baf59ac · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

StrCons and conversions to Integer

commitbaf59acf4dff7b65141fa6b336d8a0f0996c4bcf authorBenjamin Saunders <besaunde@sfu.ca> dateWed 26 Jun 2013, 12:13 (13 years ago) parent3e50b1b

2 files changed+44

compare with master

unifiedsplit

llvm/defs.c+18 src/IRTS/CodegenLLVM.hs+26

llvm/defs.c+18

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

11#include <stdio.h>

22#include <gmp.h>

3+#include <gc.h>

4+#include <string.h>

46void putStr(const char *str) {

57 fputs(str, stdout);

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

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

2022}

2123

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+

2231unsigned long long mpz_get_ull(mpz_t n)

2332{

2433 unsigned int lo, hi;

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

3544

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

3746}

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 =

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

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

142142 , 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

143146 , GlobalDefinition mainDef

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

145148 where

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

732735 IT64 -> return val

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

734737 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

735754

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

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

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

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

792811

793812cgOp 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+

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

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

796822