edwinb/Idris2-boot
1
1
Fork 0
mirror of https://github.com/edwinb/Idris2-boot.git synced 2024-12-26 22:32:44 +03:00
Code Issues Projects Releases Wiki Activity

Add some machinery to generate C

Browse Source 
This is towards making a distribution that allows building from C,
rather than having to build from the Idris source, to make it easier to
install.
This commit is contained in:
Edwin Brady 2020-02-24 10:31:24 +00:00
parent 755d9bfd20
commit da675b38a0
35 changed files with 10015 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
Makefile
View File

@ -26,7 +26,7 @@ VALID_IDRIS_VERSION_REGEXP = "1.3.2.*"
-include custom.mk
.PHONY: ttimp idris2 prelude test base clean lib_clean check_version
.PHONY: ttimp idris2 prelude test base clean lib_clean check_version idris2c dist/idris2.c
all: idris2 libs test
@ -93,3 +93,9 @@ install-libs: libs
make -C libs/base install IDRIS2=../../idris2
make -C libs/network install IDRIS2=../../idris2 IDRIS2_VERSION=${IDRIS2_VERSION}
make -C libs/contrib install IDRIS2=../../idris2
dist/idris2.c:
idris --build idris2-mkc.ipkg
cat idris2.c dist/rts/idris_main.c > dist/idris2.c
idris2c: dist/idris2.c

2
dist/build.sh vendored Normal file
View File

@ -0,0 +1,2 @@
make -C rts
clang idris2.c -o idris2 -I rts -L rts -lidris_rts -lpthread -lgmp -lm

29
dist/config.mk vendored Normal file
View File

@ -0,0 +1,29 @@
RANLIB ?=ranlib
CFLAGS :=-O2 -Wall -std=c99 -pipe -fdata-sections -ffunction-sections -D_POSIX_C_SOURCE=200809L -DHAS_PTHREAD $(CFLAGS)
ifneq (, $(findstring bsd, $(MACHINE)))
GMP_INCLUDE_DIR :=
else
GMP_INCLUDE_DIR :=-I/usr/local/include
endif
MACHINE := $(shell $(CC) -dumpmachine)
ifneq (, $(findstring darwin, $(MACHINE)))
OS :=darwin
else ifneq (, $(findstring cygwin, $(MACHINE)))
OS :=windows
else ifneq (, $(findstring mingw, $(MACHINE)))
OS :=windows
else ifneq (, $(findstring windows, $(MACHINE)))
OS :=windows
else
OS :=unix
endif
ifeq ($(OS),darwin)
SHLIB_SUFFIX :=.dylib
else ifeq ($(OS),windows)
SHLIB_SUFFIX :=.DLL
else
SHLIB_SUFFIX :=.so
endif

41
dist/rts/Makefile vendored Normal file
View File

@ -0,0 +1,41 @@
include ../config.mk
OBJS = idris_rts.o idris_heap.o idris_gc.o idris_gmp.o idris_bitstring.o \
idris_opts.o idris_stats.o idris_utf8.o idris_stdfgn.o \
idris_buffer.o getline.o idris_net.o
HDRS = idris_rts.h idris_heap.h idris_gc.h idris_gmp.h idris_bitstring.h \
idris_opts.h idris_stats.h idris_stdfgn.h idris_net.h \
idris_buffer.h idris_utf8.h getline.h
CFLAGS := $(CFLAGS)
CFLAGS += $(GMP_INCLUDE_DIR) $(GMP) -DIDRIS_TARGET_OS="\"$(OS)\""
CFLAGS += -DIDRIS_TARGET_TRIPLE="\"$(MACHINE)\""
ifeq ($(OS), windows)
OBJS += windows/win_utils.o
else
CFLAGS += -fPIC
endif
ifndef IDRIS_GMP
OBJS += mini-gmp.o
HDRS += mini-gmp.h
endif
LIBTARGET = libidris_rts.a
build: $(LIBTARGET) $(DYLIBTARGET)
$(LIBTARGET) : $(OBJS)
$(AR) rc $(LIBTARGET) $(OBJS)
$(RANLIB) $(LIBTARGET)
install :
mkdir -p $(TARGET)
install $(LIBTARGET) $(HDRS) $(TARGET)
clean :
rm -f $(OBJS) $(LIBTARGET) $(DYLIBTARGET)
$(OBJS): $(HDRS)
.PHONY: build install clean

82
dist/rts/getline.c vendored Normal file
View File

@ -0,0 +1,82 @@
/* $NetBSD: fgetln.c,v 1.9 2008/04/29 06:53:03 martin Exp $ */
/*-
* Copyright (c) 2011 The NetBSD Foundation, Inc.
* All rights reserved.
*
* This code is derived from software contributed to The NetBSD Foundation
* by Christos Zoulas.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY THE NETBSD FOUNDATION, INC. AND CONTRIBUTORS
* ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE FOUNDATION OR CONTRIBUTORS
* BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
* CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
* ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
* POSSIBILITY OF SUCH DAMAGE.
*/
#include <stdlib.h>
#include <stdio.h>
#include <unistd.h>
#include <errno.h>
#include <string.h>
ssize_t
getdelim(char **buf, size_t *bufsiz, int delimiter, FILE *fp)
{
char *ptr, *eptr;
if (*buf == NULL || *bufsiz == 0) {
*bufsiz = BUFSIZ;
if ((*buf = malloc(*bufsiz)) == NULL)
return -1;
}
for (ptr = *buf, eptr = *buf + *bufsiz;;) {
int c = fgetc(fp);
if (c == -1) {
if (feof(fp)) {
*ptr = '\0';
return ptr - *buf;
} else {
return -1;
}
}
*ptr++ = c;
if (c == delimiter) {
*ptr = '\0';
return ptr - *buf;
}
if (ptr + 2 >= eptr) {
char *nbuf;
size_t nbufsiz = *bufsiz * 2;
ssize_t d = ptr - *buf;
if ((nbuf = realloc(*buf, nbufsiz)) == NULL)
return -1;
*buf = nbuf;
*bufsiz = nbufsiz;
eptr = nbuf + nbufsiz;
ptr = nbuf + d;
}
}
}
ssize_t
getline(char **buf, size_t *bufsiz, FILE *fp)
{
return getdelim(buf, bufsiz, '\n', fp);
}

7
dist/rts/getline.h vendored Normal file
View File

@ -0,0 +1,7 @@
#ifndef GETLINE_H
#define GETLINE_H
#include <stdlib.h>
#include <stdio.h>
ssize_t getdelim(char **buf, size_t *bufsiz, int delimiter, FILE *fp);
ssize_t getline(char **buf, size_t *bufsiz, FILE *fp);
#endif // GETLINE_H

593
dist/rts/idris_bitstring.c vendored Normal file
View File

@ -0,0 +1,593 @@
#include <assert.h>
#include "idris_rts.h"
VAL idris_b8const(VM *vm, uint8_t a) {
return MKINT(a);
}
VAL idris_b16const(VM *vm, uint16_t a) {
return MKINT(a);
}
VAL idris_b32const(VM *vm, uint32_t a) {
Bits32 * cl = iallocate(vm, sizeof(*cl), 0);
SETTY(cl, CT_BITS32);
cl->bits32 = a;
return (VAL)cl;
}
VAL idris_b64const(VM *vm, uint64_t a) {
Bits64 * cl = iallocate(vm, sizeof(*cl), 0);
SETTY(cl, CT_BITS64);
cl->bits64 = a;
return (VAL)cl;
}
VAL idris_b8(VM *vm, VAL a) {
return idris_b8const(vm, GETINT(a));
}
VAL idris_b16(VM *vm, VAL a) {
return idris_b16const(vm, GETINT(a));
}
VAL idris_b32(VM *vm, VAL a) {
return idris_b32const(vm, GETINT(a));
}
VAL idris_b64(VM *vm, VAL a) {
return idris_b64const(vm, GETINT(a));
}
VAL idris_castB32Int(VM *vm, VAL a) {
return MKINT(GETBITS32(a));
}
VAL idris_b8Plus(VM *vm, VAL a, VAL b) {
uint8_t A = GETBITS8(a);
uint8_t B = GETBITS8(b);
return idris_b8const(vm, A + B);
}
VAL idris_b8Minus(VM *vm, VAL a, VAL b) {
uint8_t A = GETBITS8(a);
uint8_t B = GETBITS8(b);
return idris_b8const(vm, A - B);
}
VAL idris_b8Times(VM *vm, VAL a, VAL b) {
uint8_t A = GETBITS8(a);
uint8_t B = GETBITS8(b);
return idris_b8const(vm, A * B);
}
VAL idris_b8UDiv(VM *vm, VAL a, VAL b) {
uint8_t A = GETBITS8(a);
uint8_t B = GETBITS8(b);
return idris_b8const(vm, A / B);
}
VAL idris_b8SDiv(VM *vm, VAL a, VAL b) {
int8_t A = GETBITS8(a);
int8_t B = GETBITS8(b);
return idris_b8const(vm, A / B);
}
VAL idris_b8URem(VM *vm, VAL a, VAL b) {
uint8_t A = GETBITS8(a);
uint8_t B = GETBITS8(b);
return idris_b8const(vm, A % B);
}
VAL idris_b8SRem(VM *vm, VAL a, VAL b) {
int8_t A = GETBITS8(a);
int8_t B = GETBITS8(b);
return idris_b8const(vm, A % B);
}
VAL idris_b8Lt(VM *vm, VAL a, VAL b) {
return MKINT((i_int) (GETBITS8(a) < GETBITS8(b)));
}
VAL idris_b8Gt(VM *vm, VAL a, VAL b) {
return MKINT((i_int) (GETBITS8(a) > GETBITS8(b)));
}
VAL idris_b8Eq(VM *vm, VAL a, VAL b) {
return MKINT((i_int) (GETBITS8(a) == GETBITS8(b)));
}
VAL idris_b8Lte(VM *vm, VAL a, VAL b) {
return MKINT((i_int) (GETBITS8(a) <= GETBITS8(b)));
}
VAL idris_b8Gte(VM *vm, VAL a, VAL b) {
return MKINT((i_int) (GETBITS8(a) >= GETBITS8(b)));
}
VAL idris_b8Compl(VM *vm, VAL a) {
uint8_t A = GETBITS8(a);
return idris_b8const(vm, ~ A);
}
VAL idris_b8And(VM *vm, VAL a, VAL b) {
uint8_t A = GETBITS8(a);
uint8_t B = GETBITS8(b);
return idris_b8const(vm, A & B);
}
VAL idris_b8Or(VM *vm, VAL a, VAL b) {
uint8_t A = GETBITS8(a);
uint8_t B = GETBITS8(b);
return idris_b8const(vm, A | B);
}
VAL idris_b8Xor(VM *vm, VAL a, VAL b) {
uint8_t A = GETBITS8(a);
uint8_t B = GETBITS8(b);
return idris_b8const(vm, A ^ B);
}
VAL idris_b8Shl(VM *vm, VAL a, VAL b) {
uint8_t A = GETBITS8(a);
uint8_t B = GETBITS8(b);
return idris_b8const(vm, A << B);
}
VAL idris_b8LShr(VM *vm, VAL a, VAL b) {
uint8_t A = GETBITS8(a);
uint8_t B = GETBITS8(b);
return idris_b8const(vm, A >> B);
}
VAL idris_b8AShr(VM *vm, VAL a, VAL b) {
int8_t A = GETBITS8(a);
int8_t B = GETBITS8(b);
return idris_b8const(vm, A >> B);
}
VAL idris_b16Plus(VM *vm, VAL a, VAL b) {
uint16_t A = GETBITS16(a);
uint16_t B = GETBITS16(b);
return idris_b16const(vm, A + B);
}
VAL idris_b16Minus(VM *vm, VAL a, VAL b) {
uint16_t A = GETBITS16(a);
uint16_t B = GETBITS16(b);
return idris_b16const(vm, A - B);
}
VAL idris_b16Times(VM *vm, VAL a, VAL b) {
uint16_t A = GETBITS16(a);
uint16_t B = GETBITS16(b);
return idris_b16const(vm, A * B);
}
VAL idris_b16UDiv(VM *vm, VAL a, VAL b) {
uint16_t A = GETBITS16(a);
uint16_t B = GETBITS16(b);
return idris_b16const(vm, A / B);
}
VAL idris_b16SDiv(VM *vm, VAL a, VAL b) {
int16_t A = GETBITS16(a);
int16_t B = GETBITS16(b);
return idris_b16const(vm, A / B);
}
VAL idris_b16URem(VM *vm, VAL a, VAL b) {
uint16_t A = GETBITS16(a);
uint16_t B = GETBITS16(b);
return idris_b16const(vm, A % B);
}
VAL idris_b16SRem(VM *vm, VAL a, VAL b) {
int16_t A = GETBITS16(a);
int16_t B = GETBITS16(b);
return idris_b16const(vm, A % B);
}
VAL idris_b16Lt(VM *vm, VAL a, VAL b) {
return MKINT((i_int) (GETBITS16(a) < GETBITS16(b)));
}
VAL idris_b16Gt(VM *vm, VAL a, VAL b) {
return MKINT((i_int) (GETBITS16(a) > GETBITS16(b)));
}
VAL idris_b16Eq(VM *vm, VAL a, VAL b) {
return MKINT((i_int) (GETBITS16(a) == GETBITS16(b)));
}
VAL idris_b16Lte(VM *vm, VAL a, VAL b) {
return MKINT((i_int) (GETBITS16(a) <= GETBITS16(b)));
}
VAL idris_b16Gte(VM *vm, VAL a, VAL b) {
return MKINT((i_int) (GETBITS16(a) >= GETBITS16(b)));
}
VAL idris_b16Compl(VM *vm, VAL a) {
uint16_t A = GETBITS16(a);
return idris_b16const(vm, ~ A);
}
VAL idris_b16And(VM *vm, VAL a, VAL b) {
uint16_t A = GETBITS16(a);
uint16_t B = GETBITS16(b);
return idris_b16const(vm, A & B);
}
VAL idris_b16Or(VM *vm, VAL a, VAL b) {
uint16_t A = GETBITS16(a);
uint16_t B = GETBITS16(b);
return idris_b16const(vm, A | B);
}
VAL idris_b16Xor(VM *vm, VAL a, VAL b) {
uint16_t A = GETBITS16(a);
uint16_t B = GETBITS16(b);
return idris_b16const(vm, A ^ B);
}
VAL idris_b16Shl(VM *vm, VAL a, VAL b) {
uint16_t A = GETBITS16(a);
uint16_t B = GETBITS16(b);
return idris_b16const(vm, A << B);
}
VAL idris_b16LShr(VM *vm, VAL a, VAL b) {
uint16_t A = GETBITS16(a);
uint16_t B = GETBITS16(b);
return idris_b16const(vm, A >> B);
}
VAL idris_b16AShr(VM *vm, VAL a, VAL b) {
int16_t A = GETBITS16(a);
int16_t B = GETBITS16(b);
return idris_b16const(vm, A >> B);
}
VAL idris_b32Plus(VM *vm, VAL a, VAL b) {
uint32_t A = GETBITS32(a);
uint32_t B = GETBITS32(b);
return idris_b32const(vm, A + B);
}
VAL idris_b32Minus(VM *vm, VAL a, VAL b) {
uint32_t A = GETBITS32(a);
uint32_t B = GETBITS32(b);
return idris_b32const(vm, A - B);
}
VAL idris_b32Times(VM *vm, VAL a, VAL b) {
uint32_t A = GETBITS32(a);
uint32_t B = GETBITS32(b);
return idris_b32const(vm, A * B);
}
VAL idris_b32UDiv(VM *vm, VAL a, VAL b) {
uint32_t A = GETBITS32(a);
uint32_t B = GETBITS32(b);
return idris_b32const(vm, A / B);
}
VAL idris_b32SDiv(VM *vm, VAL a, VAL b) {
int32_t A = GETBITS32(a);
int32_t B = GETBITS32(b);
return idris_b32const(vm, A / B);
}
VAL idris_b32URem(VM *vm, VAL a, VAL b) {
uint32_t A = GETBITS32(a);
uint32_t B = GETBITS32(b);
return idris_b32const(vm, A % B);
}
VAL idris_b32SRem(VM *vm, VAL a, VAL b) {
int32_t A = GETBITS32(a);
int32_t B = GETBITS32(b);
return idris_b32const(vm, A % B);
}
VAL idris_b32Lt(VM *vm, VAL a, VAL b) {
return MKINT((i_int) (GETBITS32(a) < GETBITS32(b)));
}
VAL idris_b32Gt(VM *vm, VAL a, VAL b) {
return MKINT((i_int) (GETBITS32(a) > GETBITS32(b)));
}
VAL idris_b32Eq(VM *vm, VAL a, VAL b) {
return MKINT((i_int) (GETBITS32(a) == GETBITS32(b)));
}
VAL idris_b32Lte(VM *vm, VAL a, VAL b) {
return MKINT((i_int) (GETBITS32(a) <= GETBITS32(b)));
}
VAL idris_b32Gte(VM *vm, VAL a, VAL b) {
return MKINT((i_int) (GETBITS32(a) >= GETBITS32(b)));
}
VAL idris_b32Compl(VM *vm, VAL a) {
uint32_t A = GETBITS32(a);
return idris_b32const(vm, ~ A);
}
VAL idris_b32And(VM *vm, VAL a, VAL b) {
uint32_t A = GETBITS32(a);
uint32_t B = GETBITS32(b);
return idris_b32const(vm, A & B);
}
VAL idris_b32Or(VM *vm, VAL a, VAL b) {
uint32_t A = GETBITS32(a);
uint32_t B = GETBITS32(b);
return idris_b32const(vm, A | B);
}
VAL idris_b32Xor(VM *vm, VAL a, VAL b) {
uint32_t A = GETBITS32(a);
uint32_t B = GETBITS32(b);
return idris_b32const(vm, A ^ B);
}
VAL idris_b32Shl(VM *vm, VAL a, VAL b) {
uint32_t A = GETBITS32(a);
uint32_t B = GETBITS32(b);
return idris_b32const(vm, A << B);
}
VAL idris_b32LShr(VM *vm, VAL a, VAL b) {
uint32_t A = GETBITS32(a);
uint32_t B = GETBITS32(b);
return idris_b32const(vm, A >> B);
}
VAL idris_b32AShr(VM *vm, VAL a, VAL b) {
int32_t A = GETBITS32(a);
int32_t B = GETBITS32(b);
return idris_b32const(vm, A >> B);
}
VAL idris_b64Plus(VM *vm, VAL a, VAL b) {
uint64_t A = GETBITS64(a);
uint64_t B = GETBITS64(b);
return idris_b64const(vm, A + B);
}
VAL idris_b64Minus(VM *vm, VAL a, VAL b) {
uint64_t A = GETBITS64(a);
uint64_t B = GETBITS64(b);
return idris_b64const(vm, A - B);
}
VAL idris_b64Times(VM *vm, VAL a, VAL b) {
uint64_t A = GETBITS64(a);
uint64_t B = GETBITS64(b);
return idris_b64const(vm, A * B);
}
VAL idris_b64UDiv(VM *vm, VAL a, VAL b) {
uint64_t A = GETBITS64(a);
uint64_t B = GETBITS64(b);
return idris_b64const(vm, A / B);
}
VAL idris_b64SDiv(VM *vm, VAL a, VAL b) {
int64_t A = GETBITS64(a);
int64_t B = GETBITS64(b);
return idris_b64const(vm, A / B);
}
VAL idris_b64URem(VM *vm, VAL a, VAL b) {
uint64_t A = GETBITS64(a);
uint64_t B = GETBITS64(b);
return idris_b64const(vm, A % B);
}
VAL idris_b64SRem(VM *vm, VAL a, VAL b) {
int64_t A = GETBITS64(a);
int64_t B = GETBITS64(b);
return idris_b64const(vm, A % B);
}
VAL idris_b64Lt(VM *vm, VAL a, VAL b) {
uint64_t A = GETBITS64(a);
uint64_t B = GETBITS64(b);
return MKINT((i_int) (A < B));
}
VAL idris_b64Gt(VM *vm, VAL a, VAL b) {
uint64_t A = GETBITS64(a);
uint64_t B = GETBITS64(b);
return MKINT((i_int) (A > B));
}
VAL idris_b64Eq(VM *vm, VAL a, VAL b) {
uint64_t A = GETBITS64(a);
uint64_t B = GETBITS64(b);
return MKINT((i_int) (A == B));
}
VAL idris_b64Lte(VM *vm, VAL a, VAL b) {
uint64_t A = GETBITS64(a);
uint64_t B = GETBITS64(b);
return MKINT((i_int) (A <= B));
}
VAL idris_b64Gte(VM *vm, VAL a, VAL b) {
uint64_t A = GETBITS64(a);
uint64_t B = GETBITS64(b);
return MKINT((i_int) (A >= B));
}
VAL idris_b64Compl(VM *vm, VAL a) {
uint64_t A = GETBITS64(a);
return idris_b64const(vm, ~ A);
}
VAL idris_b64And(VM *vm, VAL a, VAL b) {
uint64_t A = GETBITS64(a);
uint64_t B = GETBITS64(b);
return idris_b64const(vm, A & B);
}
VAL idris_b64Or(VM *vm, VAL a, VAL b) {
uint64_t A = GETBITS64(a);
uint64_t B = GETBITS64(b);
return idris_b64const(vm, A | B);
}
VAL idris_b64Xor(VM *vm, VAL a, VAL b) {
uint64_t A = GETBITS64(a);
uint64_t B = GETBITS64(b);
return idris_b64const(vm, A ^ B);
}
VAL idris_b64Shl(VM *vm, VAL a, VAL b) {
uint64_t A = GETBITS64(a);
uint64_t B = GETBITS64(b);
return idris_b64const(vm, A << B);
}
VAL idris_b64LShr(VM *vm, VAL a, VAL b) {
uint64_t A = GETBITS64(a);
uint64_t B = GETBITS64(b);
return idris_b64const(vm, A >> B);
}
VAL idris_b64AShr(VM *vm, VAL a, VAL b) {
int64_t A = GETBITS64(a);
int64_t B = GETBITS64(b);
return idris_b64const(vm, A >> B);
}
VAL idris_b8Z16(VM *vm, VAL a) {
uint8_t A = GETBITS8(a);
return idris_b16const(vm, A);
}
VAL idris_b8Z32(VM *vm, VAL a) {
uint8_t A = GETBITS8(a);
return idris_b32const(vm, A);
}
VAL idris_b8Z64(VM *vm, VAL a) {
uint8_t A = GETBITS8(a);
return idris_b64const(vm, A);
}
VAL idris_b8S16(VM *vm, VAL a) {
int8_t A = GETBITS8(a);
return idris_b16const(vm, (int16_t) A);
}
VAL idris_b8S32(VM *vm, VAL a) {
int8_t A = GETBITS8(a);
return idris_b32const(vm, (int32_t) A);
}
VAL idris_b8S64(VM *vm, VAL a) {
int8_t A = GETBITS8(a);
return idris_b64const(vm, (int64_t) A);
}
VAL idris_b16Z32(VM *vm, VAL a) {
uint16_t A = GETBITS16(a);
return idris_b32const(vm, (uint32_t) A);
}
VAL idris_b16Z64(VM *vm, VAL a) {
uint16_t A = GETBITS16(a);
return idris_b64const(vm, (uint64_t) A);
}
VAL idris_b16S32(VM *vm, VAL a) {
int16_t A = GETBITS16(a);
return idris_b32const(vm, (int32_t) A);
}
VAL idris_b16S64(VM *vm, VAL a) {
int16_t A = GETBITS16(a);
return idris_b64const(vm, (int64_t) A);
}
VAL idris_b16T8(VM *vm, VAL a) {
uint16_t A = GETBITS16(a);
return idris_b8const(vm, (uint8_t) A);
}
VAL idris_b32Z64(VM *vm, VAL a) {
uint32_t A = GETBITS32(a);
return idris_b64const(vm, (uint64_t) A);
}
VAL idris_b32S64(VM *vm, VAL a) {
int32_t A = GETBITS32(a);
return idris_b64const(vm, (int64_t) A);
}
VAL idris_b32T8(VM *vm, VAL a) {
uint32_t A = GETBITS32(a);
return idris_b8const(vm, (uint8_t) A);
}
VAL idris_b32T16(VM *vm, VAL a) {
uint32_t A = GETBITS32(a);
return idris_b16const(vm, (uint16_t) A);
}
VAL idris_b64T8(VM *vm, VAL a) {
uint64_t A = GETBITS64(a);
return idris_b8const(vm, (uint8_t) A);
}
VAL idris_b64T16(VM *vm, VAL a) {
uint64_t A = GETBITS64(a);
return idris_b16const(vm, (uint16_t) A);
}
VAL idris_b64T32(VM *vm, VAL a) {
uint64_t A = GETBITS64(a);
return idris_b32const(vm, (uint32_t) A);
}
VAL idris_peekB8(VM* vm, VAL ptr, VAL offset) {
return MKB8(vm, *(uint8_t*)((char *)GETPTR(ptr) + GETINT(offset)));
}
VAL idris_pokeB8(VAL ptr, VAL offset, VAL data) {
*(uint8_t*)((char *)GETPTR(ptr) + GETINT(offset)) = GETBITS8(data);
return MKINT(0);
}
VAL idris_peekB16(VM* vm, VAL ptr, VAL offset) {
return MKB16(vm, *(uint16_t*)((char *)GETPTR(ptr) + GETINT(offset)));
}
VAL idris_pokeB16(VAL ptr, VAL offset, VAL data) {
*(uint16_t*)((char *)GETPTR(ptr) + GETINT(offset)) = GETBITS16(data);
return MKINT(0);
}
VAL idris_peekB32(VM* vm, VAL ptr, VAL offset) {
return MKB32(vm, *(uint32_t*)((char *)GETPTR(ptr) + GETINT(offset)));
}
VAL idris_pokeB32(VAL ptr, VAL offset, VAL data) {
*(uint32_t*)((char *)GETPTR(ptr) + GETINT(offset)) = GETBITS32(data);
return MKINT(0);
}
VAL idris_peekB64(VM* vm, VAL ptr, VAL offset) {
return MKB64(vm, *(uint64_t*)((char *)GETPTR(ptr) + GETINT(offset)));
}
VAL idris_pokeB64(VAL ptr, VAL offset, VAL data) {
*(uint64_t*)((char *)GETPTR(ptr) + GETINT(offset)) = GETBITS64(data);
return MKINT(0);
}

134
dist/rts/idris_bitstring.h vendored Normal file
View File

@ -0,0 +1,134 @@
#ifndef _IDRISBITSTRING_H
#define _IDRISBITSTRING_H
VAL idris_b8(VM *vm, VAL a);
VAL idris_b16(VM *vm, VAL a);
VAL idris_b32(VM *vm, VAL a);
VAL idris_b64(VM *vm, VAL a);
VAL idris_castB32Int(VM *vm, VAL a);
VAL idris_b8const(VM *vm, uint8_t a);
VAL idris_b16const(VM *vm, uint16_t a);
VAL idris_b32const(VM *vm, uint32_t a);
VAL idris_b64const(VM *vm, uint64_t a);
VAL idris_b8Plus(VM *vm, VAL a, VAL b);
VAL idris_b8Minus(VM *vm, VAL a, VAL b);
VAL idris_b8Times(VM *vm, VAL a, VAL b);
VAL idris_b8UDiv(VM *vm, VAL a, VAL b);
VAL idris_b8SDiv(VM *vm, VAL a, VAL b);
VAL idris_b8URem(VM *vm, VAL a, VAL b);
VAL idris_b8SRem(VM *vm, VAL a, VAL b);
VAL idris_b8Lt(VM *vm, VAL a, VAL b);
VAL idris_b8Gt(VM *vm, VAL a, VAL b);
VAL idris_b8Eq(VM *vm, VAL a, VAL b);
VAL idris_b8Lte(VM *vm, VAL a, VAL b);
VAL idris_b8Gte(VM *vm, VAL a, VAL b);
VAL idris_b8Compl(VM *vm, VAL a);
VAL idris_b8And(VM *vm, VAL a, VAL b);
VAL idris_b8Or(VM *vm, VAL a, VAL b);
VAL idris_b8Neg(VM *vm, VAL a);
VAL idris_b8Xor(VM *vm, VAL a, VAL b);
VAL idris_b8Shl(VM *vm, VAL a, VAL b);
VAL idris_b8LShr(VM *vm, VAL a, VAL b);
VAL idris_b8AShr(VM *vm, VAL a, VAL b);
VAL idris_b16Eq(VM *vm, VAL a, VAL b);
VAL idris_b32Eq(VM *vm, VAL a, VAL b);
VAL idris_b64Eq(VM *vm, VAL a, VAL b);
VAL idris_b8Z16(VM *vm, VAL a);
VAL idris_b8Z32(VM *vm, VAL a);
VAL idris_b8Z64(VM *vm, VAL a);
VAL idris_b8S16(VM *vm, VAL a);
VAL idris_b8S32(VM *vm, VAL a);
VAL idris_b8S64(VM *vm, VAL a);
VAL idris_b16Plus(VM *vm, VAL a, VAL b);
VAL idris_b16Minus(VM *vm, VAL a, VAL b);
VAL idris_b16Times(VM *vm, VAL a, VAL b);
VAL idris_b16UDiv(VM *vm, VAL a, VAL b);
VAL idris_b16SDiv(VM *vm, VAL a, VAL b);
VAL idris_b16URem(VM *vm, VAL a, VAL b);
VAL idris_b16SRem(VM *vm, VAL a, VAL b);
VAL idris_b16Lt(VM *vm, VAL a, VAL b);
VAL idris_b16Gt(VM *vm, VAL a, VAL b);
VAL idris_b16Eq(VM *vm, VAL a, VAL b);
VAL idris_b16Lte(VM *vm, VAL a, VAL b);
VAL idris_b16Gte(VM *vm, VAL a, VAL b);
VAL idris_b16Compl(VM *vm, VAL a);
VAL idris_b16And(VM *vm, VAL a, VAL b);
VAL idris_b16Or(VM *vm, VAL a, VAL b);
VAL idris_b16Neg(VM *vm, VAL a);
VAL idris_b16Xor(VM *vm, VAL a, VAL b);
VAL idris_b16Shl(VM *vm, VAL a, VAL b);
VAL idris_b16LShr(VM *vm, VAL a, VAL b);
VAL idris_b16AShr(VM *vm, VAL a, VAL b);
VAL idris_b16Z32(VM *vm, VAL a);
VAL idris_b16Z64(VM *vm, VAL a);
VAL idris_b16S32(VM *vm, VAL a);
VAL idris_b16S64(VM *vm, VAL a);
VAL idris_b16T8(VM *vm, VAL a);
VAL idris_b32Plus(VM *vm, VAL a, VAL b);
VAL idris_b32Minus(VM *vm, VAL a, VAL b);
VAL idris_b32Times(VM *vm, VAL a, VAL b);
VAL idris_b32UDiv(VM *vm, VAL a, VAL b);
VAL idris_b32SDiv(VM *vm, VAL a, VAL b);
VAL idris_b32URem(VM *vm, VAL a, VAL b);
VAL idris_b32SRem(VM *vm, VAL a, VAL b);
VAL idris_b32Lt(VM *vm, VAL a, VAL b);
VAL idris_b32Gt(VM *vm, VAL a, VAL b);
VAL idris_b32Eq(VM *vm, VAL a, VAL b);
VAL idris_b32Lte(VM *vm, VAL a, VAL b);
VAL idris_b32Gte(VM *vm, VAL a, VAL b);
VAL idris_b32Compl(VM *vm, VAL a);
VAL idris_b32And(VM *vm, VAL a, VAL b);
VAL idris_b32Or(VM *vm, VAL a, VAL b);
VAL idris_b32Neg(VM *vm, VAL a);
VAL idris_b32Xor(VM *vm, VAL a, VAL b);
VAL idris_b32Shl(VM *vm, VAL a, VAL b);
VAL idris_b32LShr(VM *vm, VAL a, VAL b);
VAL idris_b32AShr(VM *vm, VAL a, VAL b);
VAL idris_b32Z64(VM *vm, VAL a);
VAL idris_b32S64(VM *vm, VAL a);
VAL idris_b32T8(VM *vm, VAL a);
VAL idris_b32T16(VM *vm, VAL a);
VAL idris_b64Plus(VM *vm, VAL a, VAL b);
VAL idris_b64Minus(VM *vm, VAL a, VAL b);
VAL idris_b64Times(VM *vm, VAL a, VAL b);
VAL idris_b64UDiv(VM *vm, VAL a, VAL b);
VAL idris_b64SDiv(VM *vm, VAL a, VAL b);
VAL idris_b64URem(VM *vm, VAL a, VAL b);
VAL idris_b64SRem(VM *vm, VAL a, VAL b);
VAL idris_b64Lt(VM *vm, VAL a, VAL b);
VAL idris_b64Gt(VM *vm, VAL a, VAL b);
VAL idris_b64Eq(VM *vm, VAL a, VAL b);
VAL idris_b64Lte(VM *vm, VAL a, VAL b);
VAL idris_b64Gte(VM *vm, VAL a, VAL b);
VAL idris_b64Compl(VM *vm, VAL a);
VAL idris_b64And(VM *vm, VAL a, VAL b);
VAL idris_b64Or(VM *vm, VAL a, VAL b);
VAL idris_b64Neg(VM *vm, VAL a);
VAL idris_b64Xor(VM *vm, VAL a, VAL b);
VAL idris_b64Shl(VM *vm, VAL a, VAL b);
VAL idris_b64LShr(VM *vm, VAL a, VAL b);
VAL idris_b64AShr(VM *vm, VAL a, VAL b);
VAL idris_b64T8(VM *vm, VAL a);
VAL idris_b64T16(VM *vm, VAL a);
VAL idris_b64T32(VM *vm, VAL a);
// memory access
VAL idris_peekB8(VM* vm, VAL ptr, VAL offset);
VAL idris_pokeB8(VAL ptr, VAL offset, VAL data);
VAL idris_peekB16(VM* vm, VAL ptr, VAL offset);
VAL idris_pokeB16(VAL ptr, VAL offset, VAL data);
VAL idris_peekB32(VM* vm, VAL ptr, VAL offset);
VAL idris_pokeB32(VAL ptr, VAL offset, VAL data);
VAL idris_peekB64(VM* vm, VAL ptr, VAL offset);
VAL idris_pokeB64(VAL ptr, VAL offset, VAL data);
#endif

146
dist/rts/idris_buffer.c vendored Normal file
View File

@ -0,0 +1,146 @@
#include "idris_rts.h"
#include "idris_buffer.h"
typedef struct {
int size;
uint8_t data[0];
} Buffer;
VAL idris_newBuffer(VM* vm, int bytes) {
size_t size = sizeof(Buffer) + bytes*sizeof(uint8_t);
Buffer* buf = malloc(size);
if (buf == NULL) {
return NULL;
}
buf->size = bytes;
memset(buf->data, 0, bytes);
void* retbuf = MKMPTR(vm, buf, size);
free(buf);
return retbuf;
}
void idris_copyBuffer(void* from, int start, int len,
void* to, int loc) {
Buffer* bfrom = from;
Buffer* bto = to;
if (loc >= 0 && loc+len <= bto->size) {
memcpy(bto->data + loc, bfrom->data + start, len);
}
}
int idris_getBufferSize(void* buffer) {
return ((Buffer*)buffer)->size;
}
void idris_setBufferByte(void* buffer, int loc, uint8_t byte) {
Buffer* b = buffer;
if (loc >= 0 && loc < b->size) {
b->data[loc] = byte;
}
}
void idris_setBufferInt(void* buffer, int loc, int val) {
Buffer* b = buffer;
if (loc >= 0 && loc+3 < b->size) {
b->data[loc] = val & 0xff;
b->data[loc+1] = (val >> 8) & 0xff;
b->data[loc+2] = (val >> 16) & 0xff;
b->data[loc+3] = (val >> 24) & 0xff;
}
}
void idris_setBufferDouble(void* buffer, int loc, double val) {
Buffer* b = buffer;
// I am not proud of this
if (loc >= 0 && loc + sizeof(double) <= b->size) {
unsigned char* c = (unsigned char*)(& val);
int i;
for (i = 0; i < sizeof(double); ++i) {
b->data[loc+i] = c[i];
}
}
}
void idris_setBufferString(void* buffer, int loc, char* str) {
Buffer* b = buffer;
int len = strlen(str);
if (loc >= 0 && loc+len <= b->size) {
memcpy((b->data)+loc, str, len);
}
}
uint8_t idris_getBufferByte(void* buffer, int loc) {
Buffer* b = buffer;
if (loc >= 0 && loc < b->size) {
return b->data[loc];
} else {
return 0;
}
}
int idris_getBufferInt(void* buffer, int loc) {
Buffer* b = buffer;
if (loc >= 0 && loc+3 < b->size) {
return b->data[loc] +
(b->data[loc+1] << 8) +
(b->data[loc+2] << 16) +
(b->data[loc+3] << 24);
} else {
return 0;
}
}
double idris_getBufferDouble(void* buffer, int loc) {
Buffer* b = buffer;
double d;
// I am even less proud of this
unsigned char *c = (unsigned char*)(& d);
if (loc >= 0 && loc + sizeof(double) <= b->size) {
int i;
for (i = 0; i < sizeof(double); ++i) {
c[i] = b->data[loc+i];
}
return d;
}
else {
return 0;
}
}
VAL idris_getBufferString(void* buffer, int loc, int len) {
Buffer* b = buffer;
char * s = (char*)(b->data + loc);
size_t sz = loc >= 0 && loc+len <= b->size? len : 0;
return MKSTRlen(get_vm(), s, sz);
}
int idris_readBuffer(FILE* h, void* buffer, int loc, int max) {
Buffer* b = buffer;
size_t len;
if (loc >= 0 && loc < b->size) {
if (loc + max > b->size) {
max = b->size - loc;
}
len = fread((b->data)+loc, sizeof(uint8_t), (size_t)max, h);
return len;
} else {
return 0;
}
}
void idris_writeBuffer(FILE* h, void* buffer, int loc, int len) {
Buffer* b = buffer;
if (loc >= 0 && loc < b->size) {
if (loc + len > b->size) {
len = b->size - loc;
}
fwrite((b->data)+loc, sizeof(uint8_t), len, h);
}
}

29
dist/rts/idris_buffer.h vendored Normal file
View File

@ -0,0 +1,29 @@
#ifndef __BUFFER_H
#define __BUFFER_H
#include <stdlib.h>
#include <stdio.h>
#include <stdint.h>
#include "idris_rts.h"
VAL idris_newBuffer(VM* vm, int bytes);
int idris_getBufferSize(void* buffer);
void idris_setBufferByte(void* buffer, int loc, uint8_t byte);
void idris_setBufferInt(void* buffer, int loc, int val);
void idris_setBufferDouble(void* buffer, int loc, double val);
void idris_setBufferString(void* buffer, int loc, char* str);
void idris_copyBuffer(void* from, int start, int len,
void* to, int loc);
int idris_readBuffer(FILE* h, void* buffer, int loc, int max);
void idris_writeBuffer(FILE* h, void* buffer, int loc, int len);
uint8_t idris_getBufferByte(void* buffer, int loc);
int idris_getBufferInt(void* buffer, int loc);
double idris_getBufferDouble(void* buffer, int loc);
VAL idris_getBufferString(void* buffer, int loc, int len);
#endif

156
dist/rts/idris_gc.c vendored Normal file
View File

@ -0,0 +1,156 @@
#include "idris_heap.h"
#include "idris_rts.h"
#include "idris_gc.h"
#include "idris_bitstring.h"
#include <assert.h>
static inline VAL copy_plain(VM* vm, VAL x, size_t sz) {
VAL cl = iallocate(vm, sz, 1);
memcpy(cl, x, sz);
return cl;
}
VAL copy(VM* vm, VAL x) {
int ar;
VAL cl;
if (x==NULL) {
return x;
}
switch(GETTY(x)) {
case CT_INT: return x;
case CT_BITS32: return copy_plain(vm, x, sizeof(Bits32));
case CT_BITS64: return copy_plain(vm, x, sizeof(Bits64));
case CT_FLOAT: return copy_plain(vm, x, sizeof(Float));
case CT_FWD:
return GETPTR(x);
case CT_CDATA:
cl = copy_plain(vm, x, sizeof(CDataC));
c_heap_mark_item(GETCDATA(x));
break;
case CT_BIGINT:
cl = MKBIGMc(vm, GETMPZ(x));
break;
case CT_CON:
ar = CARITY(x);
if (ar == 0 && CTAG(x) < 256) {
return x;
}
// FALLTHROUGH
case CT_ARRAY:
case CT_STRING:
case CT_REF:
case CT_STROFFSET:
case CT_PTR:
case CT_MANAGEDPTR:
case CT_RAWDATA:
cl = copy_plain(vm, x, x->hdr.sz);
break;
default:
cl = NULL;
assert(0);
break;
}
assert(x->hdr.sz >= sizeof(Fwd));
SETTY(x, CT_FWD);
((Fwd*)x)->fwd = cl;
return cl;
}
void cheney(VM *vm) {
char* scan = aligned_heap_pointer(vm->heap.heap);
while(scan < vm->heap.next) {
VAL heap_item = (VAL)scan;
// If it's a CT_CON, CT_REF or CT_STROFFSET, copy its arguments
switch(GETTY(heap_item)) {
case CT_CON:
{
Con * c = (Con*)heap_item;
size_t len = CARITY(c);
for(size_t i = 0; i < len; ++i)
c->args[i] = copy(vm, c->args[i]);
}
break;
case CT_ARRAY:
{
Array * a = (Array*)heap_item;
size_t len = CELEM(a);
for(size_t i = 0; i < len; ++i)
a->array[i] = copy(vm, a->array[i]);
}
break;
case CT_REF:
{
Ref * r = (Ref*)heap_item;
r->ref = copy(vm, r->ref);
}
break;
case CT_STROFFSET:
{
StrOffset * s = (StrOffset*)heap_item;
s->base = (String*)copy(vm, (VAL)s->base);
}
break;
default: // Nothing to copy
break;
}
scan += aligned(valSize(heap_item));
}
assert(scan == vm->heap.next);
}
void idris_gc(VM* vm) {
HEAP_CHECK(vm)
STATS_ENTER_GC(vm->stats, vm->heap.size)
if (vm->heap.old != NULL)
free(vm->heap.old);
/* Allocate swap heap. */
alloc_heap(&vm->heap, vm->heap.size, vm->heap.growth, vm->heap.heap);
VAL* root;
for(root = vm->valstack; root < vm->valstack_top; ++root) {
*root = copy(vm, *root);
}
#ifdef HAS_PTHREAD
Msg* msg;
for(msg = vm->inbox; msg < vm->inbox_write; ++msg) {
msg->msg = copy(vm, msg->msg);
}
#endif
vm->ret = copy(vm, vm->ret);
vm->reg1 = copy(vm, vm->reg1);
cheney(vm);
// After reallocation, if we've still more than half filled the new heap, grow the heap
// for next time.
if ((vm->heap.next - vm->heap.heap) > vm->heap.size >> 1) {
vm->heap.size += vm->heap.growth;
}
// finally, sweep the C heap
c_heap_sweep(&vm->c_heap);
STATS_LEAVE_GC(vm->stats, vm->heap.size, vm->heap.next - vm->heap.heap)
HEAP_CHECK(vm)
}
void idris_gcInfo(VM* vm, int doGC) {
printf("Stack: <BOT %p> <TOP %p>\n", vm->valstack, vm->valstack_top);
printf("Final heap size %zd\n", vm->heap.size);
printf("Final heap use %zd\n", vm->heap.next - vm->heap.heap);
if (doGC) { idris_gc(vm); }
printf("Final heap use after GC %zd\n", vm->heap.next - vm->heap.heap);
#ifdef IDRIS_ENABLE_STATS
printf("Total allocations %" PRIu64 "\n", vm->stats.allocations);
#endif
printf("Number of collections %" PRIu32 "\n", vm->stats.collections);
}

9
dist/rts/idris_gc.h vendored Normal file
View File

@ -0,0 +1,9 @@
#ifndef _IDRISGC_H
#define _IDRISGC_H
#include "idris_rts.h"
void idris_gc(VM* vm);
void idris_gcInfo(VM* vm, int doGC);
#endif

377
dist/rts/idris_gmp.c vendored Normal file
View File

@ -0,0 +1,377 @@
#include "idris_rts.h"
#ifdef IDRIS_GMP
#include <gmp.h>
#else
#include "mini-gmp.h"
#endif
#include <stdlib.h>
#include <string.h>
// TMP HACK! Require this much space in the heap before a GMP operation
// so it doesn't garbage collect in the middle.
// This is highly dodgy and needs to be done better because who knows if
// GMP will need to allocate more than 64k... better to work out how
// much space is needed (or find another way of preventing copying)
#define IDRIS_MAXGMP 65536
void init_gmpalloc(void) {
mp_set_memory_functions(idris_alloc, idris_realloc, idris_free);
}
VAL MKBIGI(int val) {
return MKINT((i_int)val);
}
static BigInt * allocBig(VM * vm) {
idris_requireAlloc(vm, IDRIS_MAXGMP);
BigInt * cl = iallocate(vm, sizeof(*cl) + sizeof(mpz_t), 0);
idris_doneAlloc(vm);
SETTY(cl, CT_BIGINT);
mpz_init(*getmpz(cl));
return cl;
}
VAL MKBIGC(VM* vm, char* val) {
if (*val == '\0') {
return MKBIGI(0);
}
else {
BigInt * cl = allocBig(vm);
mpz_set_str(*getmpz(cl), val, 10);
return (VAL)cl;
}
}
VAL MKBIGM(VM* vm, void* ibig) {
BigInt * cl = allocBig(vm);
mpz_set(*getmpz(cl), *((mpz_t*)ibig));
return (VAL)cl;
}
VAL MKBIGMc(VM* vm, void* ibig) {
BigInt * cl = allocBig(vm);
mpz_init_set(*getmpz(cl), *((mpz_t*)ibig));
return (VAL)cl;
}
VAL MKBIGUI(VM* vm, unsigned long val) {
BigInt * cl = allocBig(vm);
mpz_init_set_ui(*getmpz(cl), val);
return (VAL)cl;
}
VAL MKBIGSI(VM* vm, signed long val) {
BigInt * cl = allocBig(vm);
mpz_init_set_si(*getmpz(cl), val);
return (VAL)cl;
}
static BigInt * getbig(VM * vm, VAL x) {
switch(GETTY(x)) {
case CT_INT:
{
BigInt * cl = allocBig(vm);
mpz_set_si(*getmpz(cl), GETINT(x));
return cl;
}
case CT_FWD:
return getbig(vm, ((Fwd*)x)->fwd);
default:
return (BigInt*)x;
}
}
#define GETBIG (VAL)getbig
VAL bigAdd(VM* vm, VAL x, VAL y) {
BigInt * cl = allocBig(vm);
mpz_add(*getmpz(cl), *getmpz(getbig(vm,x)), *getmpz(getbig(vm,y)));
return (VAL)cl;
}
VAL bigSub(VM* vm, VAL x, VAL y) {
BigInt * cl = allocBig(vm);
mpz_sub(*getmpz(cl), *getmpz(getbig(vm,x)), *getmpz(getbig(vm,y)));
return (VAL)cl;
}
VAL bigMul(VM* vm, VAL x, VAL y) {
BigInt * cl = allocBig(vm);
mpz_mul(*getmpz(cl), *getmpz(getbig(vm,x)), *getmpz(getbig(vm,y)));
return (VAL)cl;
}
VAL bigDiv(VM* vm, VAL x, VAL y) {
BigInt * cl = allocBig(vm);
mpz_tdiv_q(*getmpz(cl), *getmpz(getbig(vm,x)), *getmpz(getbig(vm,y)));
return (VAL)cl;
}
VAL bigMod(VM* vm, VAL x, VAL y) {
BigInt * cl = allocBig(vm);
mpz_tdiv_r(*getmpz(cl), *getmpz(getbig(vm,x)), *getmpz(getbig(vm,y)));
return (VAL)cl;
}
VAL bigAnd(VM* vm, VAL x, VAL y) {
BigInt * cl = allocBig(vm);
mpz_and(*getmpz(cl), *getmpz(getbig(vm,x)), *getmpz(getbig(vm,y)));
return (VAL)cl;
}
VAL bigOr(VM* vm, VAL x, VAL y) {
BigInt * cl = allocBig(vm);
mpz_ior(*getmpz(cl), *getmpz(getbig(vm,x)), *getmpz(getbig(vm,y)));
return (VAL)cl;
}
VAL bigShiftLeft(VM* vm, VAL x, VAL y) {
BigInt * cl = allocBig(vm);
mpz_mul_2exp(*getmpz(cl), *getmpz(getbig(vm,x)), GETINT(y));
return (VAL)cl;
}
VAL bigLShiftRight(VM* vm, VAL x, VAL y) {
BigInt * cl = allocBig(vm);
mpz_fdiv_q_2exp(*getmpz(cl), *getmpz(getbig(vm,x)), GETINT(y));
return (VAL)cl;
}
VAL bigAShiftRight(VM* vm, VAL x, VAL y) {
BigInt * cl = allocBig(vm);
mpz_fdiv_q_2exp(*getmpz(cl), *getmpz(getbig(vm,x)), GETINT(y));
return (VAL)cl;
}
VAL idris_bigAnd(VM* vm, VAL x, VAL y) {
if (ISINT(x) && ISINT(y)) {
return INTOP(&, x, y);
} else {
return bigAnd(vm, GETBIG(vm, x), GETBIG(vm, y));
}
}
VAL idris_bigOr(VM* vm, VAL x, VAL y) {
if (ISINT(x) && ISINT(y)) {
return INTOP(|, x, y);
} else {
return bigOr(vm, GETBIG(vm, x), GETBIG(vm, y));
}
}
VAL idris_bigPlus(VM* vm, VAL x, VAL y) {
if (ISINT(x) && ISINT(y)) {
i_int vx = GETINT(x);
i_int vy = GETINT(y);
if ((vx <= 0 && vy >=0) || (vx >=0 && vy <=0)) {
return ADD(x, y);
}
i_int res = vx + vy;
if (res >= 1<<30 || res <= -(1 << 30)) {
return bigAdd(vm, GETBIG(vm, x), GETBIG(vm, y));
} else {
return MKINT(res);
}
} else {
return bigAdd(vm, GETBIG(vm, x), GETBIG(vm, y));
}
}
VAL idris_bigMinus(VM* vm, VAL x, VAL y) {
if (ISINT(x) && ISINT(y)) {
i_int vx = GETINT(x);
i_int vy = GETINT(y);
if ((vx <= 0 && vy <=0) || (vx >=0 && vy <=0)) {
return INTOP(-, x, y);
}
i_int res = vx - vy;
if (res >= 1<<30 || res <= -(1 << 30)) {
return bigSub(vm, GETBIG(vm, x), GETBIG(vm, y));
} else {
return MKINT(res);
}
} else {
return bigSub(vm, GETBIG(vm, x), GETBIG(vm, y));
}
}
VAL idris_bigTimes(VM* vm, VAL x, VAL y) {
if (ISINT(x) && ISINT(y)) {
i_int vx = GETINT(x);
i_int vy = GETINT(y);
// we could work out likelihood of overflow by checking the number
// of necessary bits. Here's a quick conservative hack instead.
if ((vx < (1<<15) && vy < (1<16)) ||
(vx < (1<<16) && vy < (1<15)) ||
(vx < (1<<20) && vy < (1<11)) ||
(vx < (1<<11) && vy < (1<20)) ||
(vx < (1<<23) && vy < (1<<8)) ||
(vx < (1<<8) && vy < (1<<23))) { // ultra-conservative!
return INTOP(*,x,y);
} else {
return bigMul(vm, GETBIG(vm, x), GETBIG(vm, y));
}
} else {
return bigMul(vm, GETBIG(vm, x), GETBIG(vm, y));
}
}
VAL idris_bigShiftLeft(VM* vm, VAL x, VAL y) {
if (ISINT(x) && ISINT(y)) {
return INTOP(<<, x, y);
} else {
return bigShiftLeft(vm, GETBIG(vm, x), y);
}
}
VAL idris_bigAShiftRight(VM* vm, VAL x, VAL y) {
if (ISINT(x) && ISINT(y)) {
return INTOP(>>, x, y);
} else {
return bigAShiftRight(vm, GETBIG(vm, x), y);
}
}
VAL idris_bigLShiftRight(VM* vm, VAL x, VAL y) {
if (ISINT(x) && ISINT(y)) {
return INTOP(>>, x, y);
} else {
return bigLShiftRight(vm, GETBIG(vm, x), y);
}
}
VAL idris_bigDivide(VM* vm, VAL x, VAL y) {
if (ISINT(x) && ISINT(y)) {
return INTOP(/, x, y);
} else {
return bigDiv(vm, GETBIG(vm, x), GETBIG(vm, y));
}
}
VAL idris_bigMod(VM* vm, VAL x, VAL y) {
if (ISINT(x) && ISINT(y)) {
return INTOP(%, x, y);
} else {
return bigMod(vm, GETBIG(vm, x), GETBIG(vm, y));
}
}
int bigEqConst(VAL x, int c) {
if (ISINT(x)) { return (GETINT(x) == c); }
else {
int rv = mpz_cmp_si(GETMPZ(x), c);
return (rv == 0);
}
}
VAL bigEq(VM* vm, VAL x, VAL y) {
return MKINT((i_int)(mpz_cmp(GETMPZ(x), GETMPZ(y)) == 0));
}
VAL bigLt(VM* vm, VAL x, VAL y) {
return MKINT((i_int)(mpz_cmp(GETMPZ(x), GETMPZ(y)) < 0));
}
VAL bigGt(VM* vm, VAL x, VAL y) {
return MKINT((i_int)(mpz_cmp(GETMPZ(x), GETMPZ(y)) > 0));
}
VAL bigLe(VM* vm, VAL x, VAL y) {
return MKINT((i_int)(mpz_cmp(GETMPZ(x), GETMPZ(y)) <= 0));
}
VAL bigGe(VM* vm, VAL x, VAL y) {
return MKINT((i_int)(mpz_cmp(GETMPZ(x), GETMPZ(y)) >= 0));
}
VAL idris_bigEq(VM* vm, VAL x, VAL y) {
if (ISINT(x) && ISINT(y)) {
return MKINT((i_int)(GETINT(x) == GETINT(y)));
} else {
return bigEq(vm, GETBIG(vm, x), GETBIG(vm, y));
}
}
VAL idris_bigLt(VM* vm, VAL x, VAL y) {
if (ISINT(x) && ISINT(y)) {
return MKINT((i_int)(GETINT(x) < GETINT(y)));
} else {
return bigLt(vm, GETBIG(vm, x), GETBIG(vm, y));
}
}
VAL idris_bigLe(VM* vm, VAL x, VAL y) {
if (ISINT(x) && ISINT(y)) {
return MKINT((i_int)(GETINT(x) <= GETINT(y)));
} else {
return bigLe(vm, GETBIG(vm, x), GETBIG(vm, y));
}
}
VAL idris_bigGt(VM* vm, VAL x, VAL y) {
if (ISINT(x) && ISINT(y)) {
return MKINT((i_int)(GETINT(x) > GETINT(y)));
} else {
return bigGt(vm, GETBIG(vm, x), GETBIG(vm, y));
}
}
VAL idris_bigGe(VM* vm, VAL x, VAL y) {
if (ISINT(x) && ISINT(y)) {
return MKINT((i_int)(GETINT(x) >= GETINT(y)));
} else {
return bigGe(vm, GETBIG(vm, x), GETBIG(vm, y));
}
}
VAL idris_castIntBig(VM* vm, VAL i) {
return i;
}
VAL idris_castBigInt(VM* vm, VAL i) {
if (ISINT(i)) {
return i;
} else {
return MKINT((i_int)(mpz_get_ui(GETMPZ(i))));
}
}
VAL idris_castBigFloat(VM* vm, VAL i) {
if (ISINT(i)) {
return MKFLOAT(vm, GETINT(i));
} else {
return MKFLOAT(vm, mpz_get_d(GETMPZ(i)));
}
}
VAL idris_castFloatBig(VM* vm, VAL f) {
double val = GETFLOAT(f);
BigInt * cl = allocBig(vm);
mpz_init_set_d(*getmpz(cl), val);
return (VAL)cl;
}
VAL idris_castStrBig(VM* vm, VAL i) {
return MKBIGC(vm, GETSTR(i));
}
VAL idris_castBigStr(VM* vm, VAL i) {
char* str = mpz_get_str(NULL, 10, *getmpz(getbig(vm, i)));
return MKSTR(vm, str);
}
// Get 64 bits out of a big int with special handling
// for systems that have 32-bit longs which needs two limbs to
// fill that.
uint64_t idris_truncBigB64(const mpz_t bi) {
if (sizeof(mp_limb_t) == 8) {
return mpz_get_ui(bi);
}
int64_t out = mpz_get_ui(bi);
if (mpz_size(bi) > 1) {
out |= ((int64_t)mpz_getlimbn(bi, 1)) << 32;
}
return out;
}

57
dist/rts/idris_gmp.h vendored Normal file
View File

@ -0,0 +1,57 @@
#ifndef _IDRISGMP_H
#define _IDRISGMP_H
#ifdef IDRIS_GMP
#include <gmp.h>
#else
#include "mini-gmp.h"
#endif
#include "idris_rts.h"
// Set memory allocation functions
void init_gmpalloc(void);
VAL MKBIGI(int val);
VAL MKBIGC(VM* vm, char* bigint);
VAL MKBIGM(VM* vm, void* bigint);
VAL MKBIGMc(VM* vm, void* bigint);
VAL MKBIGUI(VM* vm, unsigned long val);
VAL MKBIGSI(VM* vm, signed long val);
VAL idris_bigPlus(VM*, VAL x, VAL y);
VAL idris_bigMinus(VM*, VAL x, VAL y);
VAL idris_bigTimes(VM*, VAL x, VAL y);
VAL idris_bigDivide(VM*, VAL x, VAL y);
VAL idris_bigMod(VM*, VAL x, VAL y);
int bigEqConst(VAL x, int c);
VAL idris_bigEq(VM*, VAL x, VAL y);
VAL idris_bigLt(VM*, VAL x, VAL y);
VAL idris_bigLe(VM*, VAL x, VAL y);
VAL idris_bigGt(VM*, VAL x, VAL y);
VAL idris_bigGe(VM*, VAL x, VAL y);
VAL idris_castIntBig(VM* vm, VAL i);
VAL idris_castBigInt(VM* vm, VAL i);
VAL idris_castFloatBig(VM* vm, VAL i);
VAL idris_castBigFloat(VM* vm, VAL i);
VAL idris_castStrBig(VM* vm, VAL i);
VAL idris_castBigStr(VM* vm, VAL i);
VAL idris_bigAnd(VM* vm, VAL x, VAL y);
VAL idris_bigOr(VM* vm, VAL x, VAL y);
VAL idris_bigShiftLeft(VM* vm, VAL x, VAL y);
VAL idris_bigAShiftRight(VM* vm, VAL x, VAL y);
VAL idris_bigLShiftRight(VM* vm, VAL x, VAL y);
uint64_t idris_truncBigB64(const mpz_t bi);
static inline mpz_t * getmpz(BigInt * v) {
return (mpz_t*)(v->big);
}
#define GETMPZ(x) *getmpz((BigInt*)x)
#endif

242
dist/rts/idris_heap.c vendored Normal file
View File

@ -0,0 +1,242 @@
#include "idris_heap.h"
#include "idris_rts.h"
#include "idris_gc.h"
#include <stdlib.h>
#include <stddef.h>
#include <stdio.h>
#include <assert.h>
static void c_heap_free_item(CHeap * heap, CHeapItem * item)
{
assert(item->size <= heap->size);
heap->size -= item->size;
// fix links
if (item->next != NULL)
{
item->next->prev_next = item->prev_next;
}
*(item->prev_next) = item->next;
// free payload
item->finalizer(item->data);
// free item struct
free(item);
}
CHeapItem * c_heap_create_item(void * data, size_t size, CDataFinalizer * finalizer)
{
CHeapItem * item = (CHeapItem *) malloc(sizeof(CHeapItem));
item->data = data;
item->size = size;
item->finalizer = finalizer;
item->is_used = false;
item->next = NULL;
item->prev_next = NULL;
return item;
}
void c_heap_insert_if_needed(VM * vm, CHeap * heap, CHeapItem * item)
{
if (item->prev_next != NULL) return; // already inserted
if (heap->first != NULL)
{
heap->first->prev_next = &item->next;
}
item->prev_next = &heap->first;
item->next = heap->first;
heap->first = item;
// at this point, links are done; let's calculate sizes
heap->size += item->size;
if (heap->size >= heap->gc_trigger_size)
{
item->is_used = true; // don't collect what we're inserting
idris_gc(vm);
}
}
void c_heap_mark_item(CHeapItem * item)
{
item->is_used = true;
}
void c_heap_sweep(CHeap * heap)
{
CHeapItem * p = heap->first;
while (p != NULL)
{
if (p->is_used)
{
p->is_used = false;
p = p->next;
}
else
{
CHeapItem * unused_item = p;
p = p->next;
c_heap_free_item(heap, unused_item);
}
}
heap->gc_trigger_size = C_HEAP_GC_TRIGGER_SIZE(heap->size);
}
void c_heap_init(CHeap * heap)
{
heap->first = NULL;
heap->size = 0;
heap->gc_trigger_size = C_HEAP_GC_TRIGGER_SIZE(heap->size);
}
void c_heap_destroy(CHeap * heap)
{
while (heap->first != NULL)
{
c_heap_free_item(heap, heap->first); // will update heap->first via the backward link
}
}
/* Used for initializing the FP heap. */
void alloc_heap(Heap * h, size_t heap_size, size_t growth, char * old)
{
char * mem = malloc(heap_size);
if (mem == NULL) {
fprintf(stderr,
"RTS ERROR: Unable to allocate heap. Requested %zd bytes.\n",
heap_size);
exit(EXIT_FAILURE);
}
memset(mem, 0, heap_size);
h->heap = mem;
h->next = aligned_heap_pointer(h->heap);
h->end = h->heap + heap_size;
h->size = heap_size;
h->growth = growth;
h->old = old;
}
void free_heap(Heap * h) {
free(h->heap);
if (h->old != NULL) {
free(h->old);
}
}
// TODO: more testing
/******************** Heap testing ********************************************/
void heap_check_underflow(Heap * heap) {
if (!(heap->heap <= heap->next)) {
fprintf(stderr, "RTS ERROR: HEAP UNDERFLOW <bot %p> <cur %p>\n",
heap->heap, heap->next);
exit(EXIT_FAILURE);
}
}
void heap_check_overflow(Heap * heap) {
if (!(heap->next <= heap->end)) {
fprintf(stderr, "RTS ERROR: HEAP OVERFLOW <cur %p> <end %p>\n",
heap->next, heap->end);
exit(EXIT_FAILURE);
}
}
int is_valid_ref(VAL v) {
return (v != NULL) && !(ISINT(v));
}
int ref_in_heap(Heap * heap, VAL v) {
return ((VAL)heap->heap <= v) && (v < (VAL)heap->next);
}
char* aligned_heap_pointer(char * heap) {
#ifdef FORCE_ALIGNMENT
if (((i_int)heap&1) == 1) {
return (heap + 1);
} else
#endif
{
return heap;
}
}
// Checks three important properties:
// 1. Closure.
// Check if all pointers in the _heap_ points only to heap.
// 2. Unidirectionality. (if compact gc)
// All references in the heap should be are unidirectional. In other words,
// more recently allocated closure can point only to earlier allocated one.
// 3. After gc there should be no forward references.
//
void heap_check_pointers(Heap * heap) {
char* scan = NULL;
size_t item_size = 0;
for(scan = heap->heap; scan < heap->next; scan += item_size) {
VAL heap_item = (VAL)scan;
item_size = aligned(valSize(heap_item));
switch(GETTY(heap_item)) {
case CT_CON:
{
Con * c = (Con*)heap_item;
size_t ar = CARITY(c);
size_t i;
for(i = 0; i < ar; ++i) {
VAL ptr = c->args[i];
if (is_valid_ref(ptr)) {
// Check for closure.
if (!ref_in_heap(heap, ptr)) {
fprintf(stderr,
"RTS ERROR: heap closure broken. "\
"<HEAP %p %p %p> <REF %p>\n",
heap->heap, heap->next, heap->end, ptr);
exit(EXIT_FAILURE);
}
#if 0 // TODO macro
// Check for unidirectionality.
if (!(ptr < heap_item)) {
fprintf(stderr,
"RTS ERROR: heap unidirectionality broken:" \
"<CT_CON %p> <FIELD %p>\n",
heap_item, ptr);
exit(EXIT_FAILURE);
}
#endif
}
}
break;
}
case CT_FWD:
// Check for artifacts after cheney gc.
fprintf(stderr, "RTS ERROR: CT_FWD in working heap.\n");
exit(EXIT_FAILURE);
break;
default:
break;
}
}
}
void heap_check_all(Heap * heap)
{
heap_check_underflow(heap);
heap_check_overflow(heap);
heap_check_pointers(heap);
}

111
dist/rts/idris_heap.h vendored Normal file
View File

@ -0,0 +1,111 @@
#ifndef _IDRIS_HEAP_H
#define _IDRIS_HEAP_H
#include <stdbool.h>
#include <stddef.h>
/* *** C heap ***
* Objects with finalizers. Mark&sweep-collected.
*
* The C heap is implemented as a doubly linked list
* of pointers coupled with their finalizers.
*/
struct VM;
#define C_HEAP_GC_TRIGGER_SIZE(heap_size) \
(heap_size < 2048 \
? 4096 \
: 2 * heap_size \
)
typedef void CDataFinalizer(void *);
typedef struct CHeapItem {
/// Payload.
void * data;
/// Size of the item, in bytes.
/// This does not have to be a precise size. It is used to assess
/// whether the heap needs garbage collection.
size_t size;
/// Finalizer that will be called on the payload pointer.
/// Its job is to deallocate all associated resources,
/// including the memory pointed to by `data` (if any).
CDataFinalizer * finalizer;
/// The mark bit set by the FP heap traversal,
/// cleared by C heap sweep.
bool is_used;
/// Next item in the C heap.
struct CHeapItem * next;
/// Pointer to the previous next-pointer.
struct CHeapItem ** prev_next;
} CHeapItem;
typedef struct CHeap {
/// The first item in the heap. NULL if the heap is empty.
CHeapItem * first;
/// Total size of the heap. (Sum of sizes of items.)
/// This may not be a precise size since individual items'
/// sizes may be just estimates.
size_t size;
/// When heap reaches this size, GC will be triggered.
size_t gc_trigger_size;
} CHeap;
/// Create a C heap.
void c_heap_init(CHeap * c_heap);
/// Destroy the given C heap. Will not deallocate the given pointer.
/// Will call finalizers & deallocate all blocks in the heap.
void c_heap_destroy(CHeap * c_heap);
/// Insert the given item into the heap if it's not there yet.
/// The VM pointer is needed because this operation may trigger GC.
void c_heap_insert_if_needed(struct VM * vm, CHeap * c_heap, CHeapItem * item);
/// Mark the given item as used.
void c_heap_mark_item(CHeapItem * item);
/// Sweep the C heap, finalizing and freeing unused blocks.
void c_heap_sweep(CHeap * c_heap);
/// Create a C heap item from its payload, size estimate, and finalizer.
/// The size does not have to be precise but it should roughly reflect
/// how big the item is for GC to work effectively.
CHeapItem * c_heap_create_item(void * data, size_t size, CDataFinalizer * finalizer);
/* *** Idris heap **
* Objects without finalizers. Cheney-collected.
*/
typedef struct {
char* next; // Next allocated chunk. Should always (heap <= next < end).
char* heap; // Point to bottom of heap
char* end; // Point to top of heap
size_t size; // Size of _next_ heap. Size of current heap is /end - heap/.
size_t growth; // Quantity of heap growth in bytes.
char* old;
} Heap;
void alloc_heap(Heap * heap, size_t heap_size, size_t growth, char * old);
void free_heap(Heap * heap);
char* aligned_heap_pointer(char * heap);
#ifdef IDRIS_DEBUG
void heap_check_all(Heap * heap);
// Should be used _between_ gc's.
#define HEAP_CHECK(vm) heap_check_all(&(vm->heap));
#else
#define HEAP_CHECK(vm)
#endif // IDRIS_DEBUG
#endif // _IDRIS_HEAP_H

78
dist/rts/idris_main.c vendored Normal file
View File

@ -0,0 +1,78 @@
#include "idris_gmp.h"
#include "idris_opts.h"
#include "idris_rts.h"
#include "idris_stats.h"
void* _idris__123_runMain_95_0_125_(VM* vm, VAL* oldbase);
#ifdef _WIN32
#include <Windows.h>
int win32_get_argv_utf8(int *argc_ptr, char ***argv_ptr)
{
int argc;
char **argv;
wchar_t **argv_utf16 = CommandLineToArgvW(GetCommandLineW(), &argc);
int i;
int offset = (argc + 1) * sizeof(char *);
int size = offset;
for (i = 0; i < argc; i++) {
size += WideCharToMultiByte(CP_UTF8, 0, argv_utf16[i], -1, 0, 0, 0, 0);
}
argv = (char **)malloc(size);
for (i = 0; i < argc; i++) {
argv[i] = (char *)argv + offset;
offset += WideCharToMultiByte(CP_UTF8, 0, argv_utf16[i], -1, argv[i], size - offset, 0, 0);
}
*argc_ptr = argc;
*argv_ptr = argv;
return 0;
}
#endif
// The default options should give satisfactory results under many circumstances.
RTSOpts opts = {
.init_heap_size = 16384000,
.max_stack_size = 4096000,
.show_summary = 0
};
#ifdef _WIN32
int main() {
int argc;
char **argv;
win32_get_argv_utf8(&argc, &argv);
#else
int main(int argc, char **argv) {
#endif
parse_shift_args(&opts, &argc, &argv);
__idris_argc = argc;
__idris_argv = argv;
VM* vm = init_vm(opts.max_stack_size, opts.init_heap_size, 1);
init_threadkeys();
init_threaddata(vm);
init_gmpalloc();
init_nullaries();
init_signals();
_idris__123_runMain_95_0_125_(vm, NULL);
#ifdef IDRIS_DEBUG
if (opts.show_summary) {
idris_gcInfo(vm, 1);
}
#endif
Stats stats = terminate(vm);
if (opts.show_summary) {
print_stats(&stats);
}
return EXIT_SUCCESS;
}

351
dist/rts/idris_net.c vendored Normal file
View File

@ -0,0 +1,351 @@
// C-Side of the Idris network library
// (C) Simon Fowler, 2014
// MIT Licensed. Have fun!
#include "idris_net.h"
#include <errno.h>
#include <stdbool.h>
#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#ifndef _WIN32
#include <netinet/in.h>
#include <arpa/inet.h>
#else
static int socket_inited = 0;
static WSADATA wsa_data;
static void clean_sockets(void) {
WSACleanup();
}
static int check_init(void) {
if (!socket_inited) {
int result = WSAStartup(MAKEWORD(2, 2), &wsa_data);
if (result == NO_ERROR) {
socket_inited = 1;
atexit(clean_sockets);
}
}
return socket_inited;
}
#endif
void buf_htonl(void* buf, int len) {
int* buf_i = (int*) buf;
int i;
for (i = 0; i < (len / sizeof(int)) + 1; i++) {
buf_i[i] = htonl(buf_i[i]);
}
}
void buf_ntohl(void* buf, int len) {
int* buf_i = (int*) buf;
int i;
for (i = 0; i < (len / sizeof(int)) + 1; i++) {
buf_i[i] = ntohl(buf_i[i]);
}
}
void* idrnet_malloc(int size) {
return malloc(size);
}
void idrnet_free(void* ptr) {
free(ptr);
}
int idrnet_socket(int domain, int type, int protocol) {
#ifdef _WIN32
if (!check_init()) {
return -1;
}
#endif
return socket(domain, type, protocol);
}
// We call this from quite a few functions. Given a textual host and an int port,
// populates a struct addrinfo.
int idrnet_getaddrinfo(struct addrinfo** address_res, char* host, int port,
int family, int socket_type) {
struct addrinfo hints;
// Convert port into string
char str_port[8];
sprintf(str_port, "%d", port);
// Set up hints structure
memset(&hints, 0, sizeof(hints)); // zero out hints
hints.ai_family = family;
hints.ai_socktype = socket_type;
// If the length of the hostname is 0 (i.e, it was set to Nothing in Idris)
// then we want to instruct the C library to fill in the IP automatically
if (strlen(host) == 0) {
hints.ai_flags = AI_PASSIVE; // fill in IP automatically
return getaddrinfo(NULL, str_port, &hints, address_res);
}
return getaddrinfo(host, str_port, &hints, address_res);
}
int idrnet_bind(int sockfd, int family, int socket_type, char* host, int port) {
struct addrinfo* address_res;
int addr_res = idrnet_getaddrinfo(&address_res, host, port, family, socket_type);
if (addr_res != 0) {
//printf("Lib err: bind getaddrinfo\n");
return -1;
}
int bind_res = bind(sockfd, address_res->ai_addr, address_res->ai_addrlen);
if (bind_res == -1) {
//freeaddrinfo(address_res);
//printf("Lib err: bind\n");
return -1;
}
return 0;
}
int idrnet_connect(int sockfd, int family, int socket_type, char* host, int port) {
struct addrinfo* remote_host;
int addr_res = idrnet_getaddrinfo(&remote_host, host, port, family, socket_type);
if (addr_res != 0) {
return -1;
}
int connect_res = connect(sockfd, remote_host->ai_addr, remote_host->ai_addrlen);
if (connect_res == -1) {
freeaddrinfo(remote_host);
return -1;
}
freeaddrinfo(remote_host);
return 0;
}
int idrnet_sockaddr_family(void* sockaddr) {
struct sockaddr* addr = (struct sockaddr*) sockaddr;
return (int) addr->sa_family;
}
char* idrnet_sockaddr_ipv4(void* sockaddr) {
struct sockaddr_in* addr = (struct sockaddr_in*) sockaddr;
char* ip_addr = (char*) malloc(sizeof(char) * INET_ADDRSTRLEN);
inet_ntop(AF_INET, &(addr->sin_addr), ip_addr, INET_ADDRSTRLEN);
//printf("Lib: ip_addr: %s\n", ip_addr);
return ip_addr;
}
int idrnet_sockaddr_ipv4_port(void* sockaddr) {
struct sockaddr_in* addr = (struct sockaddr_in*) sockaddr;
return ((int) ntohs(addr->sin_port));
}
void* idrnet_create_sockaddr() {
return malloc(sizeof(struct sockaddr_storage));
}
int idrnet_accept(int sockfd, void* sockaddr) {
struct sockaddr* addr = (struct sockaddr*) sockaddr;
socklen_t addr_size = sizeof(struct sockaddr_storage);
return accept(sockfd, addr, &addr_size);
}
int idrnet_send(int sockfd, char* data) {
int len = strlen(data); // For now.
return send(sockfd, (void*) data, len, 0);
}
int idrnet_send_buf(int sockfd, void* data, int len) {
void* buf_cpy = malloc(len);
memset(buf_cpy, 0, len);
memcpy(buf_cpy, data, len);
buf_htonl(buf_cpy, len);
int res = send(sockfd, buf_cpy, len, 0);
free(buf_cpy);
return res;
}
void* idrnet_recv(int sockfd, int len) {
idrnet_recv_result* res_struct =
(idrnet_recv_result*) malloc(sizeof(idrnet_recv_result));
char* buf = malloc(len + 1);
memset(buf, 0, len + 1);
int recv_res = recv(sockfd, buf, len, 0);
res_struct->result = recv_res;
if (recv_res > 0) { // Data was received
buf[recv_res + 1] = 0x00; // Null-term, so Idris can interpret it
}
res_struct->payload = buf;
return (void*) res_struct;
}
int idrnet_recv_buf(int sockfd, void* buf, int len) {
int recv_res = recv(sockfd, buf, len, 0);
if (recv_res != -1) {
buf_ntohl(buf, len);
}
return recv_res;
}
int idrnet_get_recv_res(void* res_struct) {
return (((idrnet_recv_result*) res_struct)->result);
}
char* idrnet_get_recv_payload(void* res_struct) {
return (((idrnet_recv_result*) res_struct)->payload);
}
void idrnet_free_recv_struct(void* res_struct) {
idrnet_recv_result* i_res_struct =
(idrnet_recv_result*) res_struct;
if (i_res_struct->payload != NULL) {
free(i_res_struct->payload);
}
free(res_struct);
}
int idrnet_errno() {
return errno;
}
int idrnet_sendto(int sockfd, char* data, char* host, int port, int family) {
struct addrinfo* remote_host;
int addr_res = idrnet_getaddrinfo(&remote_host, host, port, family, SOCK_DGRAM);
if (addr_res != 0) {
return -1;
}
int send_res = sendto(sockfd, data, strlen(data), 0,
remote_host->ai_addr, remote_host->ai_addrlen);
freeaddrinfo(remote_host);
return send_res;
}
int idrnet_sendto_buf(int sockfd, void* buf, int buf_len, char* host, int port, int family) {
struct addrinfo* remote_host;
int addr_res = idrnet_getaddrinfo(&remote_host, host, port, family, SOCK_DGRAM);
if (addr_res != 0) {
//printf("lib err: sendto getaddrinfo \n");
return -1;
}
buf_htonl(buf, buf_len);
int send_res = sendto(sockfd, buf, buf_len, 0,
remote_host->ai_addr, remote_host->ai_addrlen);
if (send_res == -1) {
perror("lib err: sendto \n");
}
//freeaddrinfo(remote_host);
return send_res;
}
void* idrnet_recvfrom(int sockfd, int len) {
/*
* int recvfrom(int sockfd, void *buf, int len, unsigned int flags,
struct sockaddr *from, int *fromlen);
*/
// Allocate the required structures, and nuke them
struct sockaddr_storage* remote_addr =
(struct sockaddr_storage*) malloc(sizeof(struct sockaddr_storage));
char* buf = (char*) malloc(len + 1);
idrnet_recvfrom_result* ret =
(idrnet_recvfrom_result*) malloc(sizeof(idrnet_recvfrom_result));
memset(remote_addr, 0, sizeof(struct sockaddr_storage));
memset(buf, 0, len + 1);
memset(ret, 0, sizeof(idrnet_recvfrom_result));
socklen_t fromlen = sizeof(struct sockaddr_storage);
int recv_res = recvfrom(sockfd, buf, len, 0, (struct sockaddr*) remote_addr, &fromlen);
ret->result = recv_res;
// Check for failure...
if (recv_res == -1) {
free(buf);
free(remote_addr);
} else {
// If data was received, process and populate
ret->result = recv_res;
ret->remote_addr = remote_addr;
// Ensure the last byte is NULL, since in this mode we're sending strings
buf[len] = 0x00;
ret->payload = (void*) buf;
}
return ret;
}
void* idrnet_recvfrom_buf(int sockfd, void* buf, int len) {
// Allocate the required structures, and nuke them
struct sockaddr_storage* remote_addr =
(struct sockaddr_storage*) malloc(sizeof(struct sockaddr_storage));
idrnet_recvfrom_result* ret =
(idrnet_recvfrom_result*) malloc(sizeof(idrnet_recvfrom_result));
memset(remote_addr, 0, sizeof(struct sockaddr_storage));
memset(ret, 0, sizeof(idrnet_recvfrom_result));
socklen_t fromlen = 0;
int recv_res = recvfrom(sockfd, buf, len, 0, (struct sockaddr*) remote_addr, &fromlen);
// Check for failure... But don't free the buffer! Not our job.
ret->result = recv_res;
if (recv_res == -1) {
free(remote_addr);
}
// Payload will be NULL -- since it's been put into the user-specified buffer. We
// still need the return struct to get our hands on the remote address, though.
if (recv_res > 0) {
buf_ntohl(buf, len);
ret->payload = NULL;
ret->remote_addr = remote_addr;
}
return ret;
}
int idrnet_get_recvfrom_res(void* res_struct) {
return (((idrnet_recvfrom_result*) res_struct)->result);
}
char* idrnet_get_recvfrom_payload(void* res_struct) {
return (((idrnet_recvfrom_result*) res_struct)->payload);
}
void* idrnet_get_recvfrom_sockaddr(void* res_struct) {
idrnet_recvfrom_result* recv_struct = (idrnet_recvfrom_result*) res_struct;
return recv_struct->remote_addr;
}
int idrnet_get_recvfrom_port(void* res_struct) {
idrnet_recvfrom_result* recv_struct = (idrnet_recvfrom_result*) res_struct;
if (recv_struct->remote_addr != NULL) {
struct sockaddr_in* remote_addr_in =
(struct sockaddr_in*) recv_struct->remote_addr;
return ((int) ntohs(remote_addr_in->sin_port));
}
return -1;
}
void idrnet_free_recvfrom_struct(void* res_struct) {
idrnet_recvfrom_result* recv_struct = (idrnet_recvfrom_result*) res_struct;
if (recv_struct != NULL) {
if (recv_struct->payload != NULL) {
free(recv_struct->payload);
}
if (recv_struct->remote_addr != NULL) {
free(recv_struct->remote_addr);
}
}
}
int idrnet_geteagain() {
return EAGAIN;
}

91
dist/rts/idris_net.h vendored Normal file
View File

@ -0,0 +1,91 @@
#ifndef IDRISNET_H
#define IDRISNET_H
// Includes used by the idris-file.
#ifdef _WIN32
#include <winsock2.h>
#include <Ws2tcpip.h>
#else
#include <netdb.h>
#include <unistd.h>
#include <sys/types.h>
#include <sys/socket.h>
#endif
struct sockaddr_storage;
struct addrinfo;
typedef struct idrnet_recv_result {
int result;
void* payload;
} idrnet_recv_result;
// Same type of thing as idrnet_recv_result, but for UDP, so stores some
// address information
typedef struct idrnet_recvfrom_result {
int result;
void* payload;
struct sockaddr_storage* remote_addr;
} idrnet_recvfrom_result;
// Memory management functions
void* idrnet_malloc(int size);
void idrnet_free(void* ptr);
// Gets value of errno
int idrnet_errno();
int idrnet_socket(int domain, int type, int protocol);
// Bind
int idrnet_bind(int sockfd, int family, int socket_type, char* host, int port);
// Connect
int idrnet_connect(int sockfd, int family, int socket_type, char* host, int port);
// Accessor functions for struct_sockaddr
int idrnet_sockaddr_family(void* sockaddr);
char* idrnet_sockaddr_ipv4(void* sockaddr);
int idrnet_sockaddr_ipv4_port(void* sockaddr);
void* idrnet_create_sockaddr();
// Accept
int idrnet_accept(int sockfd, void* sockaddr);
// Send
int idrnet_send(int sockfd, char* data);
int idrnet_send_buf(int sockfd, void* data, int len);
// Receive
// Creates a result structure containing result and payload
void* idrnet_recv(int sockfd, int len);
// Receives directly into a buffer
int idrnet_recv_buf(int sockfd, void* buf, int len);
// UDP Send
int idrnet_sendto(int sockfd, char* data, char* host, int port, int family);
int idrnet_sendto_buf(int sockfd, void* buf, int buf_len, char* host, int port, int family);
// UDP Receive
void* idrnet_recvfrom(int sockfd, int len);
void* idrnet_recvfrom_buf(int sockfd, void* buf, int len);
// Receive structure accessors
int idrnet_get_recv_res(void* res_struct);
char* idrnet_get_recv_payload(void* res_struct);
void idrnet_free_recv_struct(void* res_struct);
// Recvfrom structure accessors
int idrnet_get_recvfrom_res(void* res_struct);
char* idrnet_get_recvfrom_payload(void* res_struct);
void* idrnet_get_recvfrom_sockaddr(void* res_struct);
void idrnet_free_recvfrom_struct(void* res_struct);
int idrnet_getaddrinfo(struct addrinfo** address_res, char* host,
int port, int family, int socket_type);
int idrnet_geteagain();
#endif

109
dist/rts/idris_opts.c vendored Normal file
View File

@ -0,0 +1,109 @@
#include "idris_opts.h"
#include <stdlib.h>
#include <stddef.h>
#include <stdio.h>
#include <string.h>
#define USAGE "\n" \
"Usage: <prog> [+RTS <rtsopts> -RTS] <args>\n\n" \
"Options:\n\n" \
" -? Print this message and exits.\n" \
" -s Summary GC statistics.\n" \
" -H Initial heap size. Egs: -H4M, -H500K, -H1G\n" \
" -K Sets the maximum stack size. Egs: -K8M\n" \
"\n"
void print_usage(FILE * s) {
fprintf(s, USAGE);
}
int read_size(char * str) {
int size = 0;
char mult = ' ';
int r = sscanf(str, "%u%c", &size, &mult);
if (r == 1)
return size;
if (r == 2) {
switch (mult) {
case 'K': size = size << 10; break;
case 'M': size = size << 20; break;
case 'G': size = size << 30; break;
default:
fprintf(stderr,
"RTS Opts: Unable to recognize size suffix `%c'.\n" \
" Possible suffixes are K or M or G.\n",
mult);
print_usage(stderr);
exit(EXIT_FAILURE);
}
return size;
}
fprintf(stderr, "RTS Opts: Unable to parse size. Egs: 1K, 10M, 2G.\n");
print_usage(stderr);
exit(EXIT_FAILURE);
}
int parse_args(RTSOpts * opts, int argc, char *argv[])
{
if (argc == 0)
return 0;
if (strcmp(argv[0], "+RTS") != 0)
return 0;
int i;
for (i = 1; i < argc; i++) {
if (strcmp(argv[i], "-RTS") == 0) {
return i + 1;
}
if (argv[i][0] != '-') {
fprintf(stderr, "RTS options should start with '-'.\n");
print_usage(stderr);
exit(EXIT_FAILURE);
}
switch (argv[i][1])
{
case '?':
print_usage(stdout);
exit(EXIT_SUCCESS);
break;
case 's':
opts->show_summary = 1;
break;
case 'H':
opts->init_heap_size = read_size(argv[i] + 2);
break;
case 'K':
opts->max_stack_size = read_size(argv[i] + 2);
break;
default:
printf("RTS opts: Wrong argument: %s\n", argv[i]);
print_usage(stderr);
exit(EXIT_FAILURE);
}
}
return argc;
}
void parse_shift_args(RTSOpts * opts, int * argc, char *** argv) {
size_t shift = parse_args(opts, (*argc) - 1, (*argv) + 1);
char *prg = (*argv)[0];
*argc = *argc - shift;
*argv = *argv + shift;
(*argv)[0] = prg;
}

19
dist/rts/idris_opts.h vendored Normal file
View File

@ -0,0 +1,19 @@
#ifndef _IDRIS_OPTS_H
#define _IDRIS_OPTS_H
#include <stddef.h>
#include <stdio.h>
typedef struct {
size_t init_heap_size;
size_t max_stack_size;
int show_summary;
} RTSOpts;
void print_usage(FILE * s);
// Parse rts options and shift arguments such that rts options becomes invisible
// for main program.
void parse_shift_args(RTSOpts * opts, int * argc, char *** argv);
#endif

1174
dist/rts/idris_rts.c vendored Normal file
View File

File diff suppressed because it is too large Load Diff

546
dist/rts/idris_rts.h vendored Normal file
View File

@ -0,0 +1,546 @@
#ifndef _IDRISRTS_H
#define _IDRISRTS_H
#include <assert.h>
#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#ifdef HAS_PTHREAD
#include <stdarg.h>
#include <pthread.h>
#endif
#include "idris_heap.h"
#include "idris_stats.h"
#ifndef EXIT_SUCCESS
#define EXIT_SUCCESS 0
#endif
#ifndef EXIT_FAILURE
#define EXIT_FAILURE 1
#endif
// Closures
typedef enum {
CT_CON, CT_ARRAY, CT_INT, CT_BIGINT,
CT_FLOAT, CT_STRING, CT_STROFFSET, CT_BITS32,
CT_BITS64, CT_PTR, CT_REF, CT_FWD,
CT_MANAGEDPTR, CT_RAWDATA, CT_CDATA
} ClosureType;
typedef struct Hdr {
uint8_t ty;
uint8_t u8;
uint16_t u16;
uint32_t sz;
} Hdr;
typedef struct Val {
Hdr hdr;
} Val;
typedef struct Val * VAL;
typedef struct Con {
Hdr hdr;
uint32_t tag;
VAL args[0];
} Con;
typedef struct Array {
Hdr hdr;
VAL array[0];
} Array;
typedef struct BigInt {
Hdr hdr;
char big[0];
} BigInt;
typedef struct Float {
Hdr hdr;
double f;
} Float;
typedef struct String {
Hdr hdr;
size_t slen;
char str[0];
} String;
typedef struct StrOffset {
Hdr hdr;
String * base;
size_t offset;
} StrOffset;
typedef struct Bits32 {
Hdr hdr;
uint32_t bits32;
} Bits32;
typedef struct Bits64 {
Hdr hdr;
uint64_t bits64;
} Bits64;
typedef struct Ptr {
Hdr hdr;
void * ptr;
} Ptr;
typedef struct Ref {
Hdr hdr;
VAL ref;
} Ref;
typedef struct Fwd {
Hdr hdr;
VAL fwd;
} Fwd;
typedef struct ManagedPtr {
Hdr hdr;
char mptr[0];
} ManagedPtr;
typedef struct RawData {
Hdr hdr;
char raw[0];
} RawData;
typedef struct CDataC {
Hdr hdr;
CHeapItem * item;
} CDataC;
struct VM;
struct Msg_t {
struct VM* sender;
// An identifier to say which conversation this message is part of.
// Lowest bit is set if the id is the first message in a conversation.
int channel_id;
VAL msg;
};
typedef struct Msg_t Msg;
struct VM {
int active; // 0 if no longer running; keep for message passing
// TODO: If we're going to have lots of concurrent threads,
// we really need to be cleverer than this!
VAL* valstack;
VAL* valstack_top;
VAL* valstack_base;
VAL* stack_max;
CHeap c_heap;
Heap heap;
#ifdef HAS_PTHREAD
pthread_mutex_t inbox_lock;
pthread_mutex_t inbox_block;
pthread_mutex_t alloc_lock;
pthread_cond_t inbox_waiting;
Msg* inbox; // Block of memory for storing messages
Msg* inbox_end; // End of block of memory
int inbox_nextid; // Next channel id
Msg* inbox_write; // Location of next message to write
int processes; // Number of child processes
int max_threads; // maximum number of threads to run in parallel
struct VM* creator; // The VM that created this VM, NULL for root VM
#endif
Stats stats;
VAL ret;
VAL reg1;
};
typedef struct VM VM;
/* C data interface: allocation on the C heap.
*
* Although not enforced in code, CData is meant to be opaque
* and non-RTS code (such as libraries or C bindings) should
* access only its (void *) field called "data".
*
* Feel free to mutate cd->data; the heap does not care
* about its particular value. However, keep in mind
* that it must not break Idris's referential transparency.
*
* If you call cdata_allocate or cdata_manage, the resulting
* CData object *must* be returned from your FFI function so
* that it is inserted in the C heap. Otherwise the memory
* will be leaked.
*/
/// C data block. Contains (void * data).
typedef CHeapItem * CData;
/// Allocate memory, returning the corresponding C data block.
CData cdata_allocate(size_t size, CDataFinalizer * finalizer);
/// Wrap a pointer as a C data block.
/// The size should be an estimate of how much memory, in bytes,
/// is associated with the pointer. This estimate need not be absolutely precise
/// but it is necessary for GC to work effectively.
CData cdata_manage(void * data, size_t size, CDataFinalizer * finalizer);
// Create a new VM
VM* init_vm(int stack_size, size_t heap_size,
int max_threads);
// Get the VM for the current thread
VM* get_vm(void);
// Initialise thread-local data for this VM
void init_threaddata(VM *vm);
// Clean up a VM once it's no longer needed
Stats terminate(VM* vm);
// Create a new VM, set up everything with sensible defaults (use when
// calling Idris from C)
VM* idris_vm(void);
void close_vm(VM* vm);
// Set up key for thread-local data - called once from idris_main
void init_threadkeys(void);
// Functions all take a pointer to their VM, and previous stack base,
// and return nothing.
typedef void*(*func)(VM*, VAL*);
// Register access
#define RVAL (vm->ret)
#define LOC(x) (vm->valstack_base[x])
#define TOP(x) (vm->valstack_top[x])
#define REG1 (vm->reg1)
// Retrieving values
static inline char * getstr(String * x) {
// hdr.u8 used to mark a null string
return x->hdr.u8? NULL : x->str;
}
static inline size_t getstrlen(String * x) {
return x->slen;
}
#define GETSTR(x) (ISSTR(x) ? getstr((String*)(x)) : GETSTROFF(x))
#define GETSTRLEN(x) (ISSTR(x) ? getstrlen((String*)(x)) : GETSTROFFLEN(x))
#define GETPTR(x) (((Ptr*)(x))->ptr)
#define GETMPTR(x) (((ManagedPtr*)(x))->mptr)
#define GETFLOAT(x) (((Float*)(x))->f)
#define GETCDATA(x) (((CDataC*)(x))->item)
#define GETBITS8(x) (GETINT(x))
#define GETBITS16(x) (GETINT(x))
#define GETBITS32(x) (((Bits32*)(x))->bits32)
#define GETBITS64(x) (((Bits64*)(x))->bits64)
// Already checked it's a CT_CON
#define CTAG(x) (((Con*)(x))->tag)
#define CARITY(x) (((Con*)(x))->hdr.u16) // hdr.u16 used to store arity
#define TAG(x) (ISINT(x) || x == NULL ? (-1) : ( GETTY(x) == CT_CON ? CTAG((Con*)x) : (-1)) )
#define ARITY(x) (ISINT(x) || x == NULL ? (-1) : ( GETTY(x) == CT_CON ? CARITY((Con*)x) : (-1)) )
#define CELEM(x) (((x)->hdr.sz - sizeof(Array)) / sizeof(VAL))
#define GETTY(x) (ISINT(x)? CT_INT : (ClosureType)((x)->hdr.ty))
#define SETTY(x,t) ((x)->hdr.ty = t)
// Integers, floats and operators
typedef intptr_t i_int;
// Shifting a negative number left is undefined and (rightly) gives a warning,
// but we're only interested in shifting the bit pattern, so cast it
#define MKINT(x) ((void*)((i_int)((((uintptr_t)x)<<1)+1)))
#define GETINT(x) ((i_int)(x)>>1)
#define ISINT(x) ((((i_int)x)&1) == 1)
#define ISSTR(x) (GETTY(x) == CT_STRING)
#define INTOP(op,x,y) MKINT((i_int)((((i_int)x)>>1) op (((i_int)y)>>1)))
#define UINTOP(op,x,y) MKINT((i_int)((((uintptr_t)x)>>1) op (((uintptr_t)y)>>1)))
#define FLOATOP(op,x,y) MKFLOAT(vm, ((GETFLOAT(x)) op (GETFLOAT(y))))
#define FLOATBOP(op,x,y) MKINT((i_int)(((GETFLOAT(x)) op (GETFLOAT(y)))))
#define ADD(x,y) (void*)(((i_int)x)+(((i_int)y)-1))
#define MULT(x,y) (MKINT((((i_int)x)>>1) * (((i_int)y)>>1)))
// Stack management
#ifdef IDRIS_TRACE
#define TRACE idris_trace(vm, __FUNCTION__, __LINE__);
#else
#define TRACE
#endif
#define INITFRAME TRACE\
__attribute__((unused)) VAL* myoldbase;\
void* callres
#define REBASE vm->valstack_base = oldbase; return NULL
#define RESERVE(x) do { \
if (vm->valstack_top+(x) > vm->stack_max) { stackOverflow(); } \
else { memset(vm->valstack_top, 0, (x)*sizeof(VAL)); } \
} while(0)
#define RESERVENOALLOC(x) do { \
if (vm->valstack_top+(x) > vm->stack_max) { stackOverflow(); } \
} while(0)
#define ADDTOP(x) vm->valstack_top += (x)
#define TOPBASE(x) vm->valstack_top = vm->valstack_base + (x)
#define BASETOP(x) vm->valstack_base = vm->valstack_top + (x)
#define STOREOLD myoldbase = vm->valstack_base
#define CALL(f) callres = f(vm, myoldbase); \
while(callres!=NULL) { \
callres = ((func)(callres))(vm, myoldbase); \
}
#define TAILCALL(f) return (void*)(f);
// Creating new values (each value placed at the top of the stack)
VAL MKFLOAT(VM* vm, double val);
VAL MKSTR(VM* vm, const char* str);
VAL MKSTRlen(VM* vm, const char* str, size_t size);
VAL MKPTR(VM* vm, void* ptr);
VAL MKMPTR(VM* vm, void* ptr, size_t size);
VAL MKB8(VM* vm, uint8_t b);
VAL MKB16(VM* vm, uint16_t b);
VAL MKB32(VM* vm, uint32_t b);
VAL MKB64(VM* vm, uint64_t b);
VAL MKCDATA(VM* vm, CHeapItem * item);
// following versions don't take a lock when allocating
VAL MKFLOATc(VM* vm, double val);
VAL MKSTROFFc(VM* vm, VAL basestr);
VAL MKSTRc(VM* vm, char* str);
VAL MKSTRclen(VM* vm, char* str, size_t len);
VAL MKPTRc(VM* vm, void* ptr);
VAL MKMPTRc(VM* vm, void* ptr, size_t size);
VAL MKCDATAc(VM* vm, CHeapItem * item);
char* GETSTROFF(VAL stroff);
size_t GETSTROFFLEN(VAL stroff);
#define SETARG(x, i, a) (((Con*)(x))->args)[i] = ((VAL)(a))
#define GETARG(x, i) (((Con*)(x))->args[i])
#define PROJECT(vm,r,loc,num) \
memcpy(&(LOC(loc)), ((Con*)(r))->args, sizeof(VAL)*num)
#define SLIDE(vm, args) \
memmove(&(LOC(0)), &(TOP(0)), sizeof(VAL)*args)
void* iallocate(VM *, size_t, int);
void* allocate(size_t size, int outerlock);
// void* allocCon(VM* vm, int arity, int outerlock);
// When allocating from C, call 'idris_requireAlloc' with a size to
// guarantee that no garbage collection will happen (and hence nothing
// will move) until at least size bytes have been allocated.
// idris_doneAlloc *must* be called when allocation from C is done (as it
// may take a lock if other threads are running).
void idris_requireAlloc(VM *, size_t size);
void idris_doneAlloc(VM *);
// public interface to allocation (note that this may move other pointers
// if allocating beyond the limits given by idris_requireAlloc!)
// 'realloc' just calls alloc and copies; 'free' does nothing
void* idris_alloc(size_t size);
void* idris_realloc(void* old, size_t old_size, size_t size);
void idris_free(void* ptr, size_t size);
static inline void updateConF(Con * cl, unsigned tag, unsigned arity) {
SETTY(cl, CT_CON);
cl->tag = tag;
// hdr.u16 used to store arity
cl->hdr.u16 = arity;
assert(cl->hdr.sz == sizeof(*cl) + sizeof(VAL) * arity);
// cl->hdr.sz = sizeof(*cl) + sizeof(VAL) * arity;
}
static inline Con * allocConF(VM * vm, unsigned tag, unsigned arity, int outer) {
Con * cl = iallocate(vm, sizeof(*cl) + sizeof(VAL) * arity, outer);
SETTY(cl, CT_CON);
cl->tag = tag;
// hdr.u16 used to store arity
cl->hdr.u16 = arity;
return cl;
}
static inline Array * allocArrayF(VM * vm, size_t len, int outer) {
Array * cl = iallocate(vm, sizeof(*cl) + sizeof(VAL) * len, outer);
SETTY(cl, CT_ARRAY);
return cl;
}
#define allocCon(cl, vm, t, a, o) (cl) = (VAL)allocConF(vm, t, a, o)
#define updateCon(cl, old, tag, arity) (cl) = (old); updateConF(cl, tag, arity)
#define NULL_CON(x) ((VAL)(nullary_cons + x))
#define allocArray(cl, vm, len, o) (cl) = (VAL)allocArrayF(vm, len, o)
int idris_errno(void);
char* idris_showerror(int err);
extern Con nullary_cons[];
void init_nullaries(void);
void init_signals(void);
void* vmThread(VM* callvm, func f, VAL arg);
void* idris_stopThread(VM* vm);
// Copy a structure to another vm's heap
VAL copyTo(VM* newVM, VAL x);
// Add a message to another VM's message queue
int idris_sendMessage(VM* sender, int channel_id, VM* dest, VAL msg);
// Check whether there are any messages in the queue and return PID of
// sender if so (null if not)
VM* idris_checkMessages(VM* vm);
// Check whether there are any messages which are initiating a conversation
// in the queue and return the message if so (without removing it)
Msg* idris_checkInitMessages(VM* vm);
// Check whether there are any messages in the queue
VM* idris_checkMessagesFrom(VM* vm, int channel_id, VM* sender);
// Check whether there are any messages in the queue, and wait if not
VM* idris_checkMessagesTimeout(VM* vm, int timeout);
// block until there is a message in the queue
Msg* idris_recvMessage(VM* vm);
// block until there is a message in the queue
Msg* idris_recvMessageFrom(VM* vm, int channel_id, VM* sender);
// Query/free structure used to return message data (recvMessage will malloc,
// so needs an explicit free)
VAL idris_getMsg(Msg* msg);
VM* idris_getSender(Msg* msg);
int idris_getChannel(Msg* msg);
void idris_freeMsg(Msg* msg);
void idris_trace(VM* vm, const char* func, int line);
void dumpVal(VAL r);
void dumpStack(VM* vm);
// Casts
#define idris_castIntFloat(x) MKFLOAT(vm, (double)(GETINT(x)))
#define idris_castFloatInt(x) MKINT((i_int)(GETFLOAT(x)))
VAL idris_castIntStr(VM* vm, VAL i);
VAL idris_castBitsStr(VM* vm, VAL i);
VAL idris_castStrInt(VM* vm, VAL i);
VAL idris_castFloatStr(VM* vm, VAL i);
VAL idris_castStrFloat(VM* vm, VAL i);
// Raw memory manipulation
void idris_memset(void* ptr, i_int offset, uint8_t c, i_int size);
void idris_memmove(void* dest, void* src, i_int dest_offset, i_int src_offset, i_int size);
uint8_t idris_peek(void* ptr, i_int offset);
void idris_poke(void* ptr, i_int offset, uint8_t data);
VAL idris_peekPtr(VM* vm, VAL ptr, VAL offset);
VAL idris_pokePtr(VAL ptr, VAL offset, VAL data);
VAL idris_peekDouble(VM* vm, VAL ptr, VAL offset);
VAL idris_pokeDouble(VAL ptr, VAL offset, VAL data);
VAL idris_peekSingle(VM* vm, VAL ptr, VAL offset);
VAL idris_pokeSingle(VAL ptr, VAL offset, VAL data);
// Crash with a message (used for partial primitives)
void idris_crash(char* msg);
// String primitives
VAL idris_concat(VM* vm, VAL l, VAL r);
VAL idris_strlt(VM* vm, VAL l, VAL r);
VAL idris_streq(VM* vm, VAL l, VAL r);
VAL idris_strlen(VM* vm, VAL l);
// Read a line from a file
VAL idris_readStr(VM* vm, FILE* h);
// Read up to 'num' characters from a file
VAL idris_readChars(VM* vm, int num, FILE* h);
VAL idris_strHead(VM* vm, VAL str);
VAL idris_strShift(VM* vm, VAL str, int num);
VAL idris_strTail(VM* vm, VAL str);
// This is not expected to be efficient! Mostly we wouldn't expect to call
// it at all at run time.
VAL idris_strCons(VM* vm, VAL x, VAL xs);
VAL idris_strIndex(VM* vm, VAL str, VAL i);
VAL idris_strRev(VM* vm, VAL str);
VAL idris_substr(VM* vm, VAL offset, VAL length, VAL str);
// Support for IORefs
VAL idris_newRefLock(VAL x, int outerlock);
VAL idris_newRef(VAL x);
void idris_writeRef(VAL ref, VAL x);
VAL idris_readRef(VAL ref);
// Support for IOArrays
VAL idris_newArray(VM* vm, int size, VAL def);
void idris_arraySet(VAL arr, int index, VAL newval);
VAL idris_arrayGet(VAL arr, int index);
// system infox
// used indices:
// 0 returns backend
// 1 returns OS
VAL idris_systemInfo(VM* vm, VAL index);
// Command line args
extern int __idris_argc;
extern char **__idris_argv;
int idris_numArgs(void);
const char *idris_getArg(int i);
// disable stdin/stdout buffering
void idris_disableBuffering(void);
#ifndef SEL4
int idris_usleep(int usec);
#endif // SEL4
// Handle stack overflow.
// Just reports an error and exits.
void stackOverflow(void);
// I think these names are nicer for an API...
#define idris_constructor allocCon
#define idris_setConArg SETARG
#define idris_getConArg GETARG
#define idris_mkInt(x) MKINT((intptr_t)(x))
#include "idris_gmp.h"
static inline size_t valSize(VAL v) {
return v->hdr.sz;
}
static inline size_t aligned(size_t sz) {
return (sz + sizeof(void*) - 1) & ~(sizeof(void*)-1);
}
VM* get_vm(void);
#endif
/*
Local variables: **
c-file-style: "bsd" **
c-basic-offset: 4 **
indent-tabs-mode: nil **
End: **
*/

68
dist/rts/idris_stats.c vendored Normal file
View File

@ -0,0 +1,68 @@
#include "idris_stats.h"
#include <stdio.h>
#include <locale.h>
#ifdef IDRIS_ENABLE_STATS
void print_stats(const Stats * stats) {
clock_t total = clock() - stats->start_time;
clock_t mut = total - stats->init_time - stats->gc_time - stats->exit_time;
double mut_sec = (double)mut / CLOCKS_PER_SEC;
uint64_t avg_chunk = 0;
if (stats->alloc_count > 0) {
avg_chunk = (uint64_t)((double)stats->allocations / (double)stats->alloc_count);
}
uint64_t alloc_rate = 0;
if (mut > 0) {
alloc_rate = (uint64_t)((double)(stats->allocations) / mut_sec);
}
double gc_percent = 0.0;
double productivity = 0.0;
if (total > 0) {
gc_percent = 100 * (double)stats->gc_time / (double)total;
productivity = 100 * ((double)mut / (double)total);
}
setlocale(LC_NUMERIC, "");
printf("\n");
printf("%'20" PRIu64 " bytes allocated in the heap\n", stats->allocations);
printf("%'20" PRIu64 " bytes copied during GC\n", stats->copied);
printf("%'20" PRIu32 " maximum heap size\n", stats->max_heap_size);
printf("%'20" PRIu32 " chunks allocated in the heap\n", stats->alloc_count);
printf("%'20" PRIu64 " average chunk size\n\n", avg_chunk);
printf("GC called %d times\n\n", stats->collections);
printf("INIT time: %8.3fs\n", (double)stats->init_time / CLOCKS_PER_SEC);
printf("MUT time: %8.3fs\n", mut_sec);
printf("GC time: %8.3fs\n", (double)stats->gc_time / CLOCKS_PER_SEC);
printf("EXIT time: %8.3fs\n", (double)stats->exit_time / CLOCKS_PER_SEC);
printf("TOTAL time: %8.3fs\n\n", (double)total / CLOCKS_PER_SEC);
printf("%%GC time: %.2f%%\n\n", gc_percent);
printf("Alloc rate %'" PRIu64 " bytes per MUT sec\n\n", alloc_rate);
printf("Productivity %.2f%%\n", productivity);
}
void aggregate_stats(Stats * stats1, const Stats * stats2) {
fprintf(stderr, "RTS error: aggregate_stats not implemented");
}
#else
void print_stats(const Stats * stats) {
fprintf(stderr, "RTS ERROR: Stats are disabled.\n" \
"By the way GC called %d times.\n", stats->collections);
}
void aggregate_stats(Stats * stats1, const Stats * stats2) {
stats1->collections += stats2->collections;
}
#endif // IDRIS_ENABLE_STATS

76
dist/rts/idris_stats.h vendored Normal file
View File

@ -0,0 +1,76 @@
#ifndef _IDRIS_STATS_H
#define _IDRIS_STATS_H
#ifdef IDRIS_ENABLE_STATS
#include <time.h>
#endif
#include <inttypes.h>
#include <stdint.h>
// TODO: measure user time, exclusive/inclusive stats
typedef struct {
#ifdef IDRIS_ENABLE_STATS
uint64_t allocations; // Size of allocated space in bytes for all execution time.
uint32_t alloc_count; // How many times alloc is called.
uint64_t copied; // Size of space copied during GC.
uint32_t max_heap_size; // Maximum heap size achieved.
clock_t init_time; // Time spent for vm initialization.
clock_t exit_time; // Time spent for vm termination.
clock_t gc_time; // Time spent for gc for all execution time.
clock_t max_gc_pause; // Time spent for longest gc.
clock_t start_time; // Time of rts entry point.
#endif // IDRIS_ENABLE_STATS
uint32_t collections; // How many times gc called.
} Stats; // without start time it's a monoid, can we remove start_time it somehow?
void print_stats(const Stats * stats);
void aggregate_stats(Stats * stats1, const Stats * stats2);
#ifdef IDRIS_ENABLE_STATS
#ifndef MAX
#define MAX(a, b) ((a) > (b) ? (a) : (b))
#endif
#define STATS_INIT_STATS(stats) \
memset(&stats, 0, sizeof(Stats)); \
stats.start_time = clock();
#define STATS_ALLOC(stats, size) \
stats.allocations += size; \
stats.alloc_count = stats.alloc_count + 1;
#define STATS_ENTER_INIT(stats) clock_t _start_time = clock();
#define STATS_LEAVE_INIT(stats) stats.init_time = clock() - _start_time;
#define STATS_ENTER_EXIT(stats) clock_t _start_time = clock();
#define STATS_LEAVE_EXIT(stats) stats.exit_time = clock() - _start_time;
#define STATS_ENTER_GC(stats, heap_size) \
clock_t _start_time = clock(); \
stats.max_heap_size = MAX(stats.max_heap_size, heap_size);
#define STATS_LEAVE_GC(stats, heap_size, heap_occuped) \
clock_t _pause = clock() - _start_time; \
stats.gc_time += _pause; \
stats.max_gc_pause = MAX(_pause, stats.max_gc_pause); \
stats.max_heap_size = MAX(stats.max_heap_size, heap_size); \
stats.copied += heap_occuped; \
stats.collections = stats.collections + 1;
#else
#define STATS_INIT_STATS(stats) memset(&stats, 0, sizeof(Stats));
#define STATS_ENTER_INIT(stats)
#define STATS_LEAVE_INIT(stats)
#define STATS_ENTER_EXIT(stats)
#define STATS_LEAVE_EXIT(stats)
#define STATS_ALLOC(stats, size)
#define STATS_ENTER_GC(stats, heap_size)
#define STATS_LEAVE_GC(stats, heap_size, heap_occuped) \
stats.collections = stats.collections + 1;
#endif // IDRIS_ENABLE_STATS
#endif // _IDRIS_STATS_H

292
dist/rts/idris_stdfgn.c vendored Normal file
View File

@ -0,0 +1,292 @@
#include "idris_stdfgn.h"
#include "idris_rts.h"
#include "idris_gmp.h"
#include "idris_gc.h"
#include <fcntl.h>
#include <errno.h>
#include <sys/stat.h>
#include <time.h>
#include <dirent.h>
#include <unistd.h>
#ifdef _WIN32
#include "windows/win_utils.h"
#else
#include <sys/select.h>
#endif
extern char** environ;
void putStr(char* str) {
printf("%s", str);
}
void *fileOpen(char *name, char *mode) {
#ifdef _WIN32
FILE *f = win32_u8fopen(name, mode);
#else
FILE *f = fopen(name, mode);
#endif
return (void *)f;
}
void fileClose(void* h) {
FILE* f = (FILE*)h;
fclose(f);
}
int fileEOF(void* h) {
FILE* f = (FILE*)h;
return feof(f);
}
int fileError(void* h) {
FILE* f = (FILE*)h;
return ferror(f);
}
int fileRemove(const char *filename) {
return remove(filename);
}
int fileSize(void* h) {
FILE* f = (FILE*)h;
int fd = fileno(f);
struct stat buf;
if (fstat(fd, &buf) == 0) {
return (int)(buf.st_size);
} else {
return -1;
}
}
VAL fileAccessTime(void* h) {
FILE* f = (FILE*)h;
int fd = fileno(f);
struct stat buf;
if (fstat(fd, &buf) == 0) {
return MKBIGI(buf.st_atime);
} else {
return MKBIGI(-1);
}
}
VAL fileModifiedTime(void* h) {
FILE* f = (FILE*)h;
int fd = fileno(f);
struct stat buf;
if (fstat(fd, &buf) == 0) {
return MKBIGI(buf.st_mtime);
} else {
return MKBIGI(-1);
}
}
VAL fileStatusTime(void* h) {
FILE* f = (FILE*)h;
int fd = fileno(f);
struct stat buf;
if (fstat(fd, &buf) == 0) {
return MKBIGI(buf.st_ctime);
} else {
return MKBIGI(-1);
}
}
typedef struct {
DIR* dirptr;
int error;
} DirInfo;
void* idris_dirOpen(char* dname) {
DIR *d = opendir(dname);
if (d == NULL) {
return NULL;
} else {
DirInfo* di = malloc(sizeof(DirInfo));
di->dirptr = d;
di->error = 0;
return (void*)di;
}
}
void idris_dirClose(void* h) {
DirInfo* di = (DirInfo*)h;
closedir(di->dirptr);
free(di);
}
char* idris_nextDirEntry(void* h) {
DirInfo* di = (DirInfo*)h;
struct dirent* de = readdir(di->dirptr);
if (de == NULL) {
di->error = -1;
return NULL;
} else {
return de->d_name;
}
}
int idris_mkdir(char* dname) {
#ifdef _WIN32
return mkdir(dname);
#else
return mkdir(dname, S_IRWXU | S_IRGRP | S_IROTH);
#endif
}
int idris_chdir(char* dname) {
return chdir(dname);
}
int idris_dirError(void *dptr) {
return ((DirInfo*)dptr)->error;
}
int idris_writeStr(void* h, char* str) {
FILE* f = (FILE*)h;
if (fputs(str, f) >= 0) {
return 0;
} else {
return -1;
}
}
int fpoll(void* h)
{
#ifdef _WIN32
return win_fpoll(h);
#else
FILE* f = (FILE*)h;
fd_set x;
struct timeval timeout;
timeout.tv_sec = 1;
timeout.tv_usec = 0;
int fd = fileno(f);
FD_ZERO(&x);
FD_SET(fd, &x);
int r = select(fd+1, &x, 0, 0, &timeout);
return r;
#endif
}
void *do_popen(const char *cmd, const char *mode) {
#ifdef _WIN32
FILE *f = win32_u8popen(cmd, mode);
#else
FILE *f = popen(cmd, mode);
// int d = fileno(f);
// fcntl(d, F_SETFL, O_NONBLOCK);
#endif
return f;
}
int isNull(void* ptr) {
return ptr==NULL;
}
void* idris_stdin() {
return (void*)stdin;
}
char* getEnvPair(int i) {
return *(environ + i);
}
VAL idris_time() {
time_t t = time(NULL);
return MKBIGI(t);
}
VAL idris_clock(VM* vm) {
VAL result;
#ifdef _WIN32
int64_t sec, nsec;
win32_gettime(&sec, &nsec);
idris_constructor(result, vm, 0, 2, 0);
idris_setConArg(result, 0, MKBIGI(sec));
idris_setConArg(result, 1, MKBIGI(nsec));
#else
struct timespec ts;
// We're not checking the result here, which is of course bad, but
// CLOCK_REALTIME is required by POSIX at least!
clock_gettime(CLOCK_REALTIME, &ts);
idris_constructor(result, vm, 0, 2, 0);
idris_setConArg(result, 0, MKBIGI(ts.tv_sec));
idris_setConArg(result, 1, MKBIGI(ts.tv_nsec));
#endif
return result;
}
VAL idris_mkFileError(VM* vm) {
VAL result;
switch(errno) {
// Make sure this corresponds to the FileError structure in
// Prelude.File
case ENOENT:
idris_constructor(result, vm, 3, 0, 0);
break;
case EACCES:
idris_constructor(result, vm, 4, 0, 0);
break;
default:
idris_constructor(result, vm, 0, 1, 0);
idris_setConArg(result, 0, MKINT((intptr_t)errno));
break;
}
return result;
}
void idris_forceGC(void* vm) {
idris_gc((VM*)vm);
}
typedef struct {
char* string;
int len;
} StrBuffer;
void* idris_makeStringBuffer(int len) {
StrBuffer* sb = malloc(sizeof(StrBuffer));
if (sb != NULL) {
sb->string = malloc(len);
sb->string[0] = '\0';
sb->len = 0;
}
return sb;
}
void idris_addToString(void* buffer, char* str) {
StrBuffer* sb = (StrBuffer*)buffer;
int len = strlen(str);
memcpy(sb->string + sb->len, str, len+1);
sb->len += len;
}
VAL idris_getString(VM* vm, void* buffer) {
StrBuffer* sb = (StrBuffer*)buffer;
VAL str = MKSTR(vm, sb->string);
free(sb->string);
free(sb);
return str;
}
VAL idris_currentDir() {
char cwd[1024];
if (getcwd(cwd, sizeof(cwd)) != NULL)
return MKSTR(get_vm(),cwd);
else
return MKSTR(get_vm(),"");
}

62
dist/rts/idris_stdfgn.h vendored Normal file
View File

@ -0,0 +1,62 @@
#ifndef _IDRISSTDFGN_H
#define _IDRISSTDFGN_H
#include "idris_rts.h"
// A collection of useful standard functions to be used by the prelude.
void putStr(char* str);
//char* readStr();
void* fileOpen(char* f, char* mode);
void fileClose(void* h);
int fileEOF(void* h);
int fileError(void* h);
int fileRemove(const char* fname);
// Returns a negative number if not a file (e.g. directory or device)
int fileSize(void* h);
// Return a negative number if not a file (e.g. directory or device)
VAL fileAccessTime(void* h);
VAL fileModifiedTime(void* h);
VAL fileStatusTime(void* h);
void* idris_dirOpen(char* dname);
void idris_dirClose(void* h);
char* idris_nextDirEntry(void* h);
// Create a directory; return 0 on success or -1 on failure
int idris_mkdir(char* dname);
int idris_chdir(char* dname);
// Return 0 if ok, or -1 if there was an error with the given directory
// (like ferror)
int idris_dirError(void *dptr);
// return 0 on success
int idris_writeStr(void*h, char* str);
// construct a file error structure (see Prelude.File) from errno
VAL idris_mkFileError(VM* vm);
// Some machinery for building a large string without reallocating
// Create a string with space for 'len' bytes
void* idris_makeStringBuffer(int len);
void idris_addToString(void* buffer, char* str);
VAL idris_getString(VM* vm, void* buffer);
void* do_popen(const char* cmd, const char* mode);
int fpoll(void* h);
int isNull(void* ptr);
void* idris_stdin();
char* getEnvPair(int i);
VAL idris_time();
VAL idris_clock(VM* vm);
void idris_forceGC();
VAL idris_currentDir();
#endif

181
dist/rts/idris_utf8.c vendored Normal file
View File

@ -0,0 +1,181 @@
#include "idris_utf8.h"
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
int idris_utf8_strlen(char *s) {
int i = 0, j = 0;
while (s[i]) {
if ((s[i] & 0xc0) != 0x80) j++;
i++;
}
return j;
}
int idris_utf8_charlen(char* s) {
int init = (int)s[0];
if ((init & 0x80) == 0) {
return 1; // Top bit unset, so 1 byte
}
if ((init > 244 && init < 256) ||
(init == 192) ||
(init == 193)) {
return 1; // Invalid characters
}
int i = 1;
while ((s[i] & 0xc0) == 0x80) {
i++; // Move on until top 2 bits are not 10
}
return i;
}
unsigned idris_utf8_index(char* s, int idx) {
int i = 0, j = 0;
while (j < idx) {
if ((s[i] & 0xc0) != 0x80) j++;
i++;
}
// Find the start of the next character
while ((s[i] & 0xc0) == 0x80) { i++; }
unsigned bytes = 0;
unsigned top = 0;
int init = (int)s[1];
// s[i] is now the start of the character we want
if ((s[i] & 0x80) == 0) {
bytes = 1;
top = (int)(s[i]);
} else if ((init > 244 && init < 256) ||
(init == 192) ||
(init == 193)) {
bytes = 1;
top = (int)(s[i]); // Invalid characters
} else if ((s[i] & 0xe0) == 0xc0) {
bytes = 2;
top = (int)(s[i] & 0x1f); // 5 bits
} else if ((s[i] & 0xf0) == 0xe0) {
bytes = 3;
top = (int)(s[i] & 0x0f); // 4 bits
} else if ((s[i] & 0xf8) == 0xf0) {
bytes = 4;
top = (int)(s[i] & 0x07); // 3 bits
} else if ((s[i] & 0xfc) == 0xf8) {
bytes = 5;
top = (int)(s[i] & 0x03); // 2 bits
} else if ((s[i] & 0xfe) == 0xfc) {
bytes = 6;
top = (int)(s[i] & 0x01); // 1 bits
}
while (bytes > 1) {
top = top << 6;
top += s[++i] & 0x3f; // 6 bits
--bytes;
}
return top;
}
char* idris_utf8_advance(char* str, int i) {
while (i > 0 && *str != '\0') {
// In a UTF8 single-byte char, the highest bit is 0. In the
// first byte of a multi-byte char, the highest two bits are
// 11, but the rest of the bytes start with 10. So we can
// decrement our character counter when we see something other
// than 10 at the front.
// This is a bit of an overapproximation, as invalid multibyte
// sequences that are too long will be treated as if they are
// OK, but it's always paying attention to null-termination.
if ((*str & 0xc0) != 0x80) {
i--;
}
str++;
}
// Now we've found the first byte of the last character. Advance
// to the end of it, or the end of the string, whichever is first.
// Here, we don't risk overrunning the end of the string because
// ('\0' & 0xc0) != 0x80.
while ((*str & 0xc0) == 0x80) { str++; }
return str;
}
int idris_utf8_findOffset(char* str, int i) {
int offset = 0;
while(i > 0) {
int len = idris_utf8_charlen(str);
str+=len;
offset+=len;
i--;
}
return offset;
}
char* idris_utf8_fromChar(int x) {
char* str;
int bytes = 0, top = 0;
if (x < 0x80) {
str = malloc(2);
str[0] = (char)x;
str[1] = '\0';
return str;
}
if (x >= 0x80 && x <= 0x7ff) {
bytes = 2;
top = 0xc0;
} else if (x >= 0x800 && x <= 0xffff) {
bytes = 3;
top = 0xe0;
} else if (x >= 0x10000 && x <= 0x10ffff) {
bytes = 4;
top = 0xf0;
}
str = malloc(bytes + 1);
str[bytes] = '\0';
while(bytes > 0) {
int xbits = x & 0x3f; // Next 6 bits
bytes--;
if (bytes > 0) {
str[bytes] = (char)xbits + 0x80;
} else {
str[0] = (char)xbits + top;
}
x = x >> 6;
}
return str;
}
void reverse_range(char *start, char *end)
{
while(start < end)
{
char c = *start;
*start++ = *end;
*end-- = c;
}
}
char* reverse_char(char *start)
{
char *end = start;
while((end[1] & 0xc0) == 0x80) { end++; }
reverse_range(start, end);
return(end + 1);
}
char* idris_utf8_rev(char* s, char* result) {
strcpy(result, s);
char* end = result;
while(*end) { end = reverse_char(end); }
reverse_range(result, end-1);
return result;
}

26
dist/rts/idris_utf8.h vendored Normal file
View File

@ -0,0 +1,26 @@
#ifndef _IDRIS_UTF8
#define _IDRIS_UTF8
/* Various functions for dealing with UTF8 encoding. These are probably
not very efficient (and I'm (EB) making no guarantees about their
correctness.) Nevertheless, they mean that we can treat Strings as
UFT8. Patches welcome :). */
// Get length of a UTF8 encoded string in characters
int idris_utf8_strlen(char *s);
// Get number of bytes the first character takes in a string
int idris_utf8_charlen(char* s);
// Return int representation of string at an index.
// Assumes in bounds.
unsigned idris_utf8_index(char* s, int j);
// Convert a char as an integer to a char* as a byte sequence
// Null terminated; caller responsible for freeing
char* idris_utf8_fromChar(int x);
// Reverse a UTF8 encoded string, putting the result in 'result'
char* idris_utf8_rev(char* s, char* result);
// Advance a pointer into a string by i UTF8 characters.
// Return original pointer if i <= 0.
char* idris_utf8_advance(char* str, int i);
// Return the offset of the ith UTF8 character in the string
int idris_utf8_findOffset(char* str, int i);
#endif

1
dist/rts/libtest.c vendored Normal file
View File

@ -0,0 +1 @@
int main() {}

4412
dist/rts/mini-gmp.c vendored Normal file
View File

File diff suppressed because it is too large Load Diff

298
dist/rts/mini-gmp.h vendored Normal file
View File

@ -0,0 +1,298 @@
/* mini-gmp, a minimalistic implementation of a GNU GMP subset.
Copyright 2011-2015 Free Software Foundation, Inc.
This file is part of the GNU MP Library.
The GNU MP Library is free software; you can redistribute it and/or modify
it under the terms of either:
* the GNU Lesser General Public License as published by the Free
Software Foundation; either version 3 of the License, or (at your
option) any later version.
or
* the GNU General Public License as published by the Free Software
Foundation; either version 2 of the License, or (at your option) any
later version.
or both in parallel, as here.
The GNU MP Library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
for more details.
You should have received copies of the GNU General Public License and the
GNU Lesser General Public License along with the GNU MP Library. If not,
see https://www.gnu.org/licenses/. */
/* About mini-gmp: This is a minimal implementation of a subset of the
GMP interface. It is intended for inclusion into applications which
have modest bignums needs, as a fallback when the real GMP library
is not installed.
This file defines the public interface. */
#ifndef __MINI_GMP_H__
#define __MINI_GMP_H__
/* For size_t */
#include <stddef.h>
#if defined (__cplusplus)
extern "C" {
#endif
void mp_set_memory_functions (void *(*) (size_t),
void *(*) (void *, size_t, size_t),
void (*) (void *, size_t));
void mp_get_memory_functions (void *(**) (size_t),
void *(**) (void *, size_t, size_t),
void (**) (void *, size_t));
typedef unsigned long mp_limb_t;
typedef long mp_size_t;
typedef unsigned long mp_bitcnt_t;
typedef mp_limb_t *mp_ptr;
typedef const mp_limb_t *mp_srcptr;
typedef struct
{
int _mp_alloc; /* Number of *limbs* allocated and pointed
to by the _mp_d field. */
int _mp_size; /* abs(_mp_size) is the number of limbs the
last field points to. If _mp_size is
negative this is a negative number. */
mp_limb_t *_mp_d; /* Pointer to the limbs. */
} __mpz_struct;
typedef __mpz_struct mpz_t[1];
typedef __mpz_struct *mpz_ptr;
typedef const __mpz_struct *mpz_srcptr;
extern const int mp_bits_per_limb;
void mpn_copyi (mp_ptr, mp_srcptr, mp_size_t);
void mpn_copyd (mp_ptr, mp_srcptr, mp_size_t);
void mpn_zero (mp_ptr, mp_size_t);
int mpn_cmp (mp_srcptr, mp_srcptr, mp_size_t);
int mpn_zero_p (mp_srcptr, mp_size_t);
mp_limb_t mpn_add_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t);
mp_limb_t mpn_add_n (mp_ptr, mp_srcptr, mp_srcptr, mp_size_t);
mp_limb_t mpn_add (mp_ptr, mp_srcptr, mp_size_t, mp_srcptr, mp_size_t);
mp_limb_t mpn_sub_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t);
mp_limb_t mpn_sub_n (mp_ptr, mp_srcptr, mp_srcptr, mp_size_t);
mp_limb_t mpn_sub (mp_ptr, mp_srcptr, mp_size_t, mp_srcptr, mp_size_t);
mp_limb_t mpn_mul_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t);
mp_limb_t mpn_addmul_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t);
mp_limb_t mpn_submul_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t);
mp_limb_t mpn_mul (mp_ptr, mp_srcptr, mp_size_t, mp_srcptr, mp_size_t);
void mpn_mul_n (mp_ptr, mp_srcptr, mp_srcptr, mp_size_t);
void mpn_sqr (mp_ptr, mp_srcptr, mp_size_t);
int mpn_perfect_square_p (mp_srcptr, mp_size_t);
mp_size_t mpn_sqrtrem (mp_ptr, mp_ptr, mp_srcptr, mp_size_t);
mp_limb_t mpn_lshift (mp_ptr, mp_srcptr, mp_size_t, unsigned int);
mp_limb_t mpn_rshift (mp_ptr, mp_srcptr, mp_size_t, unsigned int);
mp_bitcnt_t mpn_scan0 (mp_srcptr, mp_bitcnt_t);
mp_bitcnt_t mpn_scan1 (mp_srcptr, mp_bitcnt_t);
void mpn_com (mp_ptr, mp_srcptr, mp_size_t);
mp_limb_t mpn_neg (mp_ptr, mp_srcptr, mp_size_t);
mp_bitcnt_t mpn_popcount (mp_srcptr, mp_size_t);
mp_limb_t mpn_invert_3by2 (mp_limb_t, mp_limb_t);
#define mpn_invert_limb(x) mpn_invert_3by2 ((x), 0)
size_t mpn_get_str (unsigned char *, int, mp_ptr, mp_size_t);
mp_size_t mpn_set_str (mp_ptr, const unsigned char *, size_t, int);
void mpz_init (mpz_t);
void mpz_init2 (mpz_t, mp_bitcnt_t);
void mpz_clear (mpz_t);
#define mpz_odd_p(z) (((z)->_mp_size != 0) & (int) (z)->_mp_d[0])
#define mpz_even_p(z) (! mpz_odd_p (z))
int mpz_sgn (const mpz_t);
int mpz_cmp_si (const mpz_t, long);
int mpz_cmp_ui (const mpz_t, unsigned long);
int mpz_cmp (const mpz_t, const mpz_t);
int mpz_cmpabs_ui (const mpz_t, unsigned long);
int mpz_cmpabs (const mpz_t, const mpz_t);
int mpz_cmp_d (const mpz_t, double);
int mpz_cmpabs_d (const mpz_t, double);
void mpz_abs (mpz_t, const mpz_t);
void mpz_neg (mpz_t, const mpz_t);
void mpz_swap (mpz_t, mpz_t);
void mpz_add_ui (mpz_t, const mpz_t, unsigned long);
void mpz_add (mpz_t, const mpz_t, const mpz_t);
void mpz_sub_ui (mpz_t, const mpz_t, unsigned long);
void mpz_ui_sub (mpz_t, unsigned long, const mpz_t);
void mpz_sub (mpz_t, const mpz_t, const mpz_t);
void mpz_mul_si (mpz_t, const mpz_t, long int);
void mpz_mul_ui (mpz_t, const mpz_t, unsigned long int);
void mpz_mul (mpz_t, const mpz_t, const mpz_t);
void mpz_mul_2exp (mpz_t, const mpz_t, mp_bitcnt_t);
void mpz_addmul_ui (mpz_t, const mpz_t, unsigned long int);
void mpz_addmul (mpz_t, const mpz_t, const mpz_t);
void mpz_submul_ui (mpz_t, const mpz_t, unsigned long int);
void mpz_submul (mpz_t, const mpz_t, const mpz_t);
void mpz_cdiv_qr (mpz_t, mpz_t, const mpz_t, const mpz_t);
void mpz_fdiv_qr (mpz_t, mpz_t, const mpz_t, const mpz_t);
void mpz_tdiv_qr (mpz_t, mpz_t, const mpz_t, const mpz_t);
void mpz_cdiv_q (mpz_t, const mpz_t, const mpz_t);
void mpz_fdiv_q (mpz_t, const mpz_t, const mpz_t);
void mpz_tdiv_q (mpz_t, const mpz_t, const mpz_t);
void mpz_cdiv_r (mpz_t, const mpz_t, const mpz_t);
void mpz_fdiv_r (mpz_t, const mpz_t, const mpz_t);
void mpz_tdiv_r (mpz_t, const mpz_t, const mpz_t);
void mpz_cdiv_q_2exp (mpz_t, const mpz_t, mp_bitcnt_t);
void mpz_fdiv_q_2exp (mpz_t, const mpz_t, mp_bitcnt_t);
void mpz_tdiv_q_2exp (mpz_t, const mpz_t, mp_bitcnt_t);
void mpz_cdiv_r_2exp (mpz_t, const mpz_t, mp_bitcnt_t);
void mpz_fdiv_r_2exp (mpz_t, const mpz_t, mp_bitcnt_t);
void mpz_tdiv_r_2exp (mpz_t, const mpz_t, mp_bitcnt_t);
void mpz_mod (mpz_t, const mpz_t, const mpz_t);
void mpz_divexact (mpz_t, const mpz_t, const mpz_t);
int mpz_divisible_p (const mpz_t, const mpz_t);
int mpz_congruent_p (const mpz_t, const mpz_t, const mpz_t);
unsigned long mpz_cdiv_qr_ui (mpz_t, mpz_t, const mpz_t, unsigned long);
unsigned long mpz_fdiv_qr_ui (mpz_t, mpz_t, const mpz_t, unsigned long);
unsigned long mpz_tdiv_qr_ui (mpz_t, mpz_t, const mpz_t, unsigned long);
unsigned long mpz_cdiv_q_ui (mpz_t, const mpz_t, unsigned long);
unsigned long mpz_fdiv_q_ui (mpz_t, const mpz_t, unsigned long);
unsigned long mpz_tdiv_q_ui (mpz_t, const mpz_t, unsigned long);
unsigned long mpz_cdiv_r_ui (mpz_t, const mpz_t, unsigned long);
unsigned long mpz_fdiv_r_ui (mpz_t, const mpz_t, unsigned long);
unsigned long mpz_tdiv_r_ui (mpz_t, const mpz_t, unsigned long);
unsigned long mpz_cdiv_ui (const mpz_t, unsigned long);
unsigned long mpz_fdiv_ui (const mpz_t, unsigned long);
unsigned long mpz_tdiv_ui (const mpz_t, unsigned long);
unsigned long mpz_mod_ui (mpz_t, const mpz_t, unsigned long);
void mpz_divexact_ui (mpz_t, const mpz_t, unsigned long);
int mpz_divisible_ui_p (const mpz_t, unsigned long);
unsigned long mpz_gcd_ui (mpz_t, const mpz_t, unsigned long);
void mpz_gcd (mpz_t, const mpz_t, const mpz_t);
void mpz_gcdext (mpz_t, mpz_t, mpz_t, const mpz_t, const mpz_t);
void mpz_lcm_ui (mpz_t, const mpz_t, unsigned long);
void mpz_lcm (mpz_t, const mpz_t, const mpz_t);
int mpz_invert (mpz_t, const mpz_t, const mpz_t);
void mpz_sqrtrem (mpz_t, mpz_t, const mpz_t);
void mpz_sqrt (mpz_t, const mpz_t);
int mpz_perfect_square_p (const mpz_t);
void mpz_pow_ui (mpz_t, const mpz_t, unsigned long);
void mpz_ui_pow_ui (mpz_t, unsigned long, unsigned long);
void mpz_powm (mpz_t, const mpz_t, const mpz_t, const mpz_t);
void mpz_powm_ui (mpz_t, const mpz_t, unsigned long, const mpz_t);
void mpz_rootrem (mpz_t, mpz_t, const mpz_t, unsigned long);
int mpz_root (mpz_t, const mpz_t, unsigned long);
void mpz_fac_ui (mpz_t, unsigned long);
void mpz_bin_uiui (mpz_t, unsigned long, unsigned long);
int mpz_probab_prime_p (const mpz_t, int);
int mpz_tstbit (const mpz_t, mp_bitcnt_t);
void mpz_setbit (mpz_t, mp_bitcnt_t);
void mpz_clrbit (mpz_t, mp_bitcnt_t);
void mpz_combit (mpz_t, mp_bitcnt_t);
void mpz_com (mpz_t, const mpz_t);
void mpz_and (mpz_t, const mpz_t, const mpz_t);
void mpz_ior (mpz_t, const mpz_t, const mpz_t);
void mpz_xor (mpz_t, const mpz_t, const mpz_t);
mp_bitcnt_t mpz_popcount (const mpz_t);
mp_bitcnt_t mpz_hamdist (const mpz_t, const mpz_t);
mp_bitcnt_t mpz_scan0 (const mpz_t, mp_bitcnt_t);
mp_bitcnt_t mpz_scan1 (const mpz_t, mp_bitcnt_t);
int mpz_fits_slong_p (const mpz_t);
int mpz_fits_ulong_p (const mpz_t);
long int mpz_get_si (const mpz_t);
unsigned long int mpz_get_ui (const mpz_t);
double mpz_get_d (const mpz_t);
size_t mpz_size (const mpz_t);
mp_limb_t mpz_getlimbn (const mpz_t, mp_size_t);
void mpz_realloc2 (mpz_t, mp_bitcnt_t);
mp_srcptr mpz_limbs_read (mpz_srcptr);
mp_ptr mpz_limbs_modify (mpz_t, mp_size_t);
mp_ptr mpz_limbs_write (mpz_t, mp_size_t);
void mpz_limbs_finish (mpz_t, mp_size_t);
mpz_srcptr mpz_roinit_n (mpz_t, mp_srcptr, mp_size_t);
#define MPZ_ROINIT_N(xp, xs) {{0, (xs),(xp) }}
void mpz_set_si (mpz_t, signed long int);
void mpz_set_ui (mpz_t, unsigned long int);
void mpz_set (mpz_t, const mpz_t);
void mpz_set_d (mpz_t, double);
void mpz_init_set_si (mpz_t, signed long int);
void mpz_init_set_ui (mpz_t, unsigned long int);
void mpz_init_set (mpz_t, const mpz_t);
void mpz_init_set_d (mpz_t, double);
size_t mpz_sizeinbase (const mpz_t, int);
char *mpz_get_str (char *, int, const mpz_t);
int mpz_set_str (mpz_t, const char *, int);
int mpz_init_set_str (mpz_t, const char *, int);
/* This long list taken from gmp.h. */
/* For reference, "defined(EOF)" cannot be used here. In g++ 2.95.4,
<iostream> defines EOF but not FILE. */
#if defined (FILE) \
|| defined (H_STDIO) \
|| defined (_H_STDIO) /* AIX */ \
|| defined (_STDIO_H) /* glibc, Sun, SCO */ \
|| defined (_STDIO_H_) /* BSD, OSF */ \
|| defined (__STDIO_H) /* Borland */ \
|| defined (__STDIO_H__) /* IRIX */ \
|| defined (_STDIO_INCLUDED) /* HPUX */ \
|| defined (__dj_include_stdio_h_) /* DJGPP */ \
|| defined (_FILE_DEFINED) /* Microsoft */ \
|| defined (__STDIO__) /* Apple MPW MrC */ \
|| defined (_MSL_STDIO_H) /* Metrowerks */ \
|| defined (_STDIO_H_INCLUDED) /* QNX4 */ \
|| defined (_ISO_STDIO_ISO_H) /* Sun C++ */ \
|| defined (__STDIO_LOADED) /* VMS */
size_t mpz_out_str (FILE *, int, const mpz_t);
#endif
void mpz_import (mpz_t, size_t, int, size_t, int, size_t, const void *);
void *mpz_export (void *, size_t *, int, size_t, int, size_t, const mpz_t);
#if defined (__cplusplus)
}
#endif
#endif /* __MINI_GMP_H__ */

67
dist/rts/windows/win_utils.c vendored Normal file
View File

@ -0,0 +1,67 @@
#include <io.h>
#include <stdint.h>
#include <stdio.h>
#include <windows.h>
// THis file exists to avoid clashes between windows.h and idris_rts.h
//
int win_fpoll(void *h)
{
HANDLE wh =(HANDLE) _get_osfhandle(_fileno((FILE *)h));
if (wh == INVALID_HANDLE_VALUE) {
return -1;
}
DWORD ret = WaitForSingleObject(wh, 1000);
// Imitate the return values of select()
if (ret == WAIT_OBJECT_0)
return 1;
if (ret == WAIT_TIMEOUT)
return 0;
return -1;
}
int widen_utf8(const char *filename_utf8, LPWSTR *filename_w)
{
int num_chars = MultiByteToWideChar(CP_UTF8, 0, filename_utf8, -1, 0, 0);
int size = sizeof(WCHAR);
*filename_w = (LPWSTR)malloc(size * num_chars);
MultiByteToWideChar(CP_UTF8, 0, filename_utf8, -1, *filename_w, num_chars);
return num_chars;
}
FILE *win32_u8fopen(const char *path, const char *mode)
{
LPWSTR wpath, wmode;
widen_utf8(path, &wpath);
widen_utf8(mode, &wmode);
FILE *f = _wfopen(wpath, wmode);
free(wpath);
free(wmode);
return f;
}
FILE *win32_u8popen(const char *path, const char *mode)
{
LPWSTR wpath, wmode;
widen_utf8(path, &wpath);
widen_utf8(mode, &wmode);
FILE *f = _wpopen(wpath, wmode);
free(wpath);
free(wmode);
return f;
}
void win32_gettime(int64_t* sec, int64_t* nsec)
{
FILETIME ft;
GetSystemTimePreciseAsFileTime(&ft);
ULARGE_INTEGER t;
t.HighPart = ft.dwHighDateTime;
t.LowPart = ft.dwLowDateTime;
*nsec = (t.QuadPart % 10000000)*100;
*sec = t.QuadPart / 10000000;
*sec -= 11644473600; // LDAP epoch to Unix epoch
}

9
dist/rts/windows/win_utils.h vendored Normal file
View File

@ -0,0 +1,9 @@
#include <stdint.h>
#include <stdio.h>
#pragma once
int win_fpoll(void *h);
FILE *win32_u8fopen(const char *path, const char *mode);
FILE *win32_u8popen(const char *path, const char *mode);
void win32_gettime(int64_t* sec, int64_t* nsec);

133
idris2-mkc.ipkg Normal file
View File

@ -0,0 +1,133 @@
package idris2
modules =
Compiler.Common,
Compiler.CompileExpr,
Compiler.Inline,
Compiler.Scheme.Chez,
Compiler.Scheme.Chicken,
Compiler.Scheme.Racket,
Compiler.Scheme.Common,
Control.Delayed,
Core.AutoSearch,
Core.Binary,
Core.CaseBuilder,
Core.CaseTree,
Core.Context,
Core.CompileExpr,
Core.Core,
Core.Coverage,
Core.Directory,
Core.Env,
Core.FC,
Core.GetType,
Core.Hash,
Core.LinearCheck,
Core.Metadata,
Core.Name,
Core.Normalise,
Core.Options,
Core.Reflect,
Core.Termination,
Core.TT,
Core.TTC,
Core.Unify,
Core.UnifyState,
Core.Value,
Data.ANameMap,
Data.Bool.Extra,
Data.IntMap,
Data.IOArray,
Data.NameMap,
Data.StringMap,
Data.These,
Data.StringTrie,
Idris.CommandLine,
Idris.Desugar,
Idris.Elab.Implementation,
Idris.Elab.Interface,
Idris.Error,
Idris.IDEMode.CaseSplit,
Idris.IDEMode.Commands,
Idris.IDEMode.MakeClause,
Idris.IDEMode.Parser,
Idris.IDEMode.REPL,
Idris.IDEMode.TokenLine,
Idris.ModTree,
Idris.Package,
Idris.Parser,
Idris.ProcessIdr,
Idris.REPL,
Idris.REPLCommon,
Idris.REPLOpts,
Idris.Resugar,
Idris.SetOptions,
Idris.Socket,
Idris.Socket.Data,
Idris.Socket.Raw,
Idris.Syntax,
Parser.Lexer,
Parser.Support,
Text.Lexer,
Text.Lexer.Core,
Text.Parser,
Text.Parser.Core,
Text.Quantity,
Text.Token,
TTImp.BindImplicits,
TTImp.Elab,
TTImp.Elab.Ambiguity,
TTImp.Elab.App,
TTImp.Elab.As,
TTImp.Elab.Binders,
TTImp.Elab.Case,
TTImp.Elab.Check,
TTImp.Elab.Dot,
TTImp.Elab.Hole,
TTImp.Elab.ImplicitBind,
TTImp.Elab.Lazy,
TTImp.Elab.Local,
TTImp.Elab.Prim,
TTImp.Elab.Quote,
TTImp.Elab.Record,
TTImp.Elab.Rewrite,
TTImp.Elab.Term,
TTImp.Elab.Utils,
TTImp.Impossible,
TTImp.Interactive.CaseSplit,
TTImp.Interactive.ExprSearch,
TTImp.Interactive.GenerateDef,
TTImp.Interactive.MakeLemma,
TTImp.Parser,
TTImp.ProcessData,
TTImp.ProcessDecls,
TTImp.ProcessDef,
TTImp.ProcessParams,
TTImp.ProcessRecord,
TTImp.ProcessType,
TTImp.Reflect,
TTImp.TTImp,
TTImp.Unelab,
TTImp.Utils,
TTImp.WithClause,
Utils.Binary,
Utils.Hex,
Utils.Shunting,
Yaffle.Main,
Yaffle.REPL
sourcedir = src
executable = idris2.c
opts = "--partial-eval -S"
main = Idris.Main