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