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