git.iko.soy/Idris-dev
on master help sign in
Merge branch 'llvm3' of https://github.com/Ralith/Idris-dev into Ralith-llvm3

Conflicts: .travis.yml

commit0cbc3840151c05afd42f1c90a9a1c62f16d2012a authorEdwin Brady <ecb10@st-andrews.ac.uk> dateThu 4 Jul 2013, 21:48 (13 years ago) parent185b31fc179636
8 files changed+1227−3
compare with master
unifiedsplit
Setup.hs+9 idris.cabal+3−2 llvm/Makefile+24 llvm/defs.c+148 src/IRTS/CodegenLLVM.hs+1038 src/IRTS/Compiler.hs+3−1 src/Idris/AbsSyntaxTree.hs+1 src/Idris/REPL.hs+1
Setup.hs+9
@@ -53,6 +53,8 @@ cleanJavaLib verbosity
5353 execPomExists <- doesFileExist ("java" </> "executable_pom.xml")
5454 when pomExists $ removeFile ("java" </> "executable_pom.xml")
5555
56+cleanLLVMLib verbosity = make verbosity ["-C", "llvm", "clean"]
57+
5658installStdLib pkg local withoutEffects verbosity copy
5759 = do let dirs = L.absoluteInstallDirs pkg local copy
5860 let idir = datadir dirs
@@ -82,6 +84,10 @@ installStdLib pkg local withoutEffects verbosity copy
8284 , "IDRIS=" ++ icmd
8385 ]
8486
87+installLLVMLib verbosity pkg local copy =
88+ let idir = datadir $ L.absoluteInstallDirs pkg local copy in
89+ make verbosity ["-C", "llvm", "install", "TARGET=" ++ idir </> "llvm"]
90+
8591installJavaLib pkg local verbosity copy version = do
8692 let rtsFile = "idris-" ++ display version ++ ".jar"
8793 putStrLn $ "Installing java libraries"
@@ -161,11 +167,13 @@ main = do
161167 let withoutEffects = noEffectsFlag $ configFlags lbi
162168 installStdLib pkg lbi withoutEffects verb
163169 (S.fromFlag $ S.copyDest flags)
170+ installLLVMLib verb pkg lbi (S.fromFlag $ S.copyDest flags)
164171 , postInst = \ _ flags pkg lbi -> do
165172 let verb = (S.fromFlag $ S.installVerbosity flags)
166173 let withoutEffects = noEffectsFlag $ configFlags lbi
167174 installStdLib pkg lbi withoutEffects verb
168175 NoCopyDest
176+ installLLVMLib verb pkg lbi NoCopyDest
169177 when (javaFlag $ configFlags lbi)
170178 (installJavaLib pkg
171179 lbi
@@ -180,6 +188,7 @@ main = do
180188 , postClean = \ _ flags _ _ -> do
181189 let verb = S.fromFlag $ S.cleanVerbosity flags
182190 cleanStdLib verb
191+ cleanLLVMLib verb
183192 cleanJavaLib verb
184193 , postBuild = \ _ flags _ lbi -> do
185194 let verb = S.fromFlag $ S.buildVerbosity flags
idris.cabal+3−2
@@ -70,6 +70,7 @@ Extra-source-files: lib/Makefile lib/*.idr lib/Prelude/*.idr
7070 javascript/javascript.ipkg
7171 config.mk
7272 rts/*.c rts/*.h rts/Makefile
73+ llvm/*.c llvm/Makefile
7374 js/*.js
7475 java/src/main/java/org/idris/rts/*.java
7576 java/*.xml
@@ -262,7 +263,7 @@ Executable idris
262263 IRTS.Lang, IRTS.LParser, IRTS.Bytecode, IRTS.Simplified,
263264 IRTS.CodegenC, IRTS.Defunctionalise, IRTS.Inliner,
264265 IRTS.Compiler, IRTS.CodegenJava, IRTS.BCImp,
265− IRTS.CodegenJavaScript,
266+ IRTS.CodegenJavaScript, IRTS.CodegenLLVM,
266267 IRTS.CodegenCommon, IRTS.DumpBC
267268
268269 Paths_idris
@@ -271,7 +272,7 @@ Executable idris
271272 haskeline>=0.7, split, directory,
272273 containers, process, transformers, filepath,
273274 directory, binary, bytestring, text, pretty,
274− language-java>=0.2.2, libffi
275+ language-java>=0.2.2, libffi, llvm-general>=3.3.0.6 && <3.4
275276
276277 Extensions: MultiParamTypeClasses, FunctionalDependencies,
277278 FlexibleInstances, TemplateHaskell
llvm/Makefilenew file+24
@@ -0,0 +1,24 @@
1+include ../config.mk
2+
3+CFLAGS=-c -O2 -Wall -Wextra -fPIC -Wno-unused-parameter
4+SOURCES=defs.c
5+OBJECTS=$(SOURCES:.c=.o)
6+LIB=libidris_rts.a
7+
8+all: $(SOURCES) $(LIB)
9+
10+$(LIB): $(OBJECTS)
11+ ar r $@ $(OBJECTS)
12+ ranlib $@
13+
14+.c.o:
15+ $(CC) $(CFLAGS) $< -o $@
16+
17+install: $(LIB) .PHONY
18+ mkdir -p $(TARGET)
19+ install $(LIB) $(TARGET)
20+
21+clean: .PHONY
22+ rm -f $(OBJECTS) $(LIB)
23+
24+.PHONY:
llvm/defs.cnew file+148
@@ -0,0 +1,148 @@
1+#include <stdio.h>
2+#include <gmp.h>
3+#include <gc.h>
4+#include <string.h>
5+#include <inttypes.h>
6+
7+void putStr(const char *str) {
8+ fputs(str, stdout);
9+}
10+
11+void mpz_init_set_ull(mpz_t n, unsigned long long ull)
12+{
13+ mpz_init_set_ui(n, (unsigned int)(ull >> 32)); /* n = (unsigned int)(ull >> 32) */
14+ mpz_mul_2exp(n, n, 32); /* n <<= 32 */
15+ mpz_add_ui(n, n, (unsigned int)ull); /* n += (unsigned int)ull */
16+}
17+
18+void mpz_init_set_sll(mpz_t n, long long sll)
19+{
20+ mpz_init_set_si(n, (int)(sll >> 32)); /* n = (int)sll >> 32 */
21+ mpz_mul_2exp(n, n, 32 ); /* n <<= 32 */
22+ mpz_add_ui(n, n, (unsigned int)sll); /* n += (unsigned int)sll */
23+}
24+
25+void mpz_set_sll(mpz_t n, long long sll)
26+{
27+ mpz_set_si(n, (int)(sll >> 32)); /* n = (int)sll >> 32 */
28+ mpz_mul_2exp(n, n, 32 ); /* n <<= 32 */
29+ mpz_add_ui(n, n, (unsigned int)sll); /* n += (unsigned int)sll */
30+}
31+
32+unsigned long long mpz_get_ull(mpz_t n)
33+{
34+ unsigned int lo, hi;
35+ mpz_t tmp;
36+
37+ mpz_init( tmp );
38+ mpz_mod_2exp( tmp, n, 64 ); /* tmp = (lower 64 bits of n) */
39+
40+ lo = mpz_get_ui( tmp ); /* lo = tmp & 0xffffffff */
41+ mpz_div_2exp( tmp, tmp, 32 ); /* tmp >>= 32 */
42+ hi = mpz_get_ui( tmp ); /* hi = tmp & 0xffffffff */
43+
44+ mpz_clear( tmp );
45+
46+ return (((unsigned long long)hi) << 32) + lo;
47+}
48+
49+char *__idris_strCons(char c, char *s) {
50+ size_t len = strlen(s);
51+ char *result = GC_malloc_atomic(len+2);
52+ result[0] = c;
53+ memcpy(result+1, s, len);
54+ result[len+1] = 0;
55+ return result;
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+
138+void *__idris_gmpMalloc(size_t size) {
139+ return GC_malloc(size);
140+}
141+
142+void *__idris_gmpRealloc(void *ptr, size_t oldSize, size_t size) {
143+ return GC_realloc(ptr, size);
144+}
145+
146+void __idris_gmpFree(void *ptr, size_t oldSize) {
147+ GC_free(ptr);
148+}
src/IRTS/CodegenLLVM.hsnew file+1038
@@ -0,0 +1,1038 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+module IRTS.CodegenLLVM (codegenLLVM) where
3+
4+import IRTS.CodegenCommon
5+import IRTS.Lang
6+import IRTS.Simplified
7+import qualified Core.TT as TT
8+
9+import Util.System
10+import Paths_idris
11+
12+import LLVM.General.Context
13+import LLVM.General.Diagnostic
14+import LLVM.General.AST
15+import LLVM.General.AST.AddrSpace
16+import qualified LLVM.General.Module as M
17+import qualified LLVM.General.AST.IntegerPredicate as IPred
18+import qualified LLVM.General.AST.Linkage as L
19+import qualified LLVM.General.AST.Visibility as V
20+import qualified LLVM.General.AST.CallingConvention as CC
21+import qualified LLVM.General.AST.Attribute as A
22+import qualified LLVM.General.AST.Global as G
23+import qualified LLVM.General.AST.Constant as C
24+import qualified LLVM.General.AST.Float as F
25+
26+import Data.List
27+import Data.Maybe
28+import Data.Word
29+import Data.Set (Set)
30+import qualified Data.Set as S
31+import Control.Applicative
32+import Control.Monad.RWS
33+import Control.Monad.Writer
34+import Control.Monad.State
35+
36+import qualified System.Info as SI (arch, os)
37+import System.IO
38+import System.Directory (removeFile)
39+import System.FilePath ((</>))
40+import System.Process (rawSystem)
41+import System.Exit (ExitCode(..))
42+import Debug.Trace
43+
44+data Target = Target { arch :: String, os :: String }
45+
46+codegenLLVM :: [(TT.Name, SDecl)] ->
47+ FilePath -> -- output file name
48+ OutputType ->
49+ IO ()
50+codegenLLVM defs file outty = withContext $ \context -> do
51+ let target = Target { arch = SI.arch, os = SI.os }
52+ let ast = codegen target (map snd defs)
53+ result <- M.withModuleFromAST context ast (outputModule file outty)
54+ case result of
55+ Right _ -> return ()
56+ Left msg -> ierror msg
57+
58+itWidth :: IntTy -> Word32
59+itWidth ITNative = 32
60+itWidth x = fromIntegral $ intTyWidth x
61+
62+outputModule :: FilePath -> OutputType -> M.Module -> IO ()
63+outputModule file Raw m = M.writeBitcodeToFile file m
64+outputModule file Object m = withTmpFile $ \bc -> do
65+ outputModule bc Raw m
66+ exit <- rawSystem "llc" ["-filetype=obj", "--disable-fp-elim", "-o", file, bc]
67+ when (exit /= ExitSuccess) $ ierror "FAILURE: Object generation"
68+outputModule file Executable m = withTmpFile $ \obj -> do
69+ outputModule obj Object m
70+ cc <- getCC
71+ defs <- (</> "llvm" </> "libidris_rts.a") <$> getDataDir
72+ exit <- rawSystem cc [obj, defs, "-lm", "-lgmp", "-lgc", "-o", file]
73+ when (exit /= ExitSuccess) $ ierror "FAILURE: Linking"
74+
75+withTmpFile :: (FilePath -> IO a) -> IO a
76+withTmpFile f = do
77+ (path, handle) <- tempfile
78+ hClose handle
79+ result <- f path
80+ removeFile path
81+ return result
82+
83+ierror :: String -> a
84+ierror msg = error $ "INTERNAL ERROR: IRTS.CodegenLLVM: " ++ msg
85+
86+mainDef :: Global
87+mainDef =
88+ functionDefaults
89+ { G.returnType = IntegerType 32
90+ , G.parameters =
91+ ([ Parameter (IntegerType 32) (Name "argc") []
92+ , Parameter (PointerType (PointerType (IntegerType 8) (AddrSpace 0)) (AddrSpace 0)) (Name "argv") []
93+ ], False)
94+ , G.name = Name "main"
95+ , G.basicBlocks =
96+ [ BasicBlock (UnName 0)
97+ [ Do $ simpleCall "GC_init" [] -- Initialize Boehm GC
98+ , Do $ simpleCall "__gmp_set_memory_functions"
99+ [ ConstantOperand . C.GlobalReference . Name $ "__idris_gmpMalloc"
100+ , ConstantOperand . C.GlobalReference . Name $ "__idris_gmpRealloc"
101+ , ConstantOperand . C.GlobalReference . Name $ "__idris_gmpFree"
102+ ]
103+ , UnName 1 := idrCall "{runMain0}" [] ]
104+ (Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [])
105+ ]}
106+
107+initDefs :: Target -> [Definition]
108+initDefs tgt =
109+ [ TypeDefinition (Name "valTy")
110+ (Just $ StructureType False
111+ [ IntegerType 32
112+ , ArrayType 0 (PointerType valueType (AddrSpace 0))
113+ ])
114+ , TypeDefinition (Name "mpz")
115+ (Just $ StructureType False
116+ [ IntegerType 32
117+ , IntegerType 32
118+ , PointerType intPtr (AddrSpace 0)
119+ ])
120+ , GlobalDefinition $ globalVariableDefaults
121+ { G.name = Name "__idris_intFmtStr"
122+ , G.linkage = L.Internal
123+ , G.isConstant = True
124+ , G.hasUnnamedAddr = True
125+ , G.type' = ArrayType 5 (IntegerType 8)
126+ , G.initializer = Just $ C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) "%lld" ++ [C.Int 8 0])
127+ }
128+ , rtsFun "intStr" ptrI8 [IntegerType 64]
129+ [ BasicBlock (UnName 0)
130+ [ UnName 1 := simpleCall "GC_malloc_atomic" [ConstantOperand (C.Int (fromInteger $ tgtWordSize tgt) 21)]
131+ , UnName 2 := simpleCall "snprintf"
132+ [ LocalReference (UnName 1)
133+ , ConstantOperand (C.Int (fromInteger $ tgtWordSize tgt) 21)
134+ , ConstantOperand $ C.GetElementPtr True (C.GlobalReference . Name $ "__idris_intFmtStr") [C.Int 32 0, C.Int 32 0]
135+ , LocalReference (UnName 0)
136+ ]
137+ ]
138+ (Do $ Ret (Just (LocalReference (UnName 1))) [])
139+ ]
140+ , exfun "llvm.trap" VoidType [] False
141+ , exfun "snprintf" (IntegerType 32) [ptrI8, intPtr, ptrI8] True
142+ , exfun "strcmp" (IntegerType 32) [ptrI8, ptrI8] False
143+ , exfun "strlen" intPtr [ptrI8] False
144+ , exfun "memcpy" ptrI8 [ptrI8, ptrI8, intPtr] False
145+ , exfun "GC_init" VoidType [] False
146+ , exfun "GC_malloc" ptrI8 [intPtr] False
147+ , exfun "GC_malloc_atomic" ptrI8 [intPtr] False
148+ , exfun "__gmp_set_memory_functions" VoidType
149+ [ PointerType (FunctionType ptrI8 [intPtr] False) (AddrSpace 0)
150+ , PointerType (FunctionType ptrI8 [ptrI8, intPtr, intPtr] False) (AddrSpace 0)
151+ , PointerType (FunctionType VoidType [ptrI8, intPtr] False) (AddrSpace 0)
152+ ] False
153+ , exfun "__gmpz_init" VoidType [pmpz] False
154+ , exfun "__gmpz_init_set_str" (IntegerType 32) [pmpz, ptrI8, IntegerType 32] False
155+ , exfun "__gmpz_get_str" ptrI8 [ptrI8, IntegerType 32, pmpz] False
156+ , exfun "__gmpz_cmp" (IntegerType 32) [pmpz, pmpz] False
157+ , exfun "mpz_get_ull" (IntegerType 64) [pmpz] False
158+ , exfun "mpz_init_set_ull" VoidType [pmpz, IntegerType 64] False
159+ , exfun "mpz_init_set_sll" VoidType [pmpz, IntegerType 64] False
160+ , exfun "__idris_strCons" ptrI8 [IntegerType 8, ptrI8] False
161+ , exfun "__idris_readStr" ptrI8 [ptrI8] False -- Actually pointer to FILE, but it's opaque anyway
162+ , exfun "__idris_gmpMalloc" ptrI8 [intPtr] False
163+ , exfun "__idris_gmpRealloc" ptrI8 [ptrI8, intPtr, intPtr] False
164+ , exfun "__idris_gmpFree" VoidType [ptrI8, intPtr] False
165+ , exfun "strtoll" (IntegerType 64) [ptrI8, PointerType ptrI8 (AddrSpace 0), IntegerType 32] False
166+ , exVar (stdinName tgt) ptrI8
167+ , exVar (stdoutName tgt) ptrI8
168+ , exVar (stderrName tgt) ptrI8
169+ , GlobalDefinition mainDef
170+ ] ++ map mpzBinFun ["add", "sub", "mul", "fdiv_q", "fdiv_r", "and", "ior", "xor"]
171+ where
172+ intPtr = IntegerType (fromInteger $ tgtWordSize tgt)
173+ ptrI8 = PointerType (IntegerType 8) (AddrSpace 0)
174+ pmpz = PointerType mpzTy (AddrSpace 0)
175+
176+ mpzBinFun n = exfun ("__gmpz_" ++ n) VoidType [pmpz, pmpz, pmpz] False
177+
178+ rtsFun :: String -> Type -> [Type] -> [BasicBlock] -> Definition
179+ rtsFun name rty argtys def =
180+ GlobalDefinition $ functionDefaults
181+ { G.linkage = L.Internal
182+ , G.returnType = rty
183+ , G.parameters = (flip map argtys $ \ty -> Parameter ty (UnName 0) [], False)
184+ , G.name = Name $ "__idris_" ++ name
185+ , G.basicBlocks = def
186+ }
187+
188+ exfun :: String -> Type -> [Type] -> Bool -> Definition
189+ exfun name rty argtys vari =
190+ GlobalDefinition $ functionDefaults
191+ { G.returnType = rty
192+ , G.name = Name name
193+ , G.parameters = (flip map argtys $ \ty -> Parameter ty (UnName 0) [], vari)
194+ }
195+ exVar :: String -> Type -> Definition
196+ exVar name ty = GlobalDefinition $ globalVariableDefaults { G.name = Name name, G.type' = ty }
197+
198+ stdinName :: Target -> String
199+ stdinName (Target { os = "darwin" }) = "__stdinp"
200+ stdinName _ = "stdin"
201+ stdoutName :: Target -> String
202+ stdoutName (Target { os = "darwin" }) = "__stdoutp"
203+ stdoutName _ = "stdout"
204+ stderrName :: Target -> String
205+ stderrName (Target { os = "darwin" }) = "__stderrp"
206+ stderrName _ = "stderr"
207+
208+codegen :: Target -> [SDecl] -> Module
209+codegen tgt defs = Module "idris" Nothing Nothing (initDefs tgt ++ globals ++ gendefs)
210+ where
211+ (gendefs, _, globals) = runRWS (mapM cgDef defs) tgt 0
212+
213+valueType :: Type
214+valueType = NamedTypeReference (Name "valTy")
215+
216+nullValue :: C.Constant
217+nullValue = C.Null (PointerType valueType (AddrSpace 0))
218+
219+primTy :: Type -> Type
220+primTy inner = StructureType False [IntegerType 32, inner]
221+
222+mpzTy :: Type
223+mpzTy = NamedTypeReference (Name "mpz")
224+
225+conType :: Word64 -> Type
226+conType nargs = StructureType False
227+ [ IntegerType 32
228+ , ArrayType nargs (PointerType valueType (AddrSpace 0))
229+ ]
230+
231+type Modgen = RWS Target [Definition] Word
232+
233+cgDef :: SDecl -> Modgen Definition
234+cgDef (SFun name argNames _ expr) = do
235+ nextGlobal <- get
236+ tgt <- ask
237+ let (_, CGS { nextGlobalName = nextGlobal' }, (allocas, bbs, globals)) =
238+ runRWS (do r <- cgExpr expr
239+ case r of
240+ Nothing -> terminate $ Unreachable []
241+ Just r' -> terminate $ Ret (Just r') [])
242+ (CGR tgt (show name))
243+ (CGS 0 nextGlobal (Name "begin") [] (map (Just . LocalReference . Name . show) argNames) S.empty)
244+ entryTerm = case bbs of
245+ [] -> Do $ Ret Nothing []
246+ BasicBlock n _ _:_ -> Do $ Br n []
247+ tell globals
248+ put nextGlobal'
249+ return . GlobalDefinition $ functionDefaults
250+ { G.linkage = L.Internal
251+ , G.callingConvention = CC.Fast
252+ , G.name = Name (show name)
253+ , G.returnType = PointerType valueType (AddrSpace 0)
254+ , G.parameters = (flip map argNames $ \argName ->
255+ Parameter (PointerType valueType (AddrSpace 0)) (Name (show argName)) []
256+ , False)
257+ , G.basicBlocks =
258+ BasicBlock (Name "entry")
259+ (map (\(n, t) -> n := Alloca t Nothing 0 []) allocas)
260+ entryTerm
261+ : bbs
262+ }
263+
264+type CGW = ([(Name, Type)], [BasicBlock], [Definition])
265+
266+type Env = [Maybe Operand]
267+
268+data CGS = CGS { nextName :: Word
269+ , nextGlobalName :: Word
270+ , currentBlockName :: Name
271+ , instAccum :: [Named Instruction]
272+ , lexenv :: Env
273+ , foreignSyms :: Set String
274+ }
275+
276+data CGR = CGR { target :: Target
277+ , funcName :: String }
278+
279+type Codegen = RWS CGR CGW CGS
280+
281+getFuncName :: Codegen String
282+getFuncName = asks funcName
283+
284+getGlobalUnName :: Codegen Name
285+getGlobalUnName = do
286+ i <- gets nextGlobalName
287+ modify $ \s -> s { nextGlobalName = 1 + i }
288+ return (UnName i)
289+
290+getUnName :: Codegen Name
291+getUnName = do
292+ i <- gets nextName
293+ modify $ \s -> s { nextName = 1 + i }
294+ return (UnName i)
295+
296+getName :: String -> Codegen Name
297+getName n = do
298+ i <- gets nextName
299+ modify $ \s -> s { nextName = 1 + i }
300+ return (Name $ n ++ show i)
301+
302+alloca :: Name -> Type -> Codegen ()
303+alloca n t = tell ([(n, t)], [], [])
304+
305+terminate :: Terminator -> Codegen ()
306+terminate term = do
307+ name <- gets currentBlockName
308+ insts <- gets instAccum
309+ modify $ \s -> s { instAccum = ierror "Not in a block"
310+ , currentBlockName = ierror "Not in a block" }
311+ tell ([], [BasicBlock name insts (Do term)], [])
312+
313+newBlock :: Name -> Codegen ()
314+newBlock name = modify $ \s -> s { instAccum = []
315+ , currentBlockName = name
316+ }
317+
318+inst :: Instruction -> Codegen Operand
319+inst i = do
320+ n <- getUnName
321+ modify $ \s -> s { instAccum = instAccum s ++ [n := i] }
322+ return $ LocalReference n
323+
324+ninst :: String -> Instruction -> Codegen Operand
325+ninst name i = do
326+ n <- getName name
327+ modify $ \s -> s { instAccum = instAccum s ++ [n := i] }
328+ return $ LocalReference n
329+
330+inst' :: Instruction -> Codegen ()
331+inst' i = modify $ \s -> s { instAccum = instAccum s ++ [Do i] }
332+
333+insts :: [Named Instruction] -> Codegen ()
334+insts is = modify $ \s -> s { instAccum = instAccum s ++ is }
335+
336+var :: LVar -> Codegen (Maybe Operand)
337+var (Loc level) = (!! level) <$> gets lexenv
338+var (Glob n) = return . Just . ConstantOperand . C.GlobalReference . Name $ show n
339+
340+binds :: Env -> Codegen (Maybe Operand) -> Codegen (Maybe Operand)
341+binds vals cg = do
342+ envLen <- length <$> gets lexenv
343+ modify $ \s -> s { lexenv = lexenv s ++ vals }
344+ value <- cg
345+ modify $ \s -> s { lexenv = take envLen $ lexenv s }
346+ return value
347+
348+replaceElt :: Int -> a -> [a] -> [a]
349+replaceElt _ val [] = error "replaceElt: Ran out of list"
350+replaceElt 0 val (x:xs) = val:xs
351+replaceElt n val (x:xs) = x : replaceElt (n-1) val xs
352+
353+alloc' :: Operand -> Codegen Operand
354+alloc' size = inst $ simpleCall "GC_malloc" [size]
355+
356+allocAtomic :: Operand -> Codegen Operand
357+allocAtomic size = inst $ simpleCall "GC_malloc_atomic" [size]
358+
359+alloc :: Type -> Codegen Operand
360+alloc ty = do
361+ size <- sizeOf ty
362+ mem <- alloc' size
363+ inst $ BitCast mem (PointerType ty (AddrSpace 0)) []
364+
365+sizeOf :: Type -> Codegen Operand
366+sizeOf ty = ConstantOperand . C.PtrToInt
367+ (C.GetElementPtr True (C.Null (PointerType ty (AddrSpace 0))) [C.Int 32 1])
368+ . IntegerType . fromIntegral <$> getWordSize
369+
370+tgtWordSize :: Target -> Integer
371+tgtWordSize (Target { arch = "i386" }) = 32
372+tgtWordSize (Target { arch = "x86_64" }) = 64
373+
374+getWordSize :: Codegen Integer
375+getWordSize = tgtWordSize <$> asks target
376+
377+cgExpr :: SExp -> Codegen (Maybe Operand)
378+cgExpr (SV v) = var v
379+cgExpr (SApp tailcall fname args) = do
380+ argSlots <- mapM var args
381+ case sequence argSlots of
382+ Nothing -> return Nothing
383+ Just argVals -> do
384+ fn <- var (Glob fname)
385+ Just <$> inst ((idrCall (show fname) argVals) { isTailCall = tailcall })
386+cgExpr (SLet _ varExpr bodyExpr) = do
387+ val <- cgExpr varExpr
388+ binds [val] $ cgExpr bodyExpr
389+cgExpr (SUpdate (Loc level) expr) = do
390+ val <- cgExpr expr
391+ modify $ \s -> s { lexenv = replaceElt level val (lexenv s) }
392+ return val
393+cgExpr (SCon tag name args) = do
394+ argSlots <- mapM var args
395+ case sequence argSlots of
396+ Nothing -> return Nothing
397+ Just argVals -> do
398+ con <- alloc . conType . fromIntegral . length $ argVals
399+ tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []
400+ inst' $ Store False tagPtr (ConstantOperand (C.Int 32 (fromIntegral tag))) Nothing 0 []
401+ forM_ (zip argVals [0..]) $ \(arg, i) -> do
402+ ptr <- inst $ GetElementPtr True con [ ConstantOperand (C.Int 32 0)
403+ , ConstantOperand (C.Int 32 1)
404+ , ConstantOperand (C.Int 32 i)] []
405+ inst' $ Store False ptr arg Nothing 0 []
406+ Just <$> inst (BitCast con (PointerType valueType (AddrSpace 0)) [])
407+cgExpr (SCase inspect alts) = do
408+ val <- var inspect
409+ case val of
410+ Nothing -> return Nothing
411+ Just v -> cgCase v alts
412+cgExpr (SChkCase inspect alts) = do
413+ mval <- var inspect
414+ case mval of
415+ Nothing -> return Nothing
416+ Just val ->
417+ do endBBN <- getName "endChkCase"
418+ notNullBBN <- getName "notNull"
419+ originBlock <- gets currentBlockName
420+ isNull <- inst $ ICmp IPred.EQ val (ConstantOperand nullValue) []
421+ terminate $ CondBr isNull endBBN notNullBBN []
422+ newBlock notNullBBN
423+ ptr <- inst $ BitCast val (PointerType (IntegerType 32) (AddrSpace 0)) []
424+ flag <- inst $ Load False ptr Nothing 0 []
425+ isVal <- inst $ ICmp IPred.EQ flag (ConstantOperand (C.Int 32 (-1))) []
426+ conBBN <- getName "constructor"
427+ terminate $ CondBr isVal endBBN conBBN []
428+ newBlock conBBN
429+ result <- cgCase val alts
430+ caseExitBlock <- gets currentBlockName
431+ case result of
432+ Nothing -> do
433+ terminate $ Unreachable []
434+ newBlock endBBN
435+ return $ Just val
436+ Just caseVal -> do
437+ terminate $ Br endBBN []
438+ newBlock endBBN
439+ Just <$> inst (Phi (PointerType valueType (AddrSpace 0))
440+ [(val, originBlock), (val, notNullBBN), (caseVal, caseExitBlock)] [])
441+cgExpr (SProj conVar idx) = do
442+ val <- var conVar
443+ case val of
444+ Nothing -> return Nothing
445+ Just v ->
446+ do ptr <- inst $ GetElementPtr True v
447+ [ ConstantOperand (C.Int 32 0)
448+ , ConstantOperand (C.Int 32 1)
449+ , ConstantOperand (C.Int 32 (fromIntegral idx))
450+ ] []
451+ Just <$> inst (Load False ptr Nothing 0 [])
452+cgExpr (SConst c) = Just <$> cgConst c
453+cgExpr (SForeign LANG_C rty fname args) = do
454+ func <- ensureCDecl fname rty (map fst args)
455+ argVals <- forM args $ \(fty, v) -> do
456+ v' <- var v
457+ case v' of
458+ Just val -> return $ Just (fty, val)
459+ Nothing -> return Nothing
460+ case sequence argVals of
461+ Nothing -> return Nothing
462+ Just argVals' -> do
463+ argUVals <- mapM (uncurry unbox) argVals'
464+ result <- inst Call { isTailCall = False
465+ , callingConvention = CC.C
466+ , returnAttributes = []
467+ , function = Right func
468+ , arguments = map (\v -> (v, [])) argUVals
469+ , functionAttributes = []
470+ , metadata = []
471+ }
472+ Just <$> box rty result
473+cgExpr (SOp fn args) = do
474+ argVals <- mapM var args
475+ case sequence argVals of
476+ Just ops -> Just <$> cgOp fn ops
477+ Nothing -> return Nothing
478+cgExpr SNothing = return . Just . ConstantOperand $ nullValue
479+cgExpr (SError msg) = do -- TODO: Print message
480+ str <- addGlobal' (ArrayType (2 + fromIntegral (length msg)) (IntegerType 8))
481+ (cgConst' (TT.Str (msg ++ "\n")))
482+ inst' $ simpleCall "putStr" [ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0
483+ , C.Int 32 0]]
484+ inst' Call { isTailCall = True
485+ , callingConvention = CC.C
486+ , returnAttributes = []
487+ , function = Right . ConstantOperand . C.GlobalReference . Name $ "llvm.trap"
488+ , arguments = []
489+ , functionAttributes = [A.NoReturn]
490+ , metadata = []
491+ }
492+ return Nothing
493+
494+cgCase :: Operand -> [SAlt] -> Codegen (Maybe Operand)
495+cgCase val alts =
496+ case find isConstCase alts of
497+ Just (SConstCase (TT.BI _) _) -> cgChainCase val defExp constAlts
498+ Just (SConstCase (TT.Str _) _) -> cgChainCase val defExp constAlts
499+ Just (SConstCase _ _) -> cgPrimCase val defExp constAlts
500+ Nothing -> cgConCase val defExp conAlts
501+ where
502+ defExp = getDefExp =<< find isDefCase alts
503+ constAlts = filter isConstCase alts
504+ conAlts = filter isConCase alts
505+
506+ isConstCase (SConstCase {}) = True
507+ isConstCase _ = False
508+
509+ isConCase (SConCase {}) = True
510+ isConCase _ = False
511+
512+ isDefCase (SDefaultCase _) = True
513+ isDefCase _ = False
514+
515+ getDefExp (SDefaultCase e) = Just e
516+ getDefExp _ = Nothing
517+
518+cgPrimCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
519+cgPrimCase caseValPtr defExp alts = do
520+ let caseTy = case head alts of
521+ SConstCase (TT.I _) _ -> IntegerType 32
522+ SConstCase (TT.B8 _) _ -> IntegerType 8
523+ SConstCase (TT.B16 _) _ -> IntegerType 16
524+ SConstCase (TT.B32 _) _ -> IntegerType 32
525+ SConstCase (TT.B64 _) _ -> IntegerType 64
526+ SConstCase (TT.Fl _) _ -> FloatingPointType 64 IEEE
527+ SConstCase (TT.Ch _) _ -> IntegerType 32
528+ realPtr <- inst $ BitCast caseValPtr (PointerType (primTy caseTy) (AddrSpace 0)) []
529+ valPtr <- inst $ GetElementPtr True realPtr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
530+ caseVal <- inst $ Load False valPtr Nothing 0 []
531+ defBlockName <- getName "default"
532+ exitBlockName <- getName "caseExit"
533+ namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
534+ terminate $ Switch caseVal defBlockName (map (\(n, SConstCase c _) -> (cgConst' c, n)) namedAlts) []
535+ initEnv <- gets lexenv
536+ defResult <- cgDefaultAlt exitBlockName defBlockName defExp
537+ results <- forM namedAlts $ \(name, SConstCase _ exp) -> cgAlt initEnv exitBlockName name Nothing exp
538+ finishCase initEnv exitBlockName (defResult:results)
539+
540+cgConCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
541+cgConCase con defExp alts = do
542+ tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []
543+ tag <- inst $ Load False tagPtr Nothing 0 []
544+ defBlockName <- getName "default"
545+ exitBlockName <- getName "caseExit"
546+ namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
547+ terminate $ Switch tag defBlockName (map (\(n, SConCase _ tag _ _ _) ->
548+ (C.Int 32 (fromIntegral tag), n)) namedAlts) []
549+ initEnv <- gets lexenv
550+ defResult <- cgDefaultAlt exitBlockName defBlockName defExp
551+ results <- forM namedAlts $ \(name, SConCase _ _ _ argns exp) ->
552+ cgAlt initEnv exitBlockName name (Just (con, map show argns)) exp
553+ finishCase initEnv exitBlockName (defResult:results)
554+
555+cgChainCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
556+cgChainCase caseValPtr defExp alts = do
557+ let (caseTy, comparator) =
558+ case head alts of
559+ SConstCase (TT.BI _) _ -> (FInt ITBig, "__gmpz_cmp")
560+ SConstCase (TT.Str _) _ -> (FString, "strcmp")
561+ caseVal <- unbox caseTy caseValPtr
562+ defBlockName <- getName "default"
563+ exitBlockName <- getName "caseExit"
564+ namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
565+ initEnv <- gets lexenv
566+ results <- forM namedAlts $ \(name, SConstCase c e) ->
567+ do const <- unbox caseTy =<< cgConst c
568+ cmp <- inst $ simpleCall comparator [const, caseVal]
569+ cmpResult <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) []
570+ elseName <- getName "else"
571+ terminate $ CondBr cmpResult name elseName []
572+ result <- cgAlt initEnv exitBlockName name Nothing e
573+ newBlock elseName
574+ return result
575+ modify $ \s -> s { lexenv = initEnv }
576+ fname <- getFuncName
577+ defaultVal <- cgExpr (fromMaybe (SError $ "Inexhaustive case failure in " ++ fname) defExp)
578+ defaultBlock <- gets currentBlockName
579+ defaultEnv <- gets lexenv
580+ defResult <- case defaultVal of
581+ Just v -> do
582+ terminate $ Br exitBlockName []
583+ return $ Just (v, defaultBlock, defaultEnv)
584+ Nothing -> do
585+ terminate $ Unreachable []
586+ return Nothing
587+ finishCase initEnv exitBlockName (defResult:results)
588+
589+finishCase :: Env -> Name -> [Maybe (Operand, Name, Env)] -> Codegen (Maybe Operand)
590+finishCase initEnv exitBlockName results = do
591+ let definedResults = mapMaybe id results
592+ case definedResults of
593+ [] -> do modify $ \s -> s { lexenv = initEnv }
594+ return Nothing
595+ xs -> do
596+ newBlock exitBlockName
597+ mergeEnvs $ map (\(_, altBlock, altEnv) -> (altBlock, altEnv)) xs
598+ Just <$> inst (Phi (PointerType valueType (AddrSpace 0))
599+ (map (\(altVal, altBlock, _) -> (altVal, altBlock)) xs) [])
600+
601+
602+cgDefaultAlt :: Name -> Name -> Maybe SExp -> Codegen (Maybe (Operand, Name, Env))
603+cgDefaultAlt exitName name exp = do
604+ newBlock name
605+ fname <- getFuncName
606+ val <- cgExpr (fromMaybe (SError $ "Inexhaustive case failure in " ++ fname) exp)
607+ env <- gets lexenv
608+ block <- gets currentBlockName
609+ case val of
610+ Just v ->
611+ do terminate $ Br exitName []
612+ return $ Just (v, block, env)
613+ Nothing ->
614+ do terminate $ Unreachable []
615+ return Nothing
616+
617+cgAlt :: Env -> Name -> Name -> Maybe (Operand, [String]) -> SExp
618+ -> Codegen (Maybe (Operand, Name, Env))
619+cgAlt initEnv exitBlockName name destr exp = do
620+ modify $ \s -> s { lexenv = initEnv }
621+ newBlock name
622+ locals <- case destr of
623+ Nothing -> return []
624+ Just (con, argns) ->
625+ forM (zip argns [0..]) $ \(argName, i) ->
626+ do ptr <- inst $ GetElementPtr True con [ ConstantOperand (C.Int 32 0)
627+ , ConstantOperand (C.Int 32 1)
628+ , ConstantOperand (C.Int 32 i)] []
629+ Just <$> ninst argName (Load False ptr Nothing 0 [])
630+ altVal <- binds locals $ cgExpr exp
631+ altEnv <- gets lexenv
632+ altBlock <- gets currentBlockName
633+ case altVal of
634+ Just v -> do
635+ terminate $ Br exitBlockName []
636+ return $ Just (v, altBlock, altEnv)
637+ Nothing -> do
638+ terminate $ Unreachable []
639+ return Nothing
640+
641+mergeEnvs :: [(Name, Env)] -> Codegen ()
642+mergeEnvs es = do
643+ let vars = transpose
644+ . map (\(block, env) -> map (\x -> (x, block)) env)
645+ $ es
646+ env <- forM vars $ \var ->
647+ case var of
648+ [] -> ierror "mergeEnvs: impossible"
649+ [(v, _)] -> return v
650+ vs@((v, _):_)
651+ | all (== v) (map fst vs) -> return v
652+ | otherwise ->
653+ let valid = map (\(a, b) -> (fromJust a, b)) . filter (isJust . fst) $ vs in
654+ Just <$> inst (Phi (PointerType valueType (AddrSpace 0)) valid [])
655+ modify $ \s -> s { lexenv = env }
656+
657+nameAlt :: Name -> SAlt -> Codegen Name
658+nameAlt d (SDefaultCase _) = return d
659+nameAlt _ (SConCase _ _ name _ _) = getName (show name)
660+nameAlt _ (SConstCase const _) = getName (show const)
661+
662+box :: FType -> Operand -> Codegen Operand
663+box FUnit _ = return $ ConstantOperand nullValue
664+box fty fval = do
665+ val <- alloc (primTy (ftyToTy fty))
666+ tagptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []
667+ valptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
668+ inst' $ Store False tagptr (ConstantOperand (C.Int 32 (-1))) Nothing 0 []
669+ inst' $ Store False valptr fval Nothing 0 []
670+ inst $ BitCast val (PointerType valueType (AddrSpace 0)) []
671+
672+unbox :: FType -> Operand -> Codegen Operand
673+unbox FUnit x = return x
674+unbox fty bval = do
675+ val <- inst $ BitCast bval (PointerType (primTy (ftyToTy fty)) (AddrSpace 0)) []
676+ fvalptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
677+ inst $ Load False fvalptr Nothing 0 []
678+
679+cgConst' :: TT.Const -> C.Constant
680+cgConst' (TT.I i) = C.Int 32 (fromIntegral i)
681+cgConst' (TT.B8 i) = C.Int 8 (fromIntegral i)
682+cgConst' (TT.B16 i) = C.Int 16 (fromIntegral i)
683+cgConst' (TT.B32 i) = C.Int 32 (fromIntegral i)
684+cgConst' (TT.B64 i) = C.Int 64 (fromIntegral i)
685+cgConst' (TT.BI i) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) (show i) ++ [C.Int 8 0])
686+cgConst' (TT.Fl f) = C.Float (F.Double f)
687+cgConst' (TT.Ch c) = C.Int 32 . fromIntegral . fromEnum $ c
688+cgConst' (TT.Str s) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) s ++ [C.Int 8 0])
689+cgConst' x = ierror $ "Unsupported constant: " ++ show x
690+
691+cgConst :: TT.Const -> Codegen Operand
692+cgConst c@(TT.I _) = box (FInt ITNative) (ConstantOperand $ cgConst' c)
693+cgConst c@(TT.B8 _) = box (FInt IT8) (ConstantOperand $ cgConst' c)
694+cgConst c@(TT.B16 _) = box (FInt IT16) (ConstantOperand $ cgConst' c)
695+cgConst c@(TT.B32 _) = box (FInt IT32) (ConstantOperand $ cgConst' c)
696+cgConst c@(TT.B64 _) = box (FInt IT64) (ConstantOperand $ cgConst' c)
697+cgConst c@(TT.Fl _) = box FDouble (ConstantOperand $ cgConst' c)
698+cgConst c@(TT.Ch _) = box FChar (ConstantOperand $ cgConst' c)
699+cgConst c@(TT.Str s) = do
700+ str <- addGlobal' (ArrayType (1 + fromIntegral (length s)) (IntegerType 8)) (cgConst' c)
701+ box FString (ConstantOperand $ C.GetElementPtr True str [C.Int 32 0, C.Int 32 0])
702+cgConst c@(TT.BI i) = do
703+ str <- addGlobal' (ArrayType (1 + fromInteger (numDigits 10 i)) (IntegerType 8)) (cgConst' c)
704+ mpz <- alloc mpzTy
705+ inst $ simpleCall "__gmpz_init_set_str" [mpz
706+ , ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0, C.Int 32 0]
707+ , ConstantOperand $ C.Int 32 10
708+ ]
709+ box (FInt ITBig) mpz
710+cgConst x = return $ ConstantOperand nullValue
711+
712+numDigits :: Integer -> Integer -> Integer
713+numDigits b n = 1 + fst (ilog b n) where
714+ ilog b n
715+ | n < b = (0, n)
716+ | otherwise = let (e, r) = ilog (b*b) n
717+ in if r < b then (2*e, r) else (2*e+1, r `div` b)
718+
719+addGlobal :: Global -> Codegen ()
720+addGlobal def = tell ([], [], [GlobalDefinition def])
721+
722+addGlobal' :: Type -> C.Constant -> Codegen C.Constant
723+addGlobal' ty val = do
724+ name <- getGlobalUnName
725+ addGlobal $ globalVariableDefaults
726+ { G.name = name
727+ , G.linkage = L.Internal
728+ , G.hasUnnamedAddr = True
729+ , G.isConstant = True
730+ , G.type' = ty
731+ , G.initializer = Just val
732+ }
733+ return . C.GlobalReference $ name
734+
735+
736+ensureCDecl :: String -> FType -> [FType] -> Codegen Operand
737+ensureCDecl name rty argtys = do
738+ syms <- gets foreignSyms
739+ unless (S.member name syms) $
740+ do addGlobal (ffunDecl name rty argtys)
741+ modify $ \s -> s { foreignSyms = S.insert name (foreignSyms s) }
742+ return $ ConstantOperand (C.GlobalReference (Name name))
743+
744+ffunDecl :: String -> FType -> [FType] -> Global
745+ffunDecl name rty argtys =
746+ functionDefaults
747+ { G.returnType = ftyToTy rty
748+ , G.name = Name name
749+ , G.parameters = (flip map argtys $ \fty ->
750+ Parameter (ftyToTy fty) (UnName 0) []
751+ , False)
752+ }
753+
754+ftyToTy :: FType -> Type
755+ftyToTy (FInt ITNative) = IntegerType 32
756+ftyToTy (FInt ITBig) = PointerType mpzTy (AddrSpace 0)
757+ftyToTy (FInt ty) = IntegerType (itWidth ty)
758+ftyToTy FChar = IntegerType 32
759+ftyToTy FString = PointerType (IntegerType 8) (AddrSpace 0)
760+ftyToTy FUnit = VoidType
761+ftyToTy FPtr = PointerType (IntegerType 8) (AddrSpace 0)
762+ftyToTy FDouble = FloatingPointType 64 IEEE
763+ftyToTy FAny = valueType
764+
765+cgOp :: PrimFn -> [Operand] -> Codegen Operand
766+cgOp (LTrunc ITBig ity) [x] = do
767+ nx <- unbox (FInt ITBig) x
768+ val <- inst $ simpleCall "mpz_get_ull" [nx]
769+ v <- case ity of
770+ IT64 -> return val
771+ _ -> inst $ Trunc val (IntegerType $ itWidth ity) []
772+ box (FInt ity) v
773+cgOp (LZExt from ITBig) [x] = do
774+ nx <- unbox (FInt from) x
775+ nx' <- case from of
776+ IT64 -> return nx
777+ _ -> inst $ ZExt nx (IntegerType 64) []
778+ mpz <- alloc mpzTy
779+ inst' $ simpleCall "mpz_init_set_ull" [mpz, nx']
780+ box (FInt ITBig) mpz
781+cgOp (LSExt from ITBig) [x] = do
782+ nx <- unbox (FInt from) x
783+ nx' <- case from of
784+ IT64 -> return nx
785+ _ -> inst $ SExt nx (IntegerType 64) []
786+ mpz <- alloc mpzTy
787+ inst' $ simpleCall "mpz_init_set_sll" [mpz, nx']
788+ box (FInt ITBig) mpz
789+
790+cgOp (LLt ITBig) [x,y] = mpzCmp IPred.SLT x y
791+cgOp (LLe ITBig) [x,y] = mpzCmp IPred.SLE x y
792+cgOp (LEq ITBig) [x,y] = mpzCmp IPred.EQ x y
793+cgOp (LGe ITBig) [x,y] = mpzCmp IPred.SGE x y
794+cgOp (LGt ITBig) [x,y] = mpzCmp IPred.SGT x y
795+cgOp (LPlus ITBig) [x,y] = mpzBin "add" x y
796+cgOp (LMinus ITBig) [x,y] = mpzBin "sub" x y
797+cgOp (LTimes ITBig) [x,y] = mpzBin "mul" x y
798+cgOp (LSDiv ITBig) [x,y] = mpzBin "fdiv_q" x y
799+cgOp (LSRem ITBig) [x,y] = mpzBin "fdiv_r" x y
800+cgOp (LAnd ITBig) [x,y] = mpzBin "and" x y
801+cgOp (LOr ITBig) [x,y] = mpzBin "ior" x y
802+cgOp (LXOr ITBig) [x,y] = mpzBin "xor" x y
803+cgOp (LCompl ITBig) [x] = mpzUn "com" x
804+
805+cgOp (LTrunc from to) [x] | itWidth from > itWidth to = iCoerce Trunc from to x
806+cgOp (LZExt from to) [x] | itWidth from < itWidth to = iCoerce ZExt from to x
807+cgOp (LSExt from to) [x] | itWidth from < itWidth to = iCoerce SExt from to x
808+
809+cgOp (LLt ity) [x,y] = iCmp ity IPred.SLT x y
810+cgOp (LLe ity) [x,y] = iCmp ity IPred.SLE x y
811+cgOp (LEq ity) [x,y] = iCmp ity IPred.EQ x y
812+cgOp (LGe ity) [x,y] = iCmp ity IPred.SGE x y
813+cgOp (LGt ity) [x,y] = iCmp ity IPred.SGT x y
814+cgOp (LPlus ity) [x,y] = ibin ity x y (Add False False)
815+cgOp (LMinus ity) [x,y] = ibin ity x y (Sub False False)
816+cgOp (LTimes ity) [x,y] = ibin ity x y (Mul False False)
817+cgOp (LUDiv ity) [x,y] = ibin ity x y (UDiv False)
818+cgOp (LURem ity) [x,y] = ibin ity x y URem
819+cgOp (LSDiv ity) [x,y] = ibin ity x y (SDiv False)
820+cgOp (LSRem ity) [x,y] = ibin ity x y SRem
821+cgOp (LAnd ity) [x,y] = ibin ity x y And
822+cgOp (LOr ity) [x,y] = ibin ity x y Or
823+cgOp (LXOr ity) [x,y] = ibin ity x y Xor
824+cgOp (LCompl ity) [x] = iun ity x (Xor (ConstantOperand (C.Int (itWidth ity) (-1))))
825+cgOp (LSHL ity) [x,y] = ibin ity x y (Shl False False)
826+cgOp (LLSHR ity) [x,y] = ibin ity x y (LShr False)
827+cgOp (LASHR ity) [x,y] = ibin ity x y (AShr False)
828+
829+cgOp LStrEq [x,y] = do
830+ x' <- unbox FString x
831+ y' <- unbox FString y
832+ cmp <- inst $ simpleCall "strcmp" [x', y']
833+ flag <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) []
834+ val <- inst $ ZExt flag (IntegerType 32) []
835+ box (FInt IT32) val
836+
837+cgOp LStrLt [x,y] = do
838+ nx <- unbox FString x
839+ ny <- unbox FString y
840+ cmp <- inst $ simpleCall "strcmp" [nx, ny]
841+ flag <- inst $ ICmp IPred.ULT cmp (ConstantOperand (C.Int 32 0)) []
842+ val <- inst $ ZExt flag (IntegerType 32) []
843+ box (FInt IT32) val
844+
845+cgOp (LIntStr ITBig) [x] = do
846+ x' <- unbox (FInt ITBig) x
847+ ustr <- inst $ simpleCall "__gmpz_get_str"
848+ [ ConstantOperand (C.Null (PointerType (IntegerType 8) (AddrSpace 0)))
849+ , ConstantOperand (C.Int 32 10)
850+ , x'
851+ ]
852+ box FString ustr
853+cgOp (LIntStr ity) [x] = do
854+ x' <- unbox (FInt ity) x
855+ x'' <- if itWidth ity < 64
856+ then inst $ SExt x' (IntegerType 64) []
857+ else return x'
858+ box FString =<< inst (idrCall "__idris_intStr" [x''])
859+cgOp (LStrInt ITBig) [s] = do
860+ ns <- unbox FString s
861+ mpz <- alloc mpzTy
862+ inst $ simpleCall "__gmpz_init_set_str" [mpz, ns, ConstantOperand $ C.Int 32 10]
863+ box (FInt ITBig) mpz
864+cgOp (LStrInt ity) [s] = do
865+ ns <- unbox FString s
866+ nx <- inst $ simpleCall "strtoll"
867+ [ns
868+ , ConstantOperand $ C.Null (PointerType (PointerType (IntegerType 8) (AddrSpace 0)) (AddrSpace 0))
869+ , ConstantOperand $ C.Int 32 10
870+ ]
871+ nx' <- case ity of
872+ IT64 -> return nx
873+ _ -> inst $ Trunc nx (IntegerType (itWidth ity)) []
874+ box (FInt ity) nx'
875+
876+cgOp LStrConcat [x,y] = cgStrCat x y
877+
878+cgOp LStrCons [c,s] = do
879+ nc <- unbox FChar c
880+ ns <- unbox FString s
881+ nc' <- inst $ Trunc nc (IntegerType 8) []
882+ r <- inst $ simpleCall "__idris_strCons" [nc', ns]
883+ box FString r
884+
885+cgOp LStrHead [c] = do
886+ s <- unbox FString c
887+ c <- inst $ Load False s Nothing 0 []
888+ c' <- inst $ ZExt c (IntegerType 32) []
889+ box FChar c'
890+
891+cgOp LStrIndex [s, i] = do
892+ ns <- unbox FString s
893+ ni <- unbox (FInt IT32) i
894+ p <- inst $ GetElementPtr True ns [ni] []
895+ c <- inst $ Load False p Nothing 0 []
896+ c' <- inst $ ZExt c (IntegerType 32) []
897+ box FChar c'
898+
899+cgOp LStrTail [c] = do
900+ s <- unbox FString c
901+ c <- inst $ GetElementPtr True s [ConstantOperand $ C.Int 32 1] []
902+ box FString c
903+
904+cgOp LStrLen [s] = do
905+ ns <- unbox FString s
906+ len <- inst $ simpleCall "strlen" [ns]
907+ ws <- getWordSize
908+ len' <- case ws of
909+ 32 -> return len
910+ x | x > 32 -> inst $ Trunc len (IntegerType $ fromInteger x) []
911+ | x < 32 -> inst $ ZExt len (IntegerType $ fromInteger x) []
912+ box (FInt IT32) len'
913+
914+cgOp LReadStr [p] = do
915+ np <- unbox FPtr p
916+ s <- inst $ simpleCall "__idris_readStr" [np]
917+ box FString s
918+
919+cgOp LStdIn [] = do
920+ ptr <- inst $ Load False (ConstantOperand . C.GlobalReference . Name $ "stdin") Nothing 0 []
921+ box FPtr ptr
922+cgOp LStdOut [] = do
923+ ptr <- inst $ Load False (ConstantOperand . C.GlobalReference . Name $ "stdout") Nothing 0 []
924+ box FPtr ptr
925+cgOp LStdErr [] = do
926+ ptr <- inst $ Load False (ConstantOperand . C.GlobalReference . Name $ "stderr") Nothing 0 []
927+ box FPtr ptr
928+
929+
930+cgOp prim args = ierror $ "Unimplemented primitive: [" ++ show prim ++ "]("
931+ ++ intersperse ',' (take (length args) ['a'..]) ++ ")"
932+
933+iCoerce :: (Operand -> Type -> InstructionMetadata -> Instruction) -> IntTy -> IntTy -> Operand -> Codegen Operand
934+iCoerce operator from to x = do
935+ x' <- unbox (FInt from) x
936+ x'' <- inst $ operator x' (IntegerType $ itWidth to) []
937+ box (FInt to) x''
938+
939+cgStrCat :: Operand -> Operand -> Codegen Operand
940+cgStrCat x y = do
941+ x' <- unbox FString x
942+ y' <- unbox FString y
943+ xlen <- inst $ simpleCall "strlen" [x']
944+ ylen <- inst $ simpleCall "strlen" [y']
945+ zlen <- inst $ Add False True xlen ylen []
946+ ws <- fromIntegral <$> getWordSize
947+ total <- inst $ Add False True zlen (ConstantOperand (C.Int ws 1)) []
948+ mem <- allocAtomic total
949+ inst $ simpleCall "memcpy" [mem, x', xlen]
950+ i <- inst $ PtrToInt mem (IntegerType ws) []
951+ offi <- inst $ Add False True i xlen []
952+ offp <- inst $ IntToPtr offi (PointerType (IntegerType 8) (AddrSpace 0)) []
953+ inst $ simpleCall "memcpy" [offp, y', ylen]
954+ j <- inst $ PtrToInt offp (IntegerType ws) []
955+ offj <- inst $ Add False True j ylen []
956+ end <- inst $ IntToPtr offj (PointerType (IntegerType 8) (AddrSpace 0)) []
957+ inst' $ Store False end (ConstantOperand (C.Int 8 0)) Nothing 0 []
958+ box FString mem
959+
960+ibin :: IntTy -> Operand -> Operand
961+ -> (Operand -> Operand -> InstructionMetadata -> Instruction) -> Codegen Operand
962+ibin ity x y instCon = do
963+ nx <- unbox (FInt ity) x
964+ ny <- unbox (FInt ity) y
965+ nr <- inst $ instCon nx ny []
966+ box (FInt ity) nr
967+
968+iun :: IntTy -> Operand -> (Operand -> InstructionMetadata -> Instruction) -> Codegen Operand
969+iun ity x instCon = do
970+ nx <- unbox (FInt ity) x
971+ nr <- inst $ instCon nx []
972+ box (FInt ity) nr
973+
974+iCmp :: IntTy -> IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand
975+iCmp ity pred x y = do
976+ nx <- unbox (FInt ity) x
977+ ny <- unbox (FInt ity) y
978+ nr <- inst $ ICmp pred nx ny []
979+ nr' <- inst $ ZExt nr (IntegerType 32) []
980+ box (FInt IT32) nr'
981+
982+mpzBin :: String -> Operand -> Operand -> Codegen Operand
983+mpzBin name x y = do
984+ nx <- unbox (FInt ITBig) x
985+ ny <- unbox (FInt ITBig) y
986+ nz <- alloc mpzTy
987+ inst' $ simpleCall "__gmpz_init" [nz]
988+ inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx, ny]
989+ box (FInt ITBig) nz
990+
991+mpzUn :: String -> Operand -> Codegen Operand
992+mpzUn name x = do
993+ nx <- unbox (FInt ITBig) x
994+ nz <- alloc mpzTy
995+ inst' $ simpleCall "__gmpz_init" [nz]
996+ inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx]
997+ box (FInt ITBig) nz
998+
999+mpzCmp :: IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand
1000+mpzCmp pred x y = do
1001+ nx <- unbox (FInt ITBig) x
1002+ ny <- unbox (FInt ITBig) y
1003+ cmp <- inst $ simpleCall "__gmpz_cmp" [nx, ny]
1004+ result <- inst $ ICmp pred cmp (ConstantOperand (C.Int 32 0)) []
1005+ i <- inst $ ZExt result (IntegerType 32) []
1006+ box (FInt IT32) i
1007+
1008+simpleCall :: String -> [Operand] -> Instruction
1009+simpleCall name args =
1010+ Call { isTailCall = False
1011+ , callingConvention = CC.C
1012+ , returnAttributes = []
1013+ , function = Right . ConstantOperand . C.GlobalReference . Name $ name
1014+ , arguments = map (\x -> (x, [])) args
1015+ , functionAttributes = []
1016+ , metadata = []
1017+ }
1018+
1019+idrCall :: String -> [Operand] -> Instruction
1020+idrCall name args =
1021+ Call { isTailCall = False
1022+ , callingConvention = CC.Fast
1023+ , returnAttributes = []
1024+ , function = Right . ConstantOperand . C.GlobalReference . Name $ name
1025+ , arguments = map (\x -> (x, [])) args
1026+ , functionAttributes = []
1027+ , metadata = []
1028+ }
1029+
1030+assert :: Operand -> String -> Codegen ()
1031+assert condition message = do
1032+ passed <- getName "assertPassed"
1033+ failed <- getName "assertFailed"
1034+ terminate $ CondBr condition passed failed []
1035+ newBlock failed
1036+ cgExpr (SError message)
1037+ terminate $ Unreachable []
1038+ newBlock passed
src/IRTS/Compiler.hs+3−1
@@ -10,6 +10,7 @@ import IRTS.CodegenC
1010import IRTS.CodegenJava
1111import IRTS.DumpBC
1212import IRTS.CodegenJavaScript
13+import IRTS.CodegenLLVM
1314import IRTS.Inliner
1415
1516import Idris.AbsSyntax
@@ -74,8 +75,9 @@ compile target f tm
7475 codegenJava [] c f hdrs libs outty
7576 ViaJavaScript ->
7677 codegenJavaScript JavaScript c f outty
77− ViaNode ->
78+ ViaNode ->
7879 codegenJavaScript Node c f outty
80+ ViaLLVM -> codegenLLVM c f outty
7981
8082 Bytecode -> dumpBC c f
8183 Error e -> fail $ show e
src/Idris/AbsSyntaxTree.hs+1
@@ -175,6 +175,7 @@ data Target = ViaC
175175 | ViaJava
176176 | ViaNode
177177 | ViaJavaScript
178+ | ViaLLVM
178179 | Bytecode
179180 deriving (Show, Eq)
180181
src/Idris/REPL.hs+1
@@ -566,6 +566,7 @@ parseTarget "Java" = ViaJava
566566parseTarget "bytecode" = Bytecode
567567parseTarget "javascript" = ViaJavaScript
568568parseTarget "node" = ViaNode
569+parseTarget "llvm" = ViaLLVM
569570parseTarget _ = error "unknown target" -- FIXME: partial function
570571
571572parseArgs :: [String] -> [Opt]