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