ilyakooo0/Idris-dev
1
0
Fork 0
mirror of https://github.com/ilyakooo0/Idris-dev.git synced 2024-11-11 14:57:30 +03:00
Code Issues Projects Releases Wiki Activity

Added GMP interface for BigInts

Browse Source
This commit is contained in:
Edwin Brady 2012-09-05 17:17:13 +01:00
parent f03a6553b0
commit 0af107c98e
9 changed files with 327 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
iif/big.iif Normal file
View File

@ -0,0 +1,7 @@
fun fact(x) = case (x ==: 0:) of {
0 => x *: fact(x - 1)
| _ => 1:
}
fun main() = let f = fact(200:) in
%WriteString(%BigStr(f) ++ "\n")

4
rts/Makefile
View File

@ -1,5 +1,5 @@
OBJS = idris_rts.o idris_gc.o
HDRS = idris_rts.h idris_gc.h
OBJS = idris_rts.o idris_gc.o idris_gmp.o
HDRS = idris_rts.h idris_gc.h idris_gmp.h
CFLAGS = -g
LIBTARGET = libidris_rts.a

3
rts/idris_gc.c
View File

@ -27,6 +27,9 @@ VAL copy(VM* vm, VAL x) {
case STRING:
cl = MKSTR(vm, x->info.str);
break;
case BIGINT:
cl = MKBIGM(vm, x->info.ptr);
break;
case PTR:
cl = MKPTR(vm, x->info.ptr);
break;

242
rts/idris_gmp.c Normal file
View File

@ -0,0 +1,242 @@
#include "idris_rts.h"
#include <gmp.h>
#include <stdlib.h>
#include <string.h>
VAL MKBIGI(int val) {
return MKINT((i_int)val);
}
VAL MKBIGC(VM* vm, char* val) {
mpz_t* bigint;
VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*));
bigint = allocate(vm, sizeof(mpz_t));
mpz_init(*bigint);
mpz_set_str(*bigint, val, 10);
cl -> ty = BIGINT;
cl -> info.ptr = (void*)bigint;
return cl;
}
VAL MKBIGM(VM* vm, void* big) {
mpz_t* bigint;
VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*));
bigint = allocate(vm, sizeof(mpz_t));
mpz_init(*bigint);
mpz_set(*bigint, *((mpz_t*)big));
cl -> ty = BIGINT;
cl -> info.ptr = (void*)bigint;
return cl;
}
VAL GETBIG(VM * vm, VAL x) {
if (ISINT(x)) {
mpz_t* bigint;
VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*));
bigint = allocate(vm, sizeof(mpz_t));
mpz_init(*bigint);
mpz_set_si(*bigint, GETINT(x));
cl -> ty = BIGINT;
cl -> info.ptr = (void*)bigint;
return cl;
} else {
return x;
}
}
VAL bigAdd(VM* vm, VAL x, VAL y) {
mpz_t* bigint;
VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*));
bigint = allocate(vm, sizeof(mpz_t));
mpz_add(*bigint, GETMPZ(x), GETMPZ(y));
cl -> ty = BIGINT;
cl -> info.ptr = (void*)bigint;
return cl;
}
VAL bigSub(VM* vm, VAL x, VAL y) {
mpz_t* bigint;
VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*));
bigint = allocate(vm, sizeof(mpz_t));
mpz_sub(*bigint, GETMPZ(x), GETMPZ(y));
cl -> ty = BIGINT;
cl -> info.ptr = (void*)bigint;
return cl;
}
VAL bigMul(VM* vm, VAL x, VAL y) {
mpz_t* bigint;
VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*));
bigint = allocate(vm, sizeof(mpz_t));
mpz_mul(*bigint, GETMPZ(x), GETMPZ(y));
cl -> ty = BIGINT;
cl -> info.ptr = (void*)bigint;
return cl;
}
VAL bigDiv(VM* vm, VAL x, VAL y) {
mpz_t* bigint;
VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*));
bigint = allocate(vm, sizeof(mpz_t));
mpz_div(*bigint, GETMPZ(x), GETMPZ(y));
cl -> ty = BIGINT;
cl -> info.ptr = (void*)bigint;
return cl;
}
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_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 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, x, 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, x, 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, x, 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, x, 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, x, 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_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);
}

26
rts/idris_gmp.h Normal file
View File

@ -0,0 +1,26 @@
#ifndef _IDRISGMP_H
#define _IDRISGMP_H
VAL MKBIGI(int val);
VAL MKBIGC(VM* vm, char* bigint);
VAL MKBIGM(VM* vm, void* bigint);
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_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_castStrBig(VM* vm, VAL i);
VAL idris_castBigStr(VM* vm, VAL i);
#define GETMPZ(x) *((mpz_t*)((x)->info.ptr))
#endif

5
rts/idris_rts.h
View File

@ -10,7 +10,7 @@
// Closures
typedef enum {
CON, INT, FLOAT, STRING, UNIT, PTR, FWD
CON, INT, BIGINT, FLOAT, STRING, UNIT, PTR, FWD
} ClosureType;
typedef struct {
@ -107,7 +107,9 @@ VAL MKCON(VM* vm, int tag, int arity, ...);
void PROJECT(VM* vm, VAL r, int loc, int arity);
void SLIDE(VM* vm, int args);
void* allocate(VM* vm, size_t size);
void* allocCon(VM* vm, int arity);
void dumpVal(VAL r);
// Casts
@ -133,5 +135,6 @@ VAL idris_readStr(VM* vm, FILE* h);
void stackOverflow();
#include "idris_gmp.h"
#endif

21
src/IRTS/CodegenC.hs
View File

@ -43,7 +43,7 @@ codegenC defs out exec incs libs dbg
gccDbg dbg ++
" " ++ tmpn ++
" `idris --link` `idris --include` " ++ libs ++
" -lidris_rts -o " ++ out
" -lidris_rts -lgmp -o " ++ out
-- putStrLn cout
exit <- system gcc
when (exit /= ExitSuccess) $
@ -86,7 +86,8 @@ bcc i (ASSIGNCONST l c)
= indent i ++ creg l ++ " = " ++ mkConst c ++ ";\n"
where
mkConst (I i) = "MKINT(" ++ show i ++ ")"
mkConst (BI i) = "MKINT(" ++ show i ++ ")" -- TODO
mkConst (BI i) | i < (2^30) = "MKINT(" ++ show i ++ ")"
| otherwise = "MKBIGC(vm,\"" ++ show i ++ "\")"
mkConst (Fl f) = "MKFLOAT(vm, " ++ show f ++ ")"
mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")"
mkConst (Str s) = "MKSTR(vm, " ++ show s ++ ")"
@ -169,6 +170,16 @@ doOp LFLe [l, r] = "FLOATBOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
doOp LFGt [l, r] = "FLOATBOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
doOp LFGe [l, r] = "FLOATBOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
doOp LBPlus [l, r] = "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
doOp LBMinus [l, r] = "idris_bigMinus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
doOp LBTimes [l, r] = "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
doOp LBDiv [l, r] = "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
doOp LBEq [l, r] = "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
doOp LBLt [l, r] = "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
doOp LBLe [l, r] = "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
doOp LBGt [l, r] = "idris_bigGt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
doOp LBGe [l, r] = "idris_bigGe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
doOp LStrConcat [l,r] = "idris_concat(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
doOp LStrLt [l,r] = "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
doOp LStrEq [l,r] = "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
@ -177,7 +188,11 @@ doOp LStrLen [x] = "idris_strlen(vm, " ++ creg x ++ ")"
doOp LIntFloat [x] = "idris_castIntFloat(" ++ creg x ++ ")"
doOp LFloatInt [x] = "idris_castFloatInt(" ++ creg x ++ ")"
doOp LIntStr [x] = "idris_castIntStr(vm, " ++ creg x ++ ")"
doOp LStrInt [x] = "idris_castFloatStr(vm, " ++ creg x ++ ")"
doOp LStrInt [x] = "idris_castStrInt(vm, " ++ creg x ++ ")"
doOp LIntBig [x] = "idris_castIntBig(vm, " ++ creg x ++ ")"
doOp LBigInt [x] = "idris_castBigInt(vm, " ++ creg x ++ ")"
doOp LStrBig [x] = "idris_castStrBig(vm, " ++ creg x ++ ")"
doOp LBigStr [x] = "idris_castBigStr(vm, " ++ creg x ++ ")"
doOp LFloatStr [x] = "idris_castFloatStr(vm, " ++ creg x ++ ")"
doOp LStrFloat [x] = "idris_castStrFloat(vm, " ++ creg x ++ ")"

27
src/IRTS/LParser.hs
View File

@ -54,7 +54,7 @@ fovm f = do defs <- parseFOVM f
let checked = checkDefs defuns (toAlist defuns)
-- print checked
case checked of
OK c -> codegenC c "a.out" True ["math.h"] "" TRACE
OK c -> codegenC c "a.out" True ["math.h"] "" NONE
Error e -> fail $ show e
parseFOVM :: FilePath -> IO [(Name, LDecl)]
@ -88,14 +88,18 @@ pLExp = buildExpressionParser optable pLExp'
optable = [[binary "*" (\x y -> LOp LTimes [x,y]) AssocLeft,
binary "/" (\x y -> LOp LDiv [x,y]) AssocLeft,
binary "*." (\x y -> LOp LFTimes [x,y]) AssocLeft,
binary "/." (\x y -> LOp LFTimes [x,y]) AssocLeft
binary "/." (\x y -> LOp LFDiv [x,y]) AssocLeft,
binary "*:" (\x y -> LOp LBTimes [x,y]) AssocLeft,
binary "/:" (\x y -> LOp LBDiv [x,y]) AssocLeft
],
[
binary "+" (\x y -> LOp LPlus [x,y]) AssocLeft,
binary "-" (\x y -> LOp LMinus [x,y]) AssocLeft,
binary "++" (\x y -> LOp LStrConcat [x,y]) AssocLeft,
binary "+." (\x y -> LOp LFPlus [x,y]) AssocLeft,
binary "-." (\x y -> LOp LFMinus [x,y]) AssocLeft
binary "-." (\x y -> LOp LFMinus [x,y]) AssocLeft,
binary "+:" (\x y -> LOp LBPlus [x,y]) AssocLeft,
binary "-:" (\x y -> LOp LBMinus [x,y]) AssocLeft
],
[
binary "==" (\x y -> LOp LEq [x, y]) AssocNone,
@ -107,7 +111,13 @@ optable = [[binary "*" (\x y -> LOp LTimes [x,y]) AssocLeft,
binary "<=" (\x y -> LOp LLe [x, y]) AssocNone,
binary "<=." (\x y -> LOp LFLe [x, y]) AssocNone,
binary ">=" (\x y -> LOp LGe [x, y]) AssocNone,
binary ">=." (\x y -> LOp LFGe [x, y]) AssocNone
binary ">=." (\x y -> LOp LFGe [x, y]) AssocNone,
binary "==:" (\x y -> LOp LBEq [x, y]) AssocNone,
binary "<:" (\x y -> LOp LBLt [x, y]) AssocNone,
binary ">:" (\x y -> LOp LBGt [x, y]) AssocNone,
binary "<=:" (\x y -> LOp LBLe [x, y]) AssocNone,
binary ">=:" (\x y -> LOp LBGe [x, y]) AssocNone
]]
binary name f assoc = Infix (do reservedOp name; return f) assoc
@ -174,6 +184,14 @@ pCast = do reserved "FloatString"; lchar '('; e <- pLExp; lchar ')'
return (LOp LStrInt [e])
<|> do reserved "IntString"; lchar '('; e <- pLExp; lchar ')'
return (LOp LIntStr [e])
<|> do reserved "BigInt"; lchar '('; e <- pLExp; lchar ')'
return (LOp LBigInt [e])
<|> do reserved "IntBig"; lchar '('; e <- pLExp; lchar ')'
return (LOp LIntBig [e])
<|> do reserved "BigString"; lchar '('; e <- pLExp; lchar ')'
return (LOp LBigStr [e])
<|> do reserved "StringBig"; lchar '('; e <- pLExp; lchar ')'
return (LOp LStrBig [e])
pPrim :: LParser LExp
pPrim = do reserved "StrEq"; lchar '(';
@ -219,6 +237,7 @@ pAlt = try (do x <- iName []
pLConst :: LParser LExp
pLConst = try (do f <- float; return $ LConst (Fl f))
<|> try (do i <- natural; lchar ':'; return $ LConst (BI i))
<|> try (do i <- natural; return $ LConst (I (fromInteger i)))
<|> try (do s <- strlit; return $ LConst (Str s))
<|> try (do c <- chlit; return $ LConst (Ch c))

2
src/IRTS/Lang.hs
View File

@ -21,8 +21,10 @@ data LExp = LV LVar
data PrimFn = LPlus | LMinus | LTimes | LDiv | LEq | LLt | LLe | LGt | LGe
| LFPlus | LFMinus | LFTimes | LFDiv | LFEq | LFLt | LFLe | LFGt | LFGe
| LBPlus | LBMinus | LBTimes | LBDiv | LBEq | LBLt | LBLe | LBGt | LBGe
| LStrConcat | LStrLt | LStrEq | LStrLen
| LIntFloat | LFloatInt | LIntStr | LStrInt | LFloatStr | LStrFloat
| LIntBig | LBigInt | LStrBig | LBigStr
| LPrintNum | LPrintStr | LReadStr
deriving Show