baf59ac · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

StrCons and conversions to Integer

baf59acBenjamin Saunders13 years ago

llvm/defs.c+18

compare with master

unifiedsplit

@@ -1,5 +1,7 @@

1#include <stdio.h>

2#include <gmp.h>

3+#include <gc.h>

4+#include <string.h>

4void putStr(const char *str) {

6void putStr(const char *str) {

5 fputs(str, stdout);

7 fputs(str, stdout);

@@ -19,6 +21,13 @@ void mpz_init_set_sll(mpz_t n, long long sll)

19 mpz_add_ui(n, n, (unsigned int)sll); /* n += (unsigned int)sll */

21 mpz_add_ui(n, n, (unsigned int)sll); /* n += (unsigned int)sll */

20}

22}

24+void mpz_set_sll(mpz_t n, long long sll)

25+{

26+ mpz_set_si(n, (int)(sll >> 32)); /* n = (int)sll >> 32 */

27+ mpz_mul_2exp(n, n, 32 ); /* n <<= 32 */

28+ mpz_add_ui(n, n, (unsigned int)sll); /* n += (unsigned int)sll */

29+}

30+

22unsigned long long mpz_get_ull(mpz_t n)

31unsigned long long mpz_get_ull(mpz_t n)

23{

32{

24 unsigned int lo, hi;

33 unsigned int lo, hi;

@@ -35,3 +44,12 @@ unsigned long long mpz_get_ull(mpz_t n)

36 return (((unsigned long long)hi) << 32) + lo;

45 return (((unsigned long long)hi) << 32) + lo;

37}

46}

47+

48+char *__idris_strCons(char c, char *s) {

49+ size_t len = strlen(s);

50+ char *result = GC_malloc_atomic(len);

51+ result[0] = c;

52+ memcpy(result+1, s, len);

53+ result[len+1] = 0;

54+ return result;

55+}

src/IRTS/CodegenLLVM.hs+26

@@ -140,6 +140,9 @@ initDefs tgt =

140 , exfun "__gmpz_get_str" ptrI8 [ptrI8, IntegerType 32, pmpz] False

141 , exfun "__gmpz_cmp" (IntegerType 32) [pmpz, pmpz] False

142 , exfun "mpz_get_ull" (IntegerType 64) [pmpz] False

143+ , exfun "mpz_init_set_ull" VoidType [pmpz, IntegerType 64] False

144+ , exfun "mpz_init_set_sll" VoidType [pmpz, IntegerType 64] False

145+ , exfun "__idris_strCons" (IntegerType 8) [IntegerType 8, PointerType (IntegerType 8) (AddrSpace 0)] False

143 , GlobalDefinition mainDef

146 , GlobalDefinition mainDef

144 ] ++ map mpzBinFun ["add", "sub", "mul", "fdiv_q", "fdiv_r", "and", "ior", "xor"]

147 ] ++ map mpzBinFun ["add", "sub", "mul", "fdiv_q", "fdiv_r", "and", "ior", "xor"]

145 where

148 where

@@ -732,6 +735,22 @@ cgOp (LTrunc ITBig ity) [x] = do

732 IT64 -> return val

735 IT64 -> return val

733 _ -> inst $ Trunc val (IntegerType $ itWidth ity) []

736 _ -> inst $ Trunc val (IntegerType $ itWidth ity) []

734 box (FInt ity) v

737 box (FInt ity) v

738+cgOp (LZExt from ITBig) [x] = do

739+ nx <- unbox (FInt from) x

740+ nx' <- case from of

741+ IT64 -> return nx

742+ _ -> inst $ Trunc nx (IntegerType $ itWidth from) []

743+ mpz <- alloc mpzTy

744+ inst' $ simpleCall "mpz_init_set_ull" [mpz, nx']

745+ box (FInt ITBig) mpz

746+cgOp (LSExt from ITBig) [x] = do

747+ nx <- unbox (FInt from) x

748+ nx' <- case from of

749+ IT64 -> return nx

750+ _ -> inst $ Trunc nx (IntegerType $ itWidth from) []

751+ mpz <- alloc mpzTy

752+ inst' $ simpleCall "mpz_init_set_sll" [mpz, nx']

753+ box (FInt ITBig) mpz

735

754

736cgOp (LLt ITBig) [x,y] = mpzCmp IPred.SLT x y

755cgOp (LLt ITBig) [x,y] = mpzCmp IPred.SLT x y

737cgOp (LLe ITBig) [x,y] = mpzCmp IPred.SLE x y

756cgOp (LLe ITBig) [x,y] = mpzCmp IPred.SLE x y

@@ -791,6 +810,13 @@ cgOp (LIntStr ity) [x] = do

791 box FString =<< inst (idrCall "__idris_intStr" [x''])

810 box FString =<< inst (idrCall "__idris_intStr" [x''])

792

811

793cgOp LStrConcat [x,y] = cgStrCat x y

812cgOp LStrConcat [x,y] = cgStrCat x y

813+

814+cgOp LStrCons [c,s] = do

815+ nc <- unbox FChar c

816+ ns <- unbox FString s

817+ r <- inst $ simpleCall "__idris_strCons" [nc, ns]

818+ box FString r

819+

794cgOp prim args = ierror $ "Unimplemented primitive: [" ++ show prim ++ "]("

820cgOp prim args = ierror $ "Unimplemented primitive: [" ++ show prim ++ "]("

795 ++ intersperse ',' (take (length args) ['a'..]) ++ ")"

821 ++ intersperse ',' (take (length args) ['a'..]) ++ ")"

796

822