git.iko.soy/Idris-dev
on ce2d69d help sign in
Idris-dev/src/IRTS/CodegenLLVM.hs
1313 lines 54 kB history raw
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2module IRTS.CodegenLLVM (codegenLLVM) where
4import IRTS.CodegenCommon
5import IRTS.Lang
6import IRTS.Simplified
7import qualified Core.TT as TT
8import Core.TT (ArithTy(..), IntTy(..), NativeTy(..), nativeTyWidth)
10import Util.System
11import Paths_idris
13import LLVM.General.Context
14import LLVM.General.Diagnostic
15import LLVM.General.AST
16import LLVM.General.AST.AddrSpace
17import LLVM.General.Target ( TargetMachine
18 , withTargetOptions, withTargetMachine, getTargetMachineDataLayout
19 , initializeAllTargets, lookupTarget
20 )
21import LLVM.General.AST.DataLayout
22import qualified LLVM.General.PassManager as PM
23import qualified LLVM.General.Module as MO
24import qualified LLVM.General.AST.IntegerPredicate as IPred
25import qualified LLVM.General.AST.FloatingPointPredicate as FPred
26import qualified LLVM.General.AST.Linkage as L
27import qualified LLVM.General.AST.Visibility as V
28import qualified LLVM.General.AST.CallingConvention as CC
29import qualified LLVM.General.AST.Attribute as A
30import qualified LLVM.General.AST.Global as G
31import qualified LLVM.General.AST.Constant as C
32import qualified LLVM.General.AST.Float as F
33import qualified LLVM.General.Relocation as R
34import qualified LLVM.General.CodeModel as CM
35import qualified LLVM.General.CodeGenOpt as CGO
37import Data.List
38import Data.Maybe
39import Data.Word
40import Data.Map (Map)
41import qualified Data.Map as M
42import qualified Data.Set as S
43import qualified Data.Vector.Unboxed as V
44import Control.Applicative
45import Control.Monad.RWS
46import Control.Monad.Writer
47import Control.Monad.State
48import Control.Monad.Error
50import qualified System.Info as SI (arch, os)
51import System.IO
52import System.Directory (removeFile)
53import System.FilePath ((</>))
54import System.Process (rawSystem)
55import System.Exit (ExitCode(..))
56import Debug.Trace
58data Target = Target { triple :: String, dataLayout :: DataLayout }
60codegenLLVM :: [(TT.Name, SDecl)] ->
61 String -> -- target triple
62 String -> -- target CPU
63 Word -> -- Optimization degree
64 FilePath -> -- output file name
65 OutputType ->
66 IO ()
67codegenLLVM defs triple cpu optimize file outty = withContext $ \context -> do
68 initializeAllTargets
69 (target, _) <- failInIO $ lookupTarget Nothing triple
70 withTargetOptions $ \options ->
71 withTargetMachine target triple cpu S.empty options R.Default CM.Default CGO.Default $ \tm ->
72 do layout <- getTargetMachineDataLayout tm
73 let ast = codegen (Target triple layout) (map snd defs)
74 result <- runErrorT . MO.withModuleFromAST context ast $ \m ->
75 do let opts = PM.defaultCuratedPassSetSpec
76 { PM.optLevel = Just optimize
77 , PM.simplifyLibCalls = Just True
78 , PM.useInlinerWithThreshold = Just 225
79 }
80 when (optimize /= 0) $ PM.withPassManager opts $ void . flip PM.runPassManager m
81 outputModule tm file outty m
82 case result of
83 Right _ -> return ()
84 Left msg -> ierror msg
86failInIO :: ErrorT String IO a -> IO a
87failInIO = either fail return <=< runErrorT
89outputModule :: TargetMachine -> FilePath -> OutputType -> MO.Module -> IO ()
90outputModule _ file Raw m = failInIO $ MO.writeBitcodeToFile file m
91outputModule tm file Object m = failInIO $ MO.writeObjectToFile tm file m
92outputModule tm file Executable m = withTmpFile $ \obj -> do
93 outputModule tm obj Object m
94 cc <- getCC
95 defs <- (</> "llvm" </> "libidris_rts.a") <$> getDataDir
96 exit <- rawSystem cc [obj, defs, "-lm", "-lgmp", "-lgc", "-o", file]
97 when (exit /= ExitSuccess) $ ierror "FAILURE: Linking"
98outputModule _ _ MavenProject _ = ierror "FAILURE: unsupported output type"
100withTmpFile :: (FilePath -> IO a) -> IO a
101withTmpFile f = do
102 (path, handle) <- tempfile
103 hClose handle
104 result <- f path
105 removeFile path
106 return result
108ierror :: String -> a
109ierror msg = error $ "INTERNAL ERROR: IRTS.CodegenLLVM: " ++ msg
111mainDef :: Global
112mainDef =
113 functionDefaults
114 { G.returnType = IntegerType 32
115 , G.parameters =
116 ([ Parameter (IntegerType 32) (Name "argc") []
117 , Parameter (PointerType (PointerType (IntegerType 8) (AddrSpace 0)) (AddrSpace 0)) (Name "argv") []
118 ], False)
119 , G.name = Name "main"
120 , G.basicBlocks =
121 [ BasicBlock (UnName 0)
122 [ Do $ simpleCall "GC_init" [] -- Initialize Boehm GC
123 , Do $ simpleCall "__gmp_set_memory_functions"
124 [ ConstantOperand . C.GlobalReference . Name $ "__idris_gmpMalloc"
125 , ConstantOperand . C.GlobalReference . Name $ "__idris_gmpRealloc"
126 , ConstantOperand . C.GlobalReference . Name $ "__idris_gmpFree"
127 ]
128 , Do $ Store False (ConstantOperand . C.GlobalReference . Name $ "__idris_argc")
129 (LocalReference (Name "argc")) Nothing 0 []
130 , Do $ Store False (ConstantOperand . C.GlobalReference . Name $ "__idris_argv")
131 (LocalReference (Name "argv")) Nothing 0 []
132 , UnName 1 := idrCall "{runMain0}" [] ]
133 (Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [])
134 ]}
136initDefs :: Target -> [Definition]
137initDefs tgt =
138 [ TypeDefinition (Name "valTy")
139 (Just $ StructureType False
140 [ IntegerType 32
141 , ArrayType 0 (PointerType valueType (AddrSpace 0))
142 ])
143 , TypeDefinition (Name "mpz")
144 (Just $ StructureType False
145 [ IntegerType 32
146 , IntegerType 32
147 , PointerType intPtr (AddrSpace 0)
148 ])
149 , GlobalDefinition $ globalVariableDefaults
150 { G.name = Name "__idris_intFmtStr"
151 , G.linkage = L.Internal
152 , G.isConstant = True
153 , G.hasUnnamedAddr = True
154 , G.type' = ArrayType 5 (IntegerType 8)
155 , G.initializer = Just $ C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) "%lld" ++ [C.Int 8 0])
156 }
157 , rtsFun "intStr" ptrI8 [IntegerType 64]
158 [ BasicBlock (UnName 0)
159 [ UnName 1 := simpleCall "GC_malloc_atomic" [ConstantOperand (C.Int (tgtWordSize tgt) 21)]
160 , UnName 2 := simpleCall "snprintf"
161 [ LocalReference (UnName 1)
162 , ConstantOperand (C.Int (tgtWordSize tgt) 21)
163 , ConstantOperand $ C.GetElementPtr True (C.GlobalReference . Name $ "__idris_intFmtStr") [C.Int 32 0, C.Int 32 0]
164 , LocalReference (UnName 0)
165 ]
166 ]
167 (Do $ Ret (Just (LocalReference (UnName 1))) [])
168 ]
169 , GlobalDefinition $ globalVariableDefaults
170 { G.name = Name "__idris_floatFmtStr"
171 , G.linkage = L.Internal
172 , G.isConstant = True
173 , G.hasUnnamedAddr = True
174 , G.type' = ArrayType 5 (IntegerType 8)
175 , G.initializer = Just $ C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) "%g" ++ [C.Int 8 0])
176 }
177 , rtsFun "floatStr" ptrI8 [FloatingPointType 64 IEEE]
178 [ BasicBlock (UnName 0)
179 [ UnName 1 := simpleCall "GC_malloc_atomic" [ConstantOperand (C.Int (tgtWordSize tgt) 21)]
180 , UnName 2 := simpleCall "snprintf"
181 [ LocalReference (UnName 1)
182 , ConstantOperand (C.Int (tgtWordSize tgt) 21)
183 , ConstantOperand $ C.GetElementPtr True (C.GlobalReference . Name $ "__idris_floatFmtStr") [C.Int 32 0, C.Int 32 0]
184 , LocalReference (UnName 0)
185 ]
186 ]
187 (Do $ Ret (Just (LocalReference (UnName 1))) [])
188 ]
189 , exfun "llvm.sin.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False
190 , exfun "llvm.cos.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False
191 , exfun "llvm.pow.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False
192 , exfun "llvm.ceil.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False
193 , exfun "llvm.floor.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False
194 , exfun "llvm.exp.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False
195 , exfun "llvm.log.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False
196 , exfun "llvm.sqrt.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False
197 , exfun "tan" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False
198 , exfun "asin" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False
199 , exfun "acos" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False
200 , exfun "atan" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False
201 , exfun "llvm.trap" VoidType [] False
202 -- , exfun "llvm.llvm.memcpy.p0i8.p0i8.i32" VoidType [ptrI8, ptrI8, IntegerType 32, IntegerType 32, IntegerType 1] False
203 -- , exfun "llvm.llvm.memcpy.p0i8.p0i8.i64" VoidType [ptrI8, ptrI8, IntegerType 64, IntegerType 32, IntegerType 1] False
204 , exfun "memcpy" ptrI8 [ptrI8, ptrI8, intPtr] False
205 , exfun "llvm.invariant.start" (PointerType (StructureType False []) (AddrSpace 0)) [IntegerType 64, ptrI8] False
206 , exfun "snprintf" (IntegerType 32) [ptrI8, intPtr, ptrI8] True
207 , exfun "strcmp" (IntegerType 32) [ptrI8, ptrI8] False
208 , exfun "strlen" intPtr [ptrI8] False
209 , exfun "GC_init" VoidType [] False
210 , exfun "GC_malloc" ptrI8 [intPtr] False
211 , exfun "GC_malloc_atomic" ptrI8 [intPtr] False
212 , exfun "__gmp_set_memory_functions" VoidType
213 [ PointerType (FunctionType ptrI8 [intPtr] False) (AddrSpace 0)
214 , PointerType (FunctionType ptrI8 [ptrI8, intPtr, intPtr] False) (AddrSpace 0)
215 , PointerType (FunctionType VoidType [ptrI8, intPtr] False) (AddrSpace 0)
216 ] False
217 , exfun "__gmpz_init" VoidType [pmpz] False
218 , exfun "__gmpz_init_set_str" (IntegerType 32) [pmpz, ptrI8, IntegerType 32] False
219 , exfun "__gmpz_get_str" ptrI8 [ptrI8, IntegerType 32, pmpz] False
220 , exfun "__gmpz_get_ui" intPtr [pmpz] False
221 , exfun "__gmpz_cmp" (IntegerType 32) [pmpz, pmpz] False
222 , exfun "__gmpz_fdiv_q_2exp" VoidType [pmpz, pmpz, intPtr] False
223 , exfun "__gmpz_mul_2exp" VoidType [pmpz, pmpz, intPtr] False
224 , exfun "__gmpz_get_d" (FloatingPointType 64 IEEE) [pmpz] False
225 , exfun "__gmpz_set_d" VoidType [pmpz, FloatingPointType 64 IEEE] False
226 , exfun "mpz_get_ull" (IntegerType 64) [pmpz] False
227 , exfun "mpz_init_set_ull" VoidType [pmpz, IntegerType 64] False
228 , exfun "mpz_init_set_sll" VoidType [pmpz, IntegerType 64] False
229 , exfun "__idris_strCons" ptrI8 [IntegerType 8, ptrI8] False
230 , exfun "__idris_readStr" ptrI8 [ptrI8] False -- Actually pointer to FILE, but it's opaque anyway
231 , exfun "__idris_gmpMalloc" ptrI8 [intPtr] False
232 , exfun "__idris_gmpRealloc" ptrI8 [ptrI8, intPtr, intPtr] False
233 , exfun "__idris_gmpFree" VoidType [ptrI8, intPtr] False
234 , exfun "__idris_strRev" ptrI8 [ptrI8] False
235 , exfun "strtoll" (IntegerType 64) [ptrI8, PointerType ptrI8 (AddrSpace 0), IntegerType 32] False
236 , exfun "putErr" VoidType [ptrI8] False
237 , exVar (stdinName tgt) ptrI8
238 , exVar (stdoutName tgt) ptrI8
239 , exVar (stderrName tgt) ptrI8
240 , exVar "__idris_argc" (IntegerType 32)
241 , exVar "__idris_argv" (PointerType ptrI8 (AddrSpace 0))
242 , GlobalDefinition mainDef
243 ] ++ map mpzBinFun ["add", "sub", "mul", "fdiv_q", "fdiv_r", "and", "ior", "xor"]
244 where
245 intPtr = IntegerType (tgtWordSize tgt)
246 ptrI8 = PointerType (IntegerType 8) (AddrSpace 0)
247 pmpz = PointerType mpzTy (AddrSpace 0)
249 mpzBinFun n = exfun ("__gmpz_" ++ n) VoidType [pmpz, pmpz, pmpz] False
251 rtsFun :: String -> Type -> [Type] -> [BasicBlock] -> Definition
252 rtsFun name rty argtys def =
253 GlobalDefinition $ functionDefaults
254 { G.linkage = L.Internal
255 , G.returnType = rty
256 , G.parameters = (flip map argtys $ \ty -> Parameter ty (UnName 0) [], False)
257 , G.name = Name $ "__idris_" ++ name
258 , G.basicBlocks = def
259 }
261 exfun :: String -> Type -> [Type] -> Bool -> Definition
262 exfun name rty argtys vari =
263 GlobalDefinition $ functionDefaults
264 { G.returnType = rty
265 , G.name = Name name
266 , G.parameters = (flip map argtys $ \ty -> Parameter ty (UnName 0) [], vari)
267 }
268 exVar :: String -> Type -> Definition
269 exVar name ty = GlobalDefinition $ globalVariableDefaults { G.name = Name name, G.type' = ty }
271isApple :: Target -> Bool
272isApple (Target { triple = t }) = isJust . stripPrefix "-apple" $ dropWhile (/= '-') t
274stdinName, stdoutName, stderrName :: Target -> String
275stdinName t | isApple t = "__stdinp"
276stdinName _ = "stdin"
277stdoutName t | isApple t = "__stdoutp"
278stdoutName _ = "stdout"
279stderrName t | isApple t = "__stderrp"
280stderrName _ = "stderr"
282getStdIn, getStdOut, getStdErr :: Codegen Operand
283getStdIn = ConstantOperand . C.GlobalReference . Name . stdinName <$> asks target
284getStdOut = ConstantOperand . C.GlobalReference . Name . stdoutName <$> asks target
285getStdErr = ConstantOperand . C.GlobalReference . Name . stderrName <$> asks target
287codegen :: Target -> [SDecl] -> Module
288codegen tgt defs = Module "idris" (Just . dataLayout $ tgt) (Just . triple $ tgt) (initDefs tgt ++ globals ++ gendefs)
289 where
290 (gendefs, _, globals) = runRWS (mapM cgDef defs) tgt initialMGS
292valueType :: Type
293valueType = NamedTypeReference (Name "valTy")
295nullValue :: C.Constant
296nullValue = C.Null (PointerType valueType (AddrSpace 0))
298primTy :: Type -> Type
299primTy inner = StructureType False [IntegerType 32, inner]
301mpzTy :: Type
302mpzTy = NamedTypeReference (Name "mpz")
304conType :: Word64 -> Type
305conType nargs = StructureType False
306 [ IntegerType 32
307 , ArrayType nargs (PointerType valueType (AddrSpace 0))
308 ]
310data MGS = MGS { mgsNextGlobalName :: Word
311 , mgsForeignSyms :: Map String (FType, [FType])
312 }
314type Modgen = RWS Target [Definition] MGS
316initialMGS :: MGS
317initialMGS = MGS { mgsNextGlobalName = 0
318 , mgsForeignSyms = M.empty
319 }
321cgDef :: SDecl -> Modgen Definition
322cgDef (SFun name argNames _ expr) = do
323 nextGlobal <- gets mgsNextGlobalName
324 existingForeignSyms <- gets mgsForeignSyms
325 tgt <- ask
326 let (_, CGS { nextGlobalName = nextGlobal', foreignSyms = foreignSyms' }, (allocas, bbs, globals)) =
327 runRWS (do r <- cgExpr expr
328 case r of
329 Nothing -> terminate $ Unreachable []
330 Just r' -> terminate $ Ret (Just r') [])
331 (CGR tgt (show name))
332 (CGS 0 nextGlobal (Name "begin") [] (map (Just . LocalReference . Name . show) argNames) existingForeignSyms)
333 entryTerm = case bbs of
334 [] -> Do $ Ret Nothing []
335 BasicBlock n _ _:_ -> Do $ Br n []
336 tell globals
337 put (MGS { mgsNextGlobalName = nextGlobal', mgsForeignSyms = foreignSyms' })
338 return . GlobalDefinition $ functionDefaults
339 { G.linkage = L.Internal
340 , G.callingConvention = CC.Fast
341 , G.name = Name (show name)
342 , G.returnType = PointerType valueType (AddrSpace 0)
343 , G.parameters = (flip map argNames $ \argName ->
344 Parameter (PointerType valueType (AddrSpace 0)) (Name (show argName)) []
345 , False)
346 , G.basicBlocks =
347 BasicBlock (Name "entry")
348 (map (\(n, t) -> n := Alloca t Nothing 0 []) allocas)
349 entryTerm
350 : bbs
351 }
353type CGW = ([(Name, Type)], [BasicBlock], [Definition])
355type Env = [Maybe Operand]
357data CGS = CGS { nextName :: Word
358 , nextGlobalName :: Word
359 , currentBlockName :: Name
360 , instAccum :: [Named Instruction]
361 , lexenv :: Env
362 , foreignSyms :: Map String (FType, [FType])
363 }
365data CGR = CGR { target :: Target
366 , funcName :: String }
368type Codegen = RWS CGR CGW CGS
370getFuncName :: Codegen String
371getFuncName = asks funcName
373getGlobalUnName :: Codegen Name
374getGlobalUnName = do
375 i <- gets nextGlobalName
376 modify $ \s -> s { nextGlobalName = 1 + i }
377 return (UnName i)
379getUnName :: Codegen Name
380getUnName = do
381 i <- gets nextName
382 modify $ \s -> s { nextName = 1 + i }
383 return (UnName i)
385getName :: String -> Codegen Name
386getName n = do
387 i <- gets nextName
388 modify $ \s -> s { nextName = 1 + i }
389 return (Name $ n ++ show i)
391alloca :: Name -> Type -> Codegen ()
392alloca n t = tell ([(n, t)], [], [])
394terminate :: Terminator -> Codegen ()
395terminate term = do
396 name <- gets currentBlockName
397 insts <- gets instAccum
398 modify $ \s -> s { instAccum = ierror "Not in a block"
399 , currentBlockName = ierror "Not in a block" }
400 tell ([], [BasicBlock name insts (Do term)], [])
402newBlock :: Name -> Codegen ()
403newBlock name = modify $ \s -> s { instAccum = []
404 , currentBlockName = name
405 }
407inst :: Instruction -> Codegen Operand
408inst i = do
409 n <- getUnName
410 modify $ \s -> s { instAccum = instAccum s ++ [n := i] }
411 return $ LocalReference n
413ninst :: String -> Instruction -> Codegen Operand
414ninst name i = do
415 n <- getName name
416 modify $ \s -> s { instAccum = instAccum s ++ [n := i] }
417 return $ LocalReference n
419inst' :: Instruction -> Codegen ()
420inst' i = modify $ \s -> s { instAccum = instAccum s ++ [Do i] }
422insts :: [Named Instruction] -> Codegen ()
423insts is = modify $ \s -> s { instAccum = instAccum s ++ is }
425var :: LVar -> Codegen (Maybe Operand)
426var (Loc level) = (!! level) <$> gets lexenv
427var (Glob n) = return . Just . ConstantOperand . C.GlobalReference . Name $ show n
429binds :: Env -> Codegen (Maybe Operand) -> Codegen (Maybe Operand)
430binds vals cg = do
431 envLen <- length <$> gets lexenv
432 modify $ \s -> s { lexenv = lexenv s ++ vals }
433 value <- cg
434 modify $ \s -> s { lexenv = take envLen $ lexenv s }
435 return value
437replaceElt :: Int -> a -> [a] -> [a]
438replaceElt _ val [] = error "replaceElt: Ran out of list"
439replaceElt 0 val (x:xs) = val:xs
440replaceElt n val (x:xs) = x : replaceElt (n-1) val xs
442alloc' :: Operand -> Codegen Operand
443alloc' size = inst $ simpleCall "GC_malloc" [size]
445allocAtomic' :: Operand -> Codegen Operand
446allocAtomic' size = inst $ simpleCall "GC_malloc_atomic" [size]
448alloc :: Type -> Codegen Operand
449alloc ty = do
450 size <- sizeOf ty
451 mem <- alloc' size
452 inst $ BitCast mem (PointerType ty (AddrSpace 0)) []
454allocAtomic :: Type -> Codegen Operand
455allocAtomic ty = do
456 size <- sizeOf ty
457 mem <- allocAtomic' size
458 inst $ BitCast mem (PointerType ty (AddrSpace 0)) []
460sizeOf :: Type -> Codegen Operand
461sizeOf ty = ConstantOperand . C.PtrToInt
462 (C.GetElementPtr True (C.Null (PointerType ty (AddrSpace 0))) [C.Int 32 1])
463 . IntegerType <$> getWordSize
465loadInv :: Operand -> Instruction
466loadInv ptr = Load False ptr Nothing 0 [("invariant.load", MetadataNode [])]
468tgtWordSize :: Target -> Word32
469tgtWordSize (Target { dataLayout = DataLayout { pointerLayouts = l } }) =
470 fst . fromJust $ M.lookup (AddrSpace 0) l
472getWordSize :: Codegen Word32
473getWordSize = tgtWordSize <$> asks target
475cgExpr :: SExp -> Codegen (Maybe Operand)
476cgExpr (SV v) = var v
477cgExpr (SApp tailcall fname args) = do
478 argSlots <- mapM var args
479 case sequence argSlots of
480 Nothing -> return Nothing
481 Just argVals -> do
482 fn <- var (Glob fname)
483 Just <$> inst ((idrCall (show fname) argVals) { isTailCall = tailcall })
484cgExpr (SLet _ varExpr bodyExpr) = do
485 val <- cgExpr varExpr
486 binds [val] $ cgExpr bodyExpr
487cgExpr (SUpdate (Loc level) expr) = do
488 val <- cgExpr expr
489 modify $ \s -> s { lexenv = replaceElt level val (lexenv s) }
490 return val
491cgExpr (SUpdate x expr) = cgExpr expr
492cgExpr (SCon tag name args) = do
493 argSlots <- mapM var args
494 case sequence argSlots of
495 Nothing -> return Nothing
496 Just argVals -> do
497 let ty = conType . fromIntegral . length $ argVals
498 con <- alloc ty
499 tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []
500 inst' $ Store False tagPtr (ConstantOperand (C.Int 32 (fromIntegral tag))) Nothing 0 []
501 forM_ (zip argVals [0..]) $ \(arg, i) -> do
502 ptr <- inst $ GetElementPtr True con [ ConstantOperand (C.Int 32 0)
503 , ConstantOperand (C.Int 32 1)
504 , ConstantOperand (C.Int 32 i)] []
505 inst' $ Store False ptr arg Nothing 0 []
506 ptrI8 <- inst $ BitCast con (PointerType (IntegerType 8) (AddrSpace 0)) []
507 inst' $ simpleCall "llvm.invariant.start" [ConstantOperand $ C.Int 64 (-1), ptrI8]
508 Just <$> inst (BitCast con (PointerType valueType (AddrSpace 0)) [])
509cgExpr (SCase inspect alts) = do
510 val <- var inspect
511 case val of
512 Nothing -> return Nothing
513 Just v -> cgCase v alts
514cgExpr (SChkCase inspect alts) = do
515 mval <- var inspect
516 case mval of
517 Nothing -> return Nothing
518 Just val ->
519 do endBBN <- getName "endChkCase"
520 notNullBBN <- getName "notNull"
521 originBlock <- gets currentBlockName
522 isNull <- inst $ ICmp IPred.EQ val (ConstantOperand nullValue) []
523 terminate $ CondBr isNull endBBN notNullBBN []
524 newBlock notNullBBN
525 ptr <- inst $ BitCast val (PointerType (IntegerType 32) (AddrSpace 0)) []
526 flag <- inst $ loadInv ptr
527 isVal <- inst $ ICmp IPred.EQ flag (ConstantOperand (C.Int 32 (-1))) []
528 conBBN <- getName "constructor"
529 terminate $ CondBr isVal endBBN conBBN []
530 newBlock conBBN
531 result <- cgCase val alts
532 caseExitBlock <- gets currentBlockName
533 case result of
534 Nothing -> do
535 terminate $ Unreachable []
536 newBlock endBBN
537 return $ Just val
538 Just caseVal -> do
539 terminate $ Br endBBN []
540 newBlock endBBN
541 Just <$> inst (Phi (PointerType valueType (AddrSpace 0))
542 [(val, originBlock), (val, notNullBBN), (caseVal, caseExitBlock)] [])
543cgExpr (SProj conVar idx) = do
544 val <- var conVar
545 case val of
546 Nothing -> return Nothing
547 Just v ->
548 do ptr <- inst $ GetElementPtr True v
549 [ ConstantOperand (C.Int 32 0)
550 , ConstantOperand (C.Int 32 1)
551 , ConstantOperand (C.Int 32 (fromIntegral idx))
552 ] []
553 Just <$> inst (loadInv ptr)
554cgExpr (SConst c) = Just <$> cgConst c
555cgExpr (SForeign LANG_C rty fname args) = do
556 func <- ensureCDecl fname rty (map fst args)
557 argVals <- forM args $ \(fty, v) -> do
558 v' <- var v
559 case v' of
560 Just val -> return $ Just (fty, val)
561 Nothing -> return Nothing
562 case sequence argVals of
563 Nothing -> return Nothing
564 Just argVals' -> do
565 argUVals <- mapM (uncurry unbox) argVals'
566 result <- inst Call { isTailCall = False
567 , callingConvention = CC.C
568 , returnAttributes = []
569 , function = Right func
570 , arguments = map (\v -> (v, [])) argUVals
571 , functionAttributes = []
572 , metadata = []
573 }
574 Just <$> box rty result
575cgExpr (SOp fn args) = do
576 argVals <- mapM var args
577 case sequence argVals of
578 Just ops -> Just <$> cgOp fn ops
579 Nothing -> return Nothing
580cgExpr SNothing = return . Just . ConstantOperand $ nullValue
581cgExpr (SError msg) = do
582 str <- addGlobal' (ArrayType (2 + fromIntegral (length msg)) (IntegerType 8))
583 (cgConst' (TT.Str (msg ++ "\n")))
584 inst' $ simpleCall "putErr" [ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0
585 , C.Int 32 0]]
586 inst' Call { isTailCall = True
587 , callingConvention = CC.C
588 , returnAttributes = []
589 , function = Right . ConstantOperand . C.GlobalReference . Name $ "llvm.trap"
590 , arguments = []
591 , functionAttributes = [A.NoReturn]
592 , metadata = []
593 }
594 return Nothing
596cgCase :: Operand -> [SAlt] -> Codegen (Maybe Operand)
597cgCase val alts =
598 case find isConstCase alts of
599 Just (SConstCase (TT.BI _) _) -> cgChainCase val defExp constAlts
600 Just (SConstCase (TT.Str _) _) -> cgChainCase val defExp constAlts
601 Just (SConstCase _ _) -> cgPrimCase val defExp constAlts
602 Nothing -> cgConCase val defExp conAlts
603 where
604 defExp = getDefExp =<< find isDefCase alts
605 constAlts = filter isConstCase alts
606 conAlts = filter isConCase alts
608 isConstCase (SConstCase {}) = True
609 isConstCase _ = False
611 isConCase (SConCase {}) = True
612 isConCase _ = False
614 isDefCase (SDefaultCase _) = True
615 isDefCase _ = False
617 getDefExp (SDefaultCase e) = Just e
618 getDefExp _ = Nothing
620cgPrimCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
621cgPrimCase caseValPtr defExp alts = do
622 let caseTy = case head alts of
623 SConstCase (TT.I _) _ -> IntegerType 32
624 SConstCase (TT.B8 _) _ -> IntegerType 8
625 SConstCase (TT.B16 _) _ -> IntegerType 16
626 SConstCase (TT.B32 _) _ -> IntegerType 32
627 SConstCase (TT.B64 _) _ -> IntegerType 64
628 SConstCase (TT.Fl _) _ -> FloatingPointType 64 IEEE
629 SConstCase (TT.Ch _) _ -> IntegerType 32
630 realPtr <- inst $ BitCast caseValPtr (PointerType (primTy caseTy) (AddrSpace 0)) []
631 valPtr <- inst $ GetElementPtr True realPtr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
632 caseVal <- inst $ loadInv valPtr
633 defBlockName <- getName "default"
634 exitBlockName <- getName "caseExit"
635 namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
636 terminate $ Switch caseVal defBlockName (map (\(n, SConstCase c _) -> (cgConst' c, n)) namedAlts) []
637 initEnv <- gets lexenv
638 defResult <- cgDefaultAlt exitBlockName defBlockName defExp
639 results <- forM namedAlts $ \(name, SConstCase _ exp) -> cgAlt initEnv exitBlockName name Nothing exp
640 finishCase initEnv exitBlockName (defResult:results)
642cgConCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
643cgConCase con defExp alts = do
644 tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []
645 tag <- inst $ loadInv tagPtr
646 defBlockName <- getName "default"
647 exitBlockName <- getName "caseExit"
648 namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
649 terminate $ Switch tag defBlockName (map (\(n, SConCase _ tag _ _ _) ->
650 (C.Int 32 (fromIntegral tag), n)) namedAlts) []
651 initEnv <- gets lexenv
652 defResult <- cgDefaultAlt exitBlockName defBlockName defExp
653 results <- forM namedAlts $ \(name, SConCase _ _ _ argns exp) ->
654 cgAlt initEnv exitBlockName name (Just (con, map show argns)) exp
655 finishCase initEnv exitBlockName (defResult:results)
657cgChainCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
658cgChainCase caseValPtr defExp alts = do
659 let (caseTy, comparator) =
660 case head alts of
661 SConstCase (TT.BI _) _ -> (FArith (ATInt ITBig), "__gmpz_cmp")
662 SConstCase (TT.Str _) _ -> (FString, "strcmp")
663 caseVal <- unbox caseTy caseValPtr
664 defBlockName <- getName "default"
665 exitBlockName <- getName "caseExit"
666 namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
667 initEnv <- gets lexenv
668 results <- forM namedAlts $ \(name, SConstCase c e) ->
669 do const <- unbox caseTy =<< cgConst c
670 cmp <- inst $ simpleCall comparator [const, caseVal]
671 cmpResult <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) []
672 elseName <- getName "else"
673 terminate $ CondBr cmpResult name elseName []
674 result <- cgAlt initEnv exitBlockName name Nothing e
675 newBlock elseName
676 return result
677 modify $ \s -> s { lexenv = initEnv }
678 fname <- getFuncName
679 defaultVal <- cgExpr (fromMaybe (SError $ "Inexhaustive case failure in " ++ fname) defExp)
680 defaultBlock <- gets currentBlockName
681 defaultEnv <- gets lexenv
682 defResult <- case defaultVal of
683 Just v -> do
684 terminate $ Br exitBlockName []
685 return $ Just (v, defaultBlock, defaultEnv)
686 Nothing -> do
687 terminate $ Unreachable []
688 return Nothing
689 finishCase initEnv exitBlockName (defResult:results)
691finishCase :: Env -> Name -> [Maybe (Operand, Name, Env)] -> Codegen (Maybe Operand)
692finishCase initEnv exitBlockName results = do
693 let definedResults = mapMaybe id results
694 case definedResults of
695 [] -> do modify $ \s -> s { lexenv = initEnv }
696 return Nothing
697 xs -> do
698 newBlock exitBlockName
699 mergeEnvs $ map (\(_, altBlock, altEnv) -> (altBlock, altEnv)) xs
700 Just <$> inst (Phi (PointerType valueType (AddrSpace 0))
701 (map (\(altVal, altBlock, _) -> (altVal, altBlock)) xs) [])
704cgDefaultAlt :: Name -> Name -> Maybe SExp -> Codegen (Maybe (Operand, Name, Env))
705cgDefaultAlt exitName name exp = do
706 newBlock name
707 fname <- getFuncName
708 val <- cgExpr (fromMaybe (SError $ "Inexhaustive case failure in " ++ fname) exp)
709 env <- gets lexenv
710 block <- gets currentBlockName
711 case val of
712 Just v ->
713 do terminate $ Br exitName []
714 return $ Just (v, block, env)
715 Nothing ->
716 do terminate $ Unreachable []
717 return Nothing
719cgAlt :: Env -> Name -> Name -> Maybe (Operand, [String]) -> SExp
720 -> Codegen (Maybe (Operand, Name, Env))
721cgAlt initEnv exitBlockName name destr exp = do
722 modify $ \s -> s { lexenv = initEnv }
723 newBlock name
724 locals <- case destr of
725 Nothing -> return []
726 Just (con, argns) ->
727 forM (zip argns [0..]) $ \(argName, i) ->
728 do ptr <- inst $ GetElementPtr True con [ ConstantOperand (C.Int 32 0)
729 , ConstantOperand (C.Int 32 1)
730 , ConstantOperand (C.Int 32 i)] []
731 Just <$> ninst argName (loadInv ptr)
732 altVal <- binds locals $ cgExpr exp
733 altEnv <- gets lexenv
734 altBlock <- gets currentBlockName
735 case altVal of
736 Just v -> do
737 terminate $ Br exitBlockName []
738 return $ Just (v, altBlock, altEnv)
739 Nothing -> do
740 terminate $ Unreachable []
741 return Nothing
743mergeEnvs :: [(Name, Env)] -> Codegen ()
744mergeEnvs es = do
745 let vars = transpose
746 . map (\(block, env) -> map (\x -> (x, block)) env)
747 $ es
748 env <- forM vars $ \var ->
749 case var of
750 [] -> ierror "mergeEnvs: impossible"
751 [(v, _)] -> return v
752 vs@((v, _):_)
753 | all (== v) (map fst vs) -> return v
754 | otherwise ->
755 let valid = map (\(a, b) -> (fromJust a, b)) . filter (isJust . fst) $ vs in
756 Just <$> inst (Phi (PointerType valueType (AddrSpace 0)) valid [])
757 modify $ \s -> s { lexenv = env }
759nameAlt :: Name -> SAlt -> Codegen Name
760nameAlt d (SDefaultCase _) = return d
761nameAlt _ (SConCase _ _ name _ _) = getName (show name)
762nameAlt _ (SConstCase const _) = getName (show const)
764isHeapFTy :: FType -> Bool
765isHeapFTy f = elem f [FString, FPtr, FAny, FArith (ATInt ITBig)]
767box :: FType -> Operand -> Codegen Operand
768box FUnit _ = return $ ConstantOperand nullValue
769box fty fval = do
770 let ty = primTy (ftyToTy fty)
771 val <- if isHeapFTy fty then alloc ty else allocAtomic ty
772 tagptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []
773 valptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
774 inst' $ Store False tagptr (ConstantOperand (C.Int 32 (-1))) Nothing 0 []
775 inst' $ Store False valptr fval Nothing 0 []
776 ptrI8 <- inst $ BitCast val (PointerType (IntegerType 8) (AddrSpace 0)) []
777 inst' $ simpleCall "llvm.invariant.start" [ConstantOperand $ C.Int 64 (-1), ptrI8]
778 inst $ BitCast val (PointerType valueType (AddrSpace 0)) []
780unbox :: FType -> Operand -> Codegen Operand
781unbox FUnit x = return x
782unbox fty bval = do
783 val <- inst $ BitCast bval (PointerType (primTy (ftyToTy fty)) (AddrSpace 0)) []
784 fvalptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
785 inst $ loadInv fvalptr
787cgConst' :: TT.Const -> C.Constant
788cgConst' (TT.I i) = C.Int 32 (fromIntegral i)
789cgConst' (TT.B8 i) = C.Int 8 (fromIntegral i)
790cgConst' (TT.B16 i) = C.Int 16 (fromIntegral i)
791cgConst' (TT.B32 i) = C.Int 32 (fromIntegral i)
792cgConst' (TT.B64 i) = C.Int 64 (fromIntegral i)
793cgConst' (TT.B8V v) = C.Vector (map ((C.Int 8) . fromIntegral) . V.toList $ v)
794cgConst' (TT.B16V v) = C.Vector (map ((C.Int 16) . fromIntegral) . V.toList $ v)
795cgConst' (TT.B32V v) = C.Vector (map ((C.Int 32) . fromIntegral) . V.toList $ v)
796cgConst' (TT.B64V v) = C.Vector (map ((C.Int 64) . fromIntegral) . V.toList $ v)
798cgConst' (TT.BI i) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) (show i) ++ [C.Int 8 0])
799cgConst' (TT.Fl f) = C.Float (F.Double f)
800cgConst' (TT.Ch c) = C.Int 32 . fromIntegral . fromEnum $ c
801cgConst' (TT.Str s) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) s ++ [C.Int 8 0])
802cgConst' x = ierror $ "Unsupported constant: " ++ show x
804cgConst :: TT.Const -> Codegen Operand
805cgConst c@(TT.I _) = box (FArith (ATInt ITNative)) (ConstantOperand $ cgConst' c)
806cgConst c@(TT.B8 _) = box (FArith (ATInt (ITFixed IT8))) (ConstantOperand $ cgConst' c)
807cgConst c@(TT.B16 _) = box (FArith (ATInt (ITFixed IT16))) (ConstantOperand $ cgConst' c)
808cgConst c@(TT.B32 _) = box (FArith (ATInt (ITFixed IT32))) (ConstantOperand $ cgConst' c)
809cgConst c@(TT.B64 _) = box (FArith (ATInt (ITFixed IT64))) (ConstantOperand $ cgConst' c)
810cgConst c@(TT.B8V v) = box (FArith (ATInt (ITVec IT8 (V.length v)))) (ConstantOperand $ cgConst' c)
811cgConst c@(TT.B16V v) = box (FArith (ATInt (ITVec IT16 (V.length v)))) (ConstantOperand $ cgConst' c)
812cgConst c@(TT.B32V v) = box (FArith (ATInt (ITVec IT32 (V.length v)))) (ConstantOperand $ cgConst' c)
813cgConst c@(TT.B64V v) = box (FArith (ATInt (ITVec IT64 (V.length v)))) (ConstantOperand $ cgConst' c)
814cgConst c@(TT.Fl _) = box (FArith ATFloat) (ConstantOperand $ cgConst' c)
815cgConst c@(TT.Ch _) = box (FArith (ATInt ITChar)) (ConstantOperand $ cgConst' c)
816cgConst c@(TT.Str s) = do
817 str <- addGlobal' (ArrayType (1 + fromIntegral (length s)) (IntegerType 8)) (cgConst' c)
818 box FString (ConstantOperand $ C.GetElementPtr True str [C.Int 32 0, C.Int 32 0])
819cgConst c@(TT.BI i) = do
820 let stringRepLen = (if i < 0 then 2 else 1) + fromInteger (numDigits 10 i)
821 str <- addGlobal' (ArrayType stringRepLen (IntegerType 8)) (cgConst' c)
822 mpz <- alloc mpzTy
823 inst $ simpleCall "__gmpz_init_set_str" [mpz
824 , ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0, C.Int 32 0]
825 , ConstantOperand $ C.Int 32 10
826 ]
827 box (FArith (ATInt ITBig)) mpz
828cgConst x = return $ ConstantOperand nullValue
830numDigits :: Integer -> Integer -> Integer
831numDigits b n = 1 + fst (ilog b n) where
832 ilog b n
833 | n < b = (0, n)
834 | otherwise = let (e, r) = ilog (b*b) n
835 in if r < b then (2*e, r) else (2*e+1, r `div` b)
837addGlobal :: Global -> Codegen ()
838addGlobal def = tell ([], [], [GlobalDefinition def])
840addGlobal' :: Type -> C.Constant -> Codegen C.Constant
841addGlobal' ty val = do
842 name <- getGlobalUnName
843 addGlobal $ globalVariableDefaults
844 { G.name = name
845 , G.linkage = L.Internal
846 , G.hasUnnamedAddr = True
847 , G.isConstant = True
848 , G.type' = ty
849 , G.initializer = Just val
850 }
851 return . C.GlobalReference $ name
854ensureCDecl :: String -> FType -> [FType] -> Codegen Operand
855ensureCDecl name rty argtys = do
856 syms <- gets foreignSyms
857 case M.lookup name syms of
858 Nothing -> do addGlobal (ffunDecl name rty argtys)
859 modify $ \s -> s { foreignSyms = M.insert name (rty, argtys) (foreignSyms s) }
860 Just (rty', argtys') -> unless (rty == rty' && argtys == argtys') . fail $
861 "Mismatched type declarations for foreign symbol \"" ++ name ++ "\": " ++ show (rty, argtys) ++ " vs " ++ show (rty', argtys')
862 return $ ConstantOperand (C.GlobalReference (Name name))
864ffunDecl :: String -> FType -> [FType] -> Global
865ffunDecl name rty argtys =
866 functionDefaults
867 { G.returnType = ftyToTy rty
868 , G.name = Name name
869 , G.parameters = (flip map argtys $ \fty ->
870 Parameter (ftyToTy fty) (UnName 0) []
871 , False)
872 }
874ftyToTy :: FType -> Type
875ftyToTy (FArith (ATInt ITNative)) = IntegerType 32
876ftyToTy (FArith (ATInt ITBig)) = PointerType mpzTy (AddrSpace 0)
877ftyToTy (FArith (ATInt (ITFixed ty))) = IntegerType (fromIntegral $ nativeTyWidth ty)
878ftyToTy (FArith (ATInt (ITVec e c)))
879 = VectorType (fromIntegral c) (IntegerType (fromIntegral $ nativeTyWidth e))
880ftyToTy (FArith (ATInt ITChar)) = IntegerType 32
881ftyToTy (FArith ATFloat) = FloatingPointType 64 IEEE
882ftyToTy FString = PointerType (IntegerType 8) (AddrSpace 0)
883ftyToTy FUnit = VoidType
884ftyToTy FPtr = PointerType (IntegerType 8) (AddrSpace 0)
885ftyToTy FAny = valueType
887-- Only use when known not to be ITBig
888itWidth :: IntTy -> Word32
889itWidth ITNative = 32
890itWidth ITChar = 32
891itWidth (ITFixed x) = fromIntegral $ nativeTyWidth x
892itWidth x = ierror $ "itWidth: " ++ show x
894itConst :: IntTy -> Integer -> C.Constant
895itConst (ITFixed n) x = C.Int (fromIntegral $ nativeTyWidth n) x
896itConst ITNative x = itConst (ITFixed IT32) x
897itConst ITChar x = itConst (ITFixed IT32) x
898itConst (ITVec elts size) x = C.Vector (replicate size (itConst (ITFixed elts) x))
900cgOp :: PrimFn -> [Operand] -> Codegen Operand
901cgOp (LTrunc ITBig ity) [x] = do
902 nx <- unbox (FArith (ATInt ITBig)) x
903 val <- inst $ simpleCall "mpz_get_ull" [nx]
904 v <- case ity of
905 (ITFixed IT64) -> return val
906 _ -> inst $ Trunc val (ftyToTy (FArith (ATInt ity))) []
907 box (FArith (ATInt ity)) v
908cgOp (LZExt from ITBig) [x] = do
909 nx <- unbox (FArith (ATInt from)) x
910 nx' <- case from of
911 (ITFixed IT64) -> return nx
912 _ -> inst $ ZExt nx (IntegerType 64) []
913 mpz <- alloc mpzTy
914 inst' $ simpleCall "mpz_init_set_ull" [mpz, nx']
915 box (FArith (ATInt ITBig)) mpz
916cgOp (LSExt from ITBig) [x] = do
917 nx <- unbox (FArith (ATInt from)) x
918 nx' <- case from of
919 (ITFixed IT64) -> return nx
920 _ -> inst $ SExt nx (IntegerType 64) []
921 mpz <- alloc mpzTy
922 inst' $ simpleCall "mpz_init_set_sll" [mpz, nx']
923 box (FArith (ATInt ITBig)) mpz
925-- ITChar, ITNative, and IT32 all share representation
926cgOp (LChInt ITNative) [x] = return x
927cgOp (LIntCh ITNative) [x] = return x
929cgOp (LSLt (ATInt ITBig)) [x,y] = mpzCmp IPred.SLT x y
930cgOp (LSLe (ATInt ITBig)) [x,y] = mpzCmp IPred.SLE x y
931cgOp (LEq (ATInt ITBig)) [x,y] = mpzCmp IPred.EQ x y
932cgOp (LSGe (ATInt ITBig)) [x,y] = mpzCmp IPred.SGE x y
933cgOp (LSGt (ATInt ITBig)) [x,y] = mpzCmp IPred.SGT x y
934cgOp (LPlus (ATInt ITBig)) [x,y] = mpzBin "add" x y
935cgOp (LMinus (ATInt ITBig)) [x,y] = mpzBin "sub" x y
936cgOp (LTimes (ATInt ITBig)) [x,y] = mpzBin "mul" x y
937cgOp (LSDiv (ATInt ITBig)) [x,y] = mpzBin "fdiv_q" x y
938cgOp (LSRem (ATInt ITBig)) [x,y] = mpzBin "fdiv_r" x y
939cgOp (LAnd ITBig) [x,y] = mpzBin "and" x y
940cgOp (LOr ITBig) [x,y] = mpzBin "ior" x y
941cgOp (LXOr ITBig) [x,y] = mpzBin "xor" x y
942cgOp (LCompl ITBig) [x] = mpzUn "com" x
943cgOp (LSHL ITBig) [x,y] = mpzBit "mul_2exp" x y
944cgOp (LASHR ITBig) [x,y] = mpzBit "fdiv_q_2exp" x y
946cgOp (LTrunc ITNative (ITFixed to)) [x]
947 | 32 >= nativeTyWidth to = iCoerce Trunc IT32 to x
948cgOp (LZExt ITNative (ITFixed to)) [x]
949 | 32 <= nativeTyWidth to = iCoerce ZExt IT32 to x
950cgOp (LSExt ITNative (ITFixed to)) [x]
951 | 32 <= nativeTyWidth to = iCoerce SExt IT32 to x
953cgOp (LTrunc (ITFixed from) ITNative) [x]
954 | nativeTyWidth from >= 32 = iCoerce Trunc from IT32 x
955cgOp (LZExt (ITFixed from) ITNative) [x]
956 | nativeTyWidth from <= 32 = iCoerce ZExt from IT32 x
957cgOp (LSExt (ITFixed from) ITNative) [x]
958 | nativeTyWidth from <= 32 = iCoerce SExt from IT32 x
960cgOp (LTrunc (ITFixed from) (ITFixed to)) [x]
961 | nativeTyWidth from > nativeTyWidth to = iCoerce Trunc from to x
962cgOp (LZExt (ITFixed from) (ITFixed to)) [x]
963 | nativeTyWidth from < nativeTyWidth to = iCoerce ZExt from to x
964cgOp (LSExt (ITFixed from) (ITFixed to)) [x]
965 | nativeTyWidth from < nativeTyWidth to = iCoerce SExt from to x
967cgOp (LSLt (ATInt ity)) [x,y] = iCmp ity IPred.SLT x y
968cgOp (LSLe (ATInt ity)) [x,y] = iCmp ity IPred.SLE x y
969cgOp (LLt ity) [x,y] = iCmp ity IPred.ULT x y
970cgOp (LLe ity) [x,y] = iCmp ity IPred.ULE x y
971cgOp (LEq (ATInt ity)) [x,y] = iCmp ity IPred.EQ x y
972cgOp (LSGe (ATInt ity)) [x,y] = iCmp ity IPred.SGE x y
973cgOp (LSGt (ATInt ity)) [x,y] = iCmp ity IPred.SGT x y
974cgOp (LGe ity) [x,y] = iCmp ity IPred.UGE x y
975cgOp (LGt ity) [x,y] = iCmp ity IPred.UGT x y
976cgOp (LPlus ty@(ATInt _)) [x,y] = binary ty x y (Add False False)
977cgOp (LMinus ty@(ATInt _)) [x,y] = binary ty x y (Sub False False)
978cgOp (LTimes ty@(ATInt _)) [x,y] = binary ty x y (Mul False False)
979cgOp (LSDiv ty@(ATInt _)) [x,y] = binary ty x y (SDiv False)
980cgOp (LSRem ty@(ATInt _)) [x,y] = binary ty x y SRem
981cgOp (LUDiv ity) [x,y] = binary (ATInt ity) x y (UDiv False)
982cgOp (LURem ity) [x,y] = binary (ATInt ity) x y URem
983cgOp (LAnd ity) [x,y] = binary (ATInt ity) x y And
984cgOp (LOr ity) [x,y] = binary (ATInt ity) x y Or
985cgOp (LXOr ity) [x,y] = binary (ATInt ity) x y Xor
986cgOp (LCompl ity) [x] = unary (ATInt ity) x (Xor . ConstantOperand $ itConst ity (-1))
987cgOp (LSHL ity) [x,y] = binary (ATInt ity) x y (Shl False False)
988cgOp (LLSHR ity) [x,y] = binary (ATInt ity) x y (LShr False)
989cgOp (LASHR ity) [x,y] = binary (ATInt ity) x y (AShr False)
991cgOp (LSLt ATFloat) [x,y] = fCmp FPred.OLT x y
992cgOp (LSLe ATFloat) [x,y] = fCmp FPred.OLE x y
993cgOp (LEq ATFloat) [x,y] = fCmp FPred.OEQ x y
994cgOp (LSGe ATFloat) [x,y] = fCmp FPred.OGE x y
995cgOp (LSGt ATFloat) [x,y] = fCmp FPred.OGT x y
996cgOp (LPlus ATFloat) [x,y] = binary ATFloat x y FAdd
997cgOp (LMinus ATFloat) [x,y] = binary ATFloat x y FSub
998cgOp (LTimes ATFloat) [x,y] = binary ATFloat x y FMul
999cgOp (LSDiv ATFloat) [x,y] = binary ATFloat x y FDiv
1001cgOp LFExp [x] = nunary ATFloat "llvm.exp.f64" x
1002cgOp LFLog [x] = nunary ATFloat "llvm.log.f64" x
1003cgOp LFSin [x] = nunary ATFloat "llvm.sin.f64" x
1004cgOp LFCos [x] = nunary ATFloat "llvm.cos.f64" x
1005cgOp LFTan [x] = nunary ATFloat "tan" x
1006cgOp LFASin [x] = nunary ATFloat "asin" x
1007cgOp LFACos [x] = nunary ATFloat "acos" x
1008cgOp LFATan [x] = nunary ATFloat "atan" x
1009cgOp LFSqrt [x] = nunary ATFloat "llvm.sqrt.f64" x
1010cgOp LFFloor [x] = nunary ATFloat "llvm.floor.f64" x
1011cgOp LFCeil [x] = nunary ATFloat "llvm.ceil.f64" x
1013cgOp (LIntFloat ITBig) [x] = do
1014 x' <- unbox (FArith (ATInt ITBig)) x
1015 uflt <- inst $ simpleCall "__gmpz_get_d" [ x' ]
1016 box (FArith ATFloat) uflt
1018cgOp (LIntFloat ity) [x] = do
1019 x' <- unbox (FArith (ATInt ity)) x
1020 x'' <- inst $ SIToFP x' (FloatingPointType 64 IEEE) []
1021 box (FArith ATFloat) x''
1023cgOp (LFloatInt ITBig) [x] = do
1024 x' <- unbox (FArith ATFloat) x
1025 z <- alloc mpzTy
1026 inst' $ simpleCall "__gmpz_init" [z]
1027 inst' $ simpleCall "__gmpz_set_d" [ z, x' ]
1028 box (FArith (ATInt ITBig)) z
1030cgOp (LFloatInt ity) [x] = do
1031 x' <- unbox (FArith ATFloat) x
1032 x'' <- inst $ FPToSI x' (ftyToTy $ cmpResultTy ity) []
1033 box (FArith (ATInt ity)) x''
1035cgOp LFloatStr [x] = do
1036 x' <- unbox (FArith ATFloat) x
1037 ustr <- inst (idrCall "__idris_floatStr" [x'])
1038 box FString ustr
1040cgOp LNoOp xs = return $ last xs
1042cgOp (LMkVec ety c) xs | c == length xs = do
1043 nxs <- mapM (unbox (FArith (ATInt (ITFixed ety)))) xs
1044 vec <- foldM (\v (e, i) -> inst $ InsertElement v e (ConstantOperand (C.Int 32 i)) [])
1045 (ConstantOperand $ C.Vector (replicate c (C.Undef (IntegerType . fromIntegral $ nativeTyWidth ety))))
1046 (zip nxs [0..])
1047 box (FArith (ATInt (ITVec ety c))) vec
1049cgOp (LIdxVec ety c) [v,i] = do
1050 nv <- unbox (FArith (ATInt (ITVec ety c))) v
1051 ni <- unbox (FArith (ATInt (ITFixed IT32))) i
1052 elt <- inst $ ExtractElement nv ni []
1053 box (FArith (ATInt (ITFixed ety))) elt
1055cgOp (LUpdateVec ety c) [v,i,e] = do
1056 let fty = FArith (ATInt (ITVec ety c))
1057 nv <- unbox fty v
1058 ni <- unbox (FArith (ATInt (ITFixed IT32))) i
1059 ne <- unbox (FArith (ATInt (ITFixed ety))) e
1060 nv' <- inst $ InsertElement nv ne ni []
1061 box fty nv'
1063cgOp (LBitCast from to) [x] = do
1064 nx <- unbox (FArith from) x
1065 nx' <- inst $ BitCast nx (ftyToTy (FArith to)) []
1066 box (FArith to) nx'
1068cgOp LStrEq [x,y] = do
1069 x' <- unbox FString x
1070 y' <- unbox FString y
1071 cmp <- inst $ simpleCall "strcmp" [x', y']
1072 flag <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) []
1073 val <- inst $ ZExt flag (IntegerType 32) []
1074 box (FArith (ATInt (ITFixed IT32))) val
1076cgOp LStrLt [x,y] = do
1077 nx <- unbox FString x
1078 ny <- unbox FString y
1079 cmp <- inst $ simpleCall "strcmp" [nx, ny]
1080 flag <- inst $ ICmp IPred.ULT cmp (ConstantOperand (C.Int 32 0)) []
1081 val <- inst $ ZExt flag (IntegerType 32) []
1082 box (FArith (ATInt (ITFixed IT32))) val
1084cgOp (LIntStr ITBig) [x] = do
1085 x' <- unbox (FArith (ATInt ITBig)) x
1086 ustr <- inst $ simpleCall "__gmpz_get_str"
1087 [ ConstantOperand (C.Null (PointerType (IntegerType 8) (AddrSpace 0)))
1088 , ConstantOperand (C.Int 32 10)
1089 , x'
1091 box FString ustr
1092cgOp (LIntStr ity) [x] = do
1093 x' <- unbox (FArith (ATInt ity)) x
1094 x'' <- if itWidth ity < 64
1095 then inst $ SExt x' (IntegerType 64) []
1096 else return x'
1097 box FString =<< inst (idrCall "__idris_intStr" [x''])
1098cgOp (LStrInt ITBig) [s] = do
1099 ns <- unbox FString s
1100 mpz <- alloc mpzTy
1101 inst $ simpleCall "__gmpz_init_set_str" [mpz, ns, ConstantOperand $ C.Int 32 10]
1102 box (FArith (ATInt ITBig)) mpz
1103cgOp (LStrInt ity) [s] = do
1104 ns <- unbox FString s
1105 nx <- inst $ simpleCall "strtoll"
1106 [ns
1107 , ConstantOperand $ C.Null (PointerType (PointerType (IntegerType 8) (AddrSpace 0)) (AddrSpace 0))
1108 , ConstantOperand $ C.Int 32 10
1110 nx' <- case ity of
1111 (ITFixed IT64) -> return nx
1112 _ -> inst $ Trunc nx (IntegerType (itWidth ity)) []
1113 box (FArith (ATInt ity)) nx'
1115cgOp LStrConcat [x,y] = cgStrCat x y
1117cgOp LStrCons [c,s] = do
1118 nc <- unbox (FArith (ATInt ITChar)) c
1119 ns <- unbox FString s
1120 nc' <- inst $ Trunc nc (IntegerType 8) []
1121 r <- inst $ simpleCall "__idris_strCons" [nc', ns]
1122 box FString r
1124cgOp LStrHead [c] = do
1125 s <- unbox FString c
1126 c <- inst $ loadInv s
1127 c' <- inst $ ZExt c (IntegerType 32) []
1128 box (FArith (ATInt ITChar)) c'
1130cgOp LStrIndex [s, i] = do
1131 ns <- unbox FString s
1132 ni <- unbox (FArith (ATInt (ITFixed IT32))) i
1133 p <- inst $ GetElementPtr True ns [ni] []
1134 c <- inst $ loadInv p
1135 c' <- inst $ ZExt c (IntegerType 32) []
1136 box (FArith (ATInt ITChar)) c'
1138cgOp LStrTail [c] = do
1139 s <- unbox FString c
1140 c <- inst $ GetElementPtr True s [ConstantOperand $ C.Int 32 1] []
1141 box FString c
1143cgOp LStrLen [s] = do
1144 ns <- unbox FString s
1145 len <- inst $ simpleCall "strlen" [ns]
1146 ws <- getWordSize
1147 len' <- case ws of
1148 32 -> return len
1149 x | x > 32 -> inst $ Trunc len (IntegerType 32) []
1150 | x < 32 -> inst $ ZExt len (IntegerType 32) []
1151 box (FArith (ATInt (ITFixed IT32))) len'
1153cgOp LStrRev [s] = do
1154 ns <- unbox FString s
1155 box FString =<< inst (simpleCall "__idris_strRev" [ns])
1157cgOp LReadStr [p] = do
1158 np <- unbox FPtr p
1159 s <- inst $ simpleCall "__idris_readStr" [np]
1160 box FString s
1162cgOp LStdIn [] = do
1163 stdin <- getStdIn
1164 ptr <- inst $ loadInv stdin
1165 box FPtr ptr
1166cgOp LStdOut [] = do
1167 stdout <- getStdOut
1168 ptr <- inst $ loadInv stdout
1169 box FPtr ptr
1170cgOp LStdErr [] = do
1171 stdErr <- getStdErr
1172 ptr <- inst $ loadInv stdErr
1173 box FPtr ptr
1175cgOp prim args = ierror $ "Unimplemented primitive: <" ++ show prim ++ ">("
1176 ++ intersperse ',' (take (length args) ['a'..]) ++ ")"
1178iCoerce :: (Operand -> Type -> InstructionMetadata -> Instruction) -> NativeTy -> NativeTy -> Operand -> Codegen Operand
1179iCoerce _ from to x | from == to = return x
1180iCoerce operator from to x = do
1181 x' <- unbox (FArith (ATInt (ITFixed from))) x
1182 x'' <- inst $ operator x' (ftyToTy (FArith (ATInt (ITFixed to)))) []
1183 box (FArith (ATInt (ITFixed to))) x''
1185cgStrCat :: Operand -> Operand -> Codegen Operand
1186cgStrCat x y = do
1187 x' <- unbox FString x
1188 y' <- unbox FString y
1189 xlen <- inst $ simpleCall "strlen" [x']
1190 ylen <- inst $ simpleCall "strlen" [y']
1191 zlen <- inst $ Add False True xlen ylen []
1192 ws <- getWordSize
1193 total <- inst $ Add False True zlen (ConstantOperand (C.Int ws 1)) []
1194 mem <- allocAtomic' total
1195 inst $ simpleCall "memcpy" [mem, x', xlen]
1196 i <- inst $ PtrToInt mem (IntegerType ws) []
1197 offi <- inst $ Add False True i xlen []
1198 offp <- inst $ IntToPtr offi (PointerType (IntegerType 8) (AddrSpace 0)) []
1199 inst $ simpleCall "memcpy" [offp, y', ylen]
1200 j <- inst $ PtrToInt offp (IntegerType ws) []
1201 offj <- inst $ Add False True j ylen []
1202 end <- inst $ IntToPtr offj (PointerType (IntegerType 8) (AddrSpace 0)) []
1203 inst' $ Store False end (ConstantOperand (C.Int 8 0)) Nothing 0 []
1204 box FString mem
1206binary :: ArithTy -> Operand -> Operand
1207 -> (Operand -> Operand -> InstructionMetadata -> Instruction) -> Codegen Operand
1208binary ty x y instCon = do
1209 nx <- unbox (FArith ty) x
1210 ny <- unbox (FArith ty) y
1211 nr <- inst $ instCon nx ny []
1212 box (FArith ty) nr
1214unary :: ArithTy -> Operand
1215 -> (Operand -> InstructionMetadata -> Instruction) -> Codegen Operand
1216unary ty x instCon = do
1217 nx <- unbox (FArith ty) x
1218 nr <- inst $ instCon nx []
1219 box (FArith ty) nr
1221nunary :: ArithTy -> String
1222 -> Operand -> Codegen Operand
1223nunary ty name x = do
1224 nx <- unbox (FArith ty) x
1225 nr <- inst $ simpleCall name [nx]
1226 box (FArith ty) nr
1228iCmp :: IntTy -> IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand
1229iCmp ity pred x y = do
1230 nx <- unbox (FArith (ATInt ity)) x
1231 ny <- unbox (FArith (ATInt ity)) y
1232 nr <- inst $ ICmp pred nx ny []
1233 nr' <- inst $ SExt nr (ftyToTy $ cmpResultTy ity) []
1234 box (cmpResultTy ity) nr'
1236fCmp :: FPred.FloatingPointPredicate -> Operand -> Operand -> Codegen Operand
1237fCmp pred x y = do
1238 nx <- unbox (FArith ATFloat) x
1239 ny <- unbox (FArith ATFloat) y
1240 nr <- inst $ FCmp pred nx ny []
1241 box (FArith (ATInt (ITFixed IT32))) nr
1243cmpResultTy :: IntTy -> FType
1244cmpResultTy v@(ITVec _ _) = FArith (ATInt v)
1245cmpResultTy _ = FArith (ATInt (ITFixed IT32))
1247mpzBin :: String -> Operand -> Operand -> Codegen Operand
1248mpzBin name x y = do
1249 nx <- unbox (FArith (ATInt ITBig)) x
1250 ny <- unbox (FArith (ATInt ITBig)) y
1251 nz <- alloc mpzTy
1252 inst' $ simpleCall "__gmpz_init" [nz]
1253 inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx, ny]
1254 box (FArith (ATInt ITBig)) nz
1256mpzBit :: String -> Operand -> Operand -> Codegen Operand
1257mpzBit name x y = do
1258 nx <- unbox (FArith (ATInt ITBig)) x
1259 ny <- unbox (FArith (ATInt ITBig)) y
1260 bitcnt <- inst $ simpleCall "__gmpz_get_ui" [ny]
1261 nz <- alloc mpzTy
1262 inst' $ simpleCall "__gmpz_init" [nz]
1263 inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx, bitcnt]
1264 box (FArith (ATInt ITBig)) nz
1266mpzUn :: String -> Operand -> Codegen Operand
1267mpzUn name x = do
1268 nx <- unbox (FArith (ATInt ITBig)) x
1269 nz <- alloc mpzTy
1270 inst' $ simpleCall "__gmpz_init" [nz]
1271 inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx]
1272 box (FArith (ATInt ITBig)) nz
1274mpzCmp :: IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand
1275mpzCmp pred x y = do
1276 nx <- unbox (FArith (ATInt ITBig)) x
1277 ny <- unbox (FArith (ATInt ITBig)) y
1278 cmp <- inst $ simpleCall "__gmpz_cmp" [nx, ny]
1279 result <- inst $ ICmp pred cmp (ConstantOperand (C.Int 32 0)) []
1280 i <- inst $ ZExt result (IntegerType 32) []
1281 box (FArith (ATInt (ITFixed IT32))) i
1283simpleCall :: String -> [Operand] -> Instruction
1284simpleCall name args =
1285 Call { isTailCall = False
1286 , callingConvention = CC.C
1287 , returnAttributes = []
1288 , function = Right . ConstantOperand . C.GlobalReference . Name $ name
1289 , arguments = map (\x -> (x, [])) args
1290 , functionAttributes = []
1291 , metadata = []
1294idrCall :: String -> [Operand] -> Instruction
1295idrCall name args =
1296 Call { isTailCall = False
1297 , callingConvention = CC.Fast
1298 , returnAttributes = []
1299 , function = Right . ConstantOperand . C.GlobalReference . Name $ name
1300 , arguments = map (\x -> (x, [])) args
1301 , functionAttributes = []
1302 , metadata = []
1305assert :: Operand -> String -> Codegen ()
1306assert condition message = do
1307 passed <- getName "assertPassed"
1308 failed <- getName "assertFailed"
1309 terminate $ CondBr condition passed failed []
1310 newBlock failed
1311 cgExpr (SError message)
1312 terminate $ Unreachable []
1313 newBlock passed