git.iko.soy/Idris-dev
on master help sign in
Implement more primitives and foreign lib functions
fc17a3fBenjamin Saunders
llvm/defs.c+82
compare with master
unifiedsplit
@@ -2,6 +2,7 @@
2#include <gmp.h>
2#include <gmp.h>
3#include <gc.h>
3#include <gc.h>
4#include <string.h>
4#include <string.h>
5+#include <inttypes.h>
5
6
6void putStr(const char *str) {
7void putStr(const char *str) {
7 fputs(str, stdout);
8 fputs(str, stdout);
@@ -53,3 +54,84 @@ char *__idris_strCons(char c, char *s) {
53 result[len+1] = 0;
54 result[len+1] = 0;
54 return result;
55 return result;
55}
56}
57+
58+#define BUFSIZE 256
59+char *__idris_readStr(FILE* h) {
60+// Modified from 'safe-fgets.c' in the gdb distribution.
61+// (see http://www.gnu.org/software/gdb/current/)
62+ char *line_ptr;
63+ char* line_buf = (char *) GC_malloc (BUFSIZE);
64+ int line_buf_size = BUFSIZE;
65+
66+ /* points to last byte */
67+ line_ptr = line_buf + line_buf_size - 1;
68+
69+ /* so we can see if fgets put a 0 there */
70+ *line_ptr = 1;
71+ if (fgets (line_buf, line_buf_size, h) == 0)
72+ return "";
73+
74+ /* we filled the buffer? */
75+ while (line_ptr[0] == 0 && line_ptr[-1] != '\n')
76+ {
77+ /* Make the buffer bigger and read more of the line */
78+ line_buf_size += BUFSIZE;
79+ line_buf = (char *) GC_realloc (line_buf, line_buf_size);
80+
81+ /* points to last byte again */
82+ line_ptr = line_buf + line_buf_size - 1;
83+ /* so we can see if fgets put a 0 there */
84+ *line_ptr = 1;
85+
86+ if (fgets (line_buf + line_buf_size - BUFSIZE - 1, BUFSIZE + 1, h) == 0)
87+ return "";
88+ }
89+
90+ return line_buf;
91+}
92+
93+void* fileOpen(char* name, char* mode) {
94+ FILE* f = fopen(name, mode);
95+ return (void*)f;
96+}
97+
98+void fileClose(void* h) {
99+ FILE* f = (FILE*)h;
100+ fclose(f);
101+}
102+
103+int fileEOF(void* h) {
104+ FILE* f = (FILE*)h;
105+ return feof(f);
106+}
107+
108+int fileError(void* h) {
109+ FILE* f = (FILE*)h;
110+ return ferror(f);
111+}
112+
113+void fputStr(void* h, char* str) {
114+ FILE* f = (FILE*)h;
115+ fputs(str, f);
116+}
117+
118+int isNull(void* ptr) {
119+ return ptr==NULL;
120+}
121+
122+void idris_memset(void* ptr, size_t offset, uint8_t c, size_t size) {
123+ memset(((uint8_t*)ptr) + offset, c, size);
124+}
125+
126+uint8_t idris_peek(void* ptr, size_t offset) {
127+ return *(((uint8_t*)ptr) + offset);
128+}
129+
130+void idris_poke(void* ptr, size_t offset, uint8_t data) {
131+ *(((uint8_t*)ptr) + offset) = data;
132+}
133+
134+void idris_memmove(void* dest, void* src, size_t dest_offset, size_t src_offset, size_t size) {
135+ memmove(dest + dest_offset, src + src_offset, size);
136+}
137+
src/IRTS/CodegenLLVM.hs+22
@@ -143,6 +143,10 @@ initDefs tgt =
143 , exfun "mpz_init_set_ull" VoidType [pmpz, IntegerType 64] False
143 , exfun "mpz_init_set_ull" VoidType [pmpz, IntegerType 64] False
144 , exfun "mpz_init_set_sll" VoidType [pmpz, IntegerType 64] False
144 , exfun "mpz_init_set_sll" VoidType [pmpz, IntegerType 64] False
145 , exfun "__idris_strCons" ptrI8 [IntegerType 8, ptrI8] False
145 , exfun "__idris_strCons" ptrI8 [IntegerType 8, ptrI8] False
146+ , exfun "__idris_readStr" ptrI8 [ptrI8] False -- Actually pointer to FILE, but it's opaque anyway
147+ , exVar "stdin" ptrI8
148+ , exVar "stdout" ptrI8
149+ , exVar "stderr" ptrI8
146 , GlobalDefinition mainDef
150 , GlobalDefinition mainDef
147 ] ++ map mpzBinFun ["add", "sub", "mul", "fdiv_q", "fdiv_r", "and", "ior", "xor"]
151 ] ++ map mpzBinFun ["add", "sub", "mul", "fdiv_q", "fdiv_r", "and", "ior", "xor"]
148 where
152 where
@@ -169,6 +173,8 @@ initDefs tgt =
169 , G.name = Name name
173 , G.name = Name name
170 , G.parameters = (flip map argtys $ \ty -> Parameter ty (UnName 0) [], vari)
174 , G.parameters = (flip map argtys $ \ty -> Parameter ty (UnName 0) [], vari)
171 }
175 }
176+ exVar :: String -> Type -> Definition
177+ exVar name ty = GlobalDefinition $ globalVariableDefaults { G.name = Name name, G.type' = ty }
172
178
173codegen :: String -> [SDecl] -> Module
179codegen :: String -> [SDecl] -> Module
174codegen tgt defs = Module "idris" Nothing Nothing (initDefs tgt ++ globals ++ gendefs)
180codegen tgt defs = Module "idris" Nothing Nothing (initDefs tgt ++ globals ++ gendefs)
@@ -829,6 +835,22 @@ cgOp LStrTail [c] = do
829 c <- inst $ GetElementPtr True s [ConstantOperand $ C.Int 32 1] []
835 c <- inst $ GetElementPtr True s [ConstantOperand $ C.Int 32 1] []
830 box FString c
836 box FString c
831
837
838+cgOp LReadStr [p] = do
839+ np <- unbox FPtr p
840+ s <- inst $ simpleCall "__idris_readStr" [np]
841+ box FString s
842+
843+cgOp LStdIn [] = do
844+ ptr <- inst $ Load False (ConstantOperand . C.GlobalReference . Name $ "stdin") Nothing 0 []
845+ box FPtr ptr
846+cgOp LStdOut [] = do
847+ ptr <- inst $ Load False (ConstantOperand . C.GlobalReference . Name $ "stdout") Nothing 0 []
848+ box FPtr ptr
849+cgOp LStdErr [] = do
850+ ptr <- inst $ Load False (ConstantOperand . C.GlobalReference . Name $ "stderr") Nothing 0 []
851+ box FPtr ptr
852+
853+
832cgOp prim args = ierror $ "Unimplemented primitive: [" ++ show prim ++ "]("
854cgOp prim args = ierror $ "Unimplemented primitive: [" ++ show prim ++ "]("
833 ++ intersperse ',' (take (length args) ['a'..]) ++ ")"
855 ++ intersperse ',' (take (length args) ['a'..]) ++ ")"
834
856