git.iko.soy/Idris-dev
on 7ebf672 help sign in
Idris-dev/src/IRTS/CodegenLLVM.hs
1068 lines 42 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
9import Util.System
10import Paths_idris
12import LLVM.General.Context
13import LLVM.General.Diagnostic
14import LLVM.General.AST
15import LLVM.General.AST.AddrSpace
16import LLVM.General.Target
17import LLVM.General.AST.DataLayout
18import LLVM.General.PassManager
19import qualified LLVM.General.Module as M
20import qualified LLVM.General.AST.IntegerPredicate as IPred
21import qualified LLVM.General.AST.Linkage as L
22import qualified LLVM.General.AST.Visibility as V
23import qualified LLVM.General.AST.CallingConvention as CC
24import qualified LLVM.General.AST.Attribute as A
25import qualified LLVM.General.AST.Global as G
26import qualified LLVM.General.AST.Constant as C
27import qualified LLVM.General.AST.Float as F
28import qualified LLVM.General.Relocation as R
29import qualified LLVM.General.CodeModel as CM
30import qualified LLVM.General.CodeGenOpt as CGO
32import Data.List
33import Data.Maybe
34import Data.Word
35import Data.Set (Set)
36import qualified Data.Set as S
37import qualified Data.Map as M
38import Control.Applicative
39import Control.Monad.RWS
40import Control.Monad.Writer
41import Control.Monad.State
42import Control.Monad.Error
44import qualified System.Info as SI (arch, os)
45import System.IO
46import System.Directory (removeFile)
47import System.FilePath ((</>))
48import System.Process (rawSystem)
49import System.Exit (ExitCode(..))
50import Debug.Trace
52data Target = Target { triple :: String, dataLayout :: DataLayout }
54codegenLLVM :: [(TT.Name, SDecl)] ->
55 FilePath -> -- output file name
56 OutputType ->
57 IO ()
58codegenLLVM defs file outty = withContext $ \context -> do
59 triple <- getDefaultTargetTriple
60 cpu <- getHostCPUName
61 features <- getHostCPUFeatures
62 initializeAllTargets
63 (target, _) <- failInIO $ lookupTarget Nothing triple
64 withTargetOptions $ \options ->
65 withTargetMachine target triple cpu features options R.Default CM.Default CGO.Default $ \tm ->
66 do layout <- getTargetMachineDataLayout tm
67 let ast = codegen (Target triple layout) (map snd defs)
68 result <- runErrorT . M.withModuleFromAST context ast $ \m ->
69 do let opts = defaultCuratedPassSetSpec
70 { optLevel = Just 3
71 , simplifyLibCalls = Just True
72 , useInlinerWithThreshold = Just 225
73 }
74 withPassManager opts $ \pm -> runPassManager pm m
75 outputModule tm file outty m
76 case result of
77 Right _ -> return ()
78 Left msg -> ierror msg
80failInIO :: ErrorT String IO a -> IO a
81failInIO = either fail return <=< runErrorT
83itWidth :: IntTy -> Word32
84itWidth ITNative = 32
85itWidth x = fromIntegral $ intTyWidth x
87outputModule :: TargetMachine -> FilePath -> OutputType -> M.Module -> IO ()
88outputModule _ file Raw m = failInIO $ M.writeBitcodeToFile file m
89outputModule tm file Object m = failInIO $ M.writeObjectToFile tm file m
90outputModule tm file Executable m = withTmpFile $ \obj -> do
91 outputModule tm obj Object m
92 cc <- getCC
93 defs <- (</> "llvm" </> "libidris_rts.a") <$> getDataDir
94 exit <- rawSystem cc [obj, defs, "-lm", "-lgmp", "-lgc", "-o", file]
95 when (exit /= ExitSuccess) $ ierror "FAILURE: Linking"
97withTmpFile :: (FilePath -> IO a) -> IO a
98withTmpFile f = do
99 (path, handle) <- tempfile
100 hClose handle
101 result <- f path
102 removeFile path
103 return result
105ierror :: String -> a
106ierror msg = error $ "INTERNAL ERROR: IRTS.CodegenLLVM: " ++ msg
108mainDef :: Global
109mainDef =
110 functionDefaults
111 { G.returnType = IntegerType 32
112 , G.parameters =
113 ([ Parameter (IntegerType 32) (Name "argc") []
114 , Parameter (PointerType (PointerType (IntegerType 8) (AddrSpace 0)) (AddrSpace 0)) (Name "argv") []
115 ], False)
116 , G.name = Name "main"
117 , G.basicBlocks =
118 [ BasicBlock (UnName 0)
119 [ Do $ simpleCall "GC_init" [] -- Initialize Boehm GC
120 , Do $ simpleCall "__gmp_set_memory_functions"
121 [ ConstantOperand . C.GlobalReference . Name $ "__idris_gmpMalloc"
122 , ConstantOperand . C.GlobalReference . Name $ "__idris_gmpRealloc"
123 , ConstantOperand . C.GlobalReference . Name $ "__idris_gmpFree"
124 ]
125 , UnName 1 := idrCall "{runMain0}" [] ]
126 (Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [])
127 ]}
129initDefs :: Target -> [Definition]
130initDefs tgt =
131 [ TypeDefinition (Name "valTy")
132 (Just $ StructureType False
133 [ IntegerType 32
134 , ArrayType 0 (PointerType valueType (AddrSpace 0))
135 ])
136 , TypeDefinition (Name "mpz")
137 (Just $ StructureType False
138 [ IntegerType 32
139 , IntegerType 32
140 , PointerType intPtr (AddrSpace 0)
141 ])
142 , GlobalDefinition $ globalVariableDefaults
143 { G.name = Name "__idris_intFmtStr"
144 , G.linkage = L.Internal
145 , G.isConstant = True
146 , G.hasUnnamedAddr = True
147 , G.type' = ArrayType 5 (IntegerType 8)
148 , G.initializer = Just $ C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) "%lld" ++ [C.Int 8 0])
149 }
150 , rtsFun "intStr" ptrI8 [IntegerType 64]
151 [ BasicBlock (UnName 0)
152 [ UnName 1 := simpleCall "GC_malloc_atomic" [ConstantOperand (C.Int (tgtWordSize tgt) 21)]
153 , UnName 2 := simpleCall "snprintf"
154 [ LocalReference (UnName 1)
155 , ConstantOperand (C.Int (tgtWordSize tgt) 21)
156 , ConstantOperand $ C.GetElementPtr True (C.GlobalReference . Name $ "__idris_intFmtStr") [C.Int 32 0, C.Int 32 0]
157 , LocalReference (UnName 0)
158 ]
159 ]
160 (Do $ Ret (Just (LocalReference (UnName 1))) [])
161 ]
162 , exfun "llvm.trap" VoidType [] False
163 , exfun "snprintf" (IntegerType 32) [ptrI8, intPtr, ptrI8] True
164 , exfun "strcmp" (IntegerType 32) [ptrI8, ptrI8] False
165 , exfun "strlen" intPtr [ptrI8] False
166 , exfun "memcpy" ptrI8 [ptrI8, ptrI8, intPtr] False
167 , exfun "GC_init" VoidType [] False
168 , exfun "GC_malloc" ptrI8 [intPtr] False
169 , exfun "GC_malloc_atomic" ptrI8 [intPtr] False
170 , exfun "__gmp_set_memory_functions" VoidType
171 [ PointerType (FunctionType ptrI8 [intPtr] False) (AddrSpace 0)
172 , PointerType (FunctionType ptrI8 [ptrI8, intPtr, intPtr] False) (AddrSpace 0)
173 , PointerType (FunctionType VoidType [ptrI8, intPtr] False) (AddrSpace 0)
174 ] False
175 , exfun "__gmpz_init" VoidType [pmpz] False
176 , exfun "__gmpz_init_set_str" (IntegerType 32) [pmpz, ptrI8, IntegerType 32] False
177 , exfun "__gmpz_get_str" ptrI8 [ptrI8, IntegerType 32, pmpz] False
178 , exfun "__gmpz_cmp" (IntegerType 32) [pmpz, pmpz] False
179 , exfun "mpz_get_ull" (IntegerType 64) [pmpz] False
180 , exfun "mpz_init_set_ull" VoidType [pmpz, IntegerType 64] False
181 , exfun "mpz_init_set_sll" VoidType [pmpz, IntegerType 64] False
182 , exfun "__idris_strCons" ptrI8 [IntegerType 8, ptrI8] False
183 , exfun "__idris_readStr" ptrI8 [ptrI8] False -- Actually pointer to FILE, but it's opaque anyway
184 , exfun "__idris_gmpMalloc" ptrI8 [intPtr] False
185 , exfun "__idris_gmpRealloc" ptrI8 [ptrI8, intPtr, intPtr] False
186 , exfun "__idris_gmpFree" VoidType [ptrI8, intPtr] False
187 , exfun "strtoll" (IntegerType 64) [ptrI8, PointerType ptrI8 (AddrSpace 0), IntegerType 32] False
188 , exVar (stdinName tgt) ptrI8
189 , exVar (stdoutName tgt) ptrI8
190 , exVar (stderrName tgt) ptrI8
191 , GlobalDefinition mainDef
192 ] ++ map mpzBinFun ["add", "sub", "mul", "fdiv_q", "fdiv_r", "and", "ior", "xor"]
193 where
194 intPtr = IntegerType (tgtWordSize tgt)
195 ptrI8 = PointerType (IntegerType 8) (AddrSpace 0)
196 pmpz = PointerType mpzTy (AddrSpace 0)
198 mpzBinFun n = exfun ("__gmpz_" ++ n) VoidType [pmpz, pmpz, pmpz] False
200 rtsFun :: String -> Type -> [Type] -> [BasicBlock] -> Definition
201 rtsFun name rty argtys def =
202 GlobalDefinition $ functionDefaults
203 { G.linkage = L.Internal
204 , G.returnType = rty
205 , G.parameters = (flip map argtys $ \ty -> Parameter ty (UnName 0) [], False)
206 , G.name = Name $ "__idris_" ++ name
207 , G.basicBlocks = def
208 }
210 exfun :: String -> Type -> [Type] -> Bool -> Definition
211 exfun name rty argtys vari =
212 GlobalDefinition $ functionDefaults
213 { G.returnType = rty
214 , G.name = Name name
215 , G.parameters = (flip map argtys $ \ty -> Parameter ty (UnName 0) [], vari)
216 }
217 exVar :: String -> Type -> Definition
218 exVar name ty = GlobalDefinition $ globalVariableDefaults { G.name = Name name, G.type' = ty }
220isApple :: Target -> Bool
221isApple (Target { triple = t }) = isJust . stripPrefix "-apple" $ dropWhile (/= '-') t
223stdinName, stdoutName, stderrName :: Target -> String
224stdinName t | isApple t = "__stdinp"
225stdinName _ = "stdin"
226stdoutName t | isApple t = "__stdoutp"
227stdoutName _ = "stdout"
228stderrName t | isApple t = "__stderrp"
229stderrName _ = "stderr"
231getStdIn, getStdOut, getStdErr :: Codegen Operand
232getStdIn = ConstantOperand . C.GlobalReference . Name . stdinName <$> asks target
233getStdOut = ConstantOperand . C.GlobalReference . Name . stdoutName <$> asks target
234getStdErr = ConstantOperand . C.GlobalReference . Name . stderrName <$> asks target
236codegen :: Target -> [SDecl] -> Module
237codegen tgt defs = Module "idris" (Just . dataLayout $ tgt) Nothing (initDefs tgt ++ globals ++ gendefs)
238 where
239 (gendefs, _, globals) = runRWS (mapM cgDef defs) tgt 0
241valueType :: Type
242valueType = NamedTypeReference (Name "valTy")
244nullValue :: C.Constant
245nullValue = C.Null (PointerType valueType (AddrSpace 0))
247primTy :: Type -> Type
248primTy inner = StructureType False [IntegerType 32, inner]
250mpzTy :: Type
251mpzTy = NamedTypeReference (Name "mpz")
253conType :: Word64 -> Type
254conType nargs = StructureType False
255 [ IntegerType 32
256 , ArrayType nargs (PointerType valueType (AddrSpace 0))
257 ]
259type Modgen = RWS Target [Definition] Word
261cgDef :: SDecl -> Modgen Definition
262cgDef (SFun name argNames _ expr) = do
263 nextGlobal <- get
264 tgt <- ask
265 let (_, CGS { nextGlobalName = nextGlobal' }, (allocas, bbs, globals)) =
266 runRWS (do r <- cgExpr expr
267 case r of
268 Nothing -> terminate $ Unreachable []
269 Just r' -> terminate $ Ret (Just r') [])
270 (CGR tgt (show name))
271 (CGS 0 nextGlobal (Name "begin") [] (map (Just . LocalReference . Name . show) argNames) S.empty)
272 entryTerm = case bbs of
273 [] -> Do $ Ret Nothing []
274 BasicBlock n _ _:_ -> Do $ Br n []
275 tell globals
276 put nextGlobal'
277 return . GlobalDefinition $ functionDefaults
278 { G.linkage = L.Internal
279 , G.callingConvention = CC.Fast
280 , G.name = Name (show name)
281 , G.returnType = PointerType valueType (AddrSpace 0)
282 , G.parameters = (flip map argNames $ \argName ->
283 Parameter (PointerType valueType (AddrSpace 0)) (Name (show argName)) []
284 , False)
285 , G.basicBlocks =
286 BasicBlock (Name "entry")
287 (map (\(n, t) -> n := Alloca t Nothing 0 []) allocas)
288 entryTerm
289 : bbs
290 }
292type CGW = ([(Name, Type)], [BasicBlock], [Definition])
294type Env = [Maybe Operand]
296data CGS = CGS { nextName :: Word
297 , nextGlobalName :: Word
298 , currentBlockName :: Name
299 , instAccum :: [Named Instruction]
300 , lexenv :: Env
301 , foreignSyms :: Set String
302 }
304data CGR = CGR { target :: Target
305 , funcName :: String }
307type Codegen = RWS CGR CGW CGS
309getFuncName :: Codegen String
310getFuncName = asks funcName
312getGlobalUnName :: Codegen Name
313getGlobalUnName = do
314 i <- gets nextGlobalName
315 modify $ \s -> s { nextGlobalName = 1 + i }
316 return (UnName i)
318getUnName :: Codegen Name
319getUnName = do
320 i <- gets nextName
321 modify $ \s -> s { nextName = 1 + i }
322 return (UnName i)
324getName :: String -> Codegen Name
325getName n = do
326 i <- gets nextName
327 modify $ \s -> s { nextName = 1 + i }
328 return (Name $ n ++ show i)
330alloca :: Name -> Type -> Codegen ()
331alloca n t = tell ([(n, t)], [], [])
333terminate :: Terminator -> Codegen ()
334terminate term = do
335 name <- gets currentBlockName
336 insts <- gets instAccum
337 modify $ \s -> s { instAccum = ierror "Not in a block"
338 , currentBlockName = ierror "Not in a block" }
339 tell ([], [BasicBlock name insts (Do term)], [])
341newBlock :: Name -> Codegen ()
342newBlock name = modify $ \s -> s { instAccum = []
343 , currentBlockName = name
344 }
346inst :: Instruction -> Codegen Operand
347inst i = do
348 n <- getUnName
349 modify $ \s -> s { instAccum = instAccum s ++ [n := i] }
350 return $ LocalReference n
352ninst :: String -> Instruction -> Codegen Operand
353ninst name i = do
354 n <- getName name
355 modify $ \s -> s { instAccum = instAccum s ++ [n := i] }
356 return $ LocalReference n
358inst' :: Instruction -> Codegen ()
359inst' i = modify $ \s -> s { instAccum = instAccum s ++ [Do i] }
361insts :: [Named Instruction] -> Codegen ()
362insts is = modify $ \s -> s { instAccum = instAccum s ++ is }
364var :: LVar -> Codegen (Maybe Operand)
365var (Loc level) = (!! level) <$> gets lexenv
366var (Glob n) = return . Just . ConstantOperand . C.GlobalReference . Name $ show n
368binds :: Env -> Codegen (Maybe Operand) -> Codegen (Maybe Operand)
369binds vals cg = do
370 envLen <- length <$> gets lexenv
371 modify $ \s -> s { lexenv = lexenv s ++ vals }
372 value <- cg
373 modify $ \s -> s { lexenv = take envLen $ lexenv s }
374 return value
376replaceElt :: Int -> a -> [a] -> [a]
377replaceElt _ val [] = error "replaceElt: Ran out of list"
378replaceElt 0 val (x:xs) = val:xs
379replaceElt n val (x:xs) = x : replaceElt (n-1) val xs
381alloc' :: Operand -> Codegen Operand
382alloc' size = inst $ simpleCall "GC_malloc" [size]
384allocAtomic :: Operand -> Codegen Operand
385allocAtomic size = inst $ simpleCall "GC_malloc_atomic" [size]
387alloc :: Type -> Codegen Operand
388alloc ty = do
389 size <- sizeOf ty
390 mem <- alloc' size
391 inst $ BitCast mem (PointerType ty (AddrSpace 0)) []
393sizeOf :: Type -> Codegen Operand
394sizeOf ty = ConstantOperand . C.PtrToInt
395 (C.GetElementPtr True (C.Null (PointerType ty (AddrSpace 0))) [C.Int 32 1])
396 . IntegerType <$> getWordSize
398tgtWordSize :: Target -> Word32
399tgtWordSize (Target { dataLayout = DataLayout { pointerLayouts = l } }) =
400 fst . fromJust $ M.lookup (AddrSpace 0) l
402getWordSize :: Codegen Word32
403getWordSize = tgtWordSize <$> asks target
405cgExpr :: SExp -> Codegen (Maybe Operand)
406cgExpr (SV v) = var v
407cgExpr (SApp tailcall fname args) = do
408 argSlots <- mapM var args
409 case sequence argSlots of
410 Nothing -> return Nothing
411 Just argVals -> do
412 fn <- var (Glob fname)
413 Just <$> inst ((idrCall (show fname) argVals) { isTailCall = tailcall })
414cgExpr (SLet _ varExpr bodyExpr) = do
415 val <- cgExpr varExpr
416 binds [val] $ cgExpr bodyExpr
417cgExpr (SUpdate (Loc level) expr) = do
418 val <- cgExpr expr
419 modify $ \s -> s { lexenv = replaceElt level val (lexenv s) }
420 return val
421cgExpr (SCon tag name args) = do
422 argSlots <- mapM var args
423 case sequence argSlots of
424 Nothing -> return Nothing
425 Just argVals -> do
426 con <- alloc . conType . fromIntegral . length $ argVals
427 tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []
428 inst' $ Store False tagPtr (ConstantOperand (C.Int 32 (fromIntegral tag))) Nothing 0 []
429 forM_ (zip argVals [0..]) $ \(arg, i) -> do
430 ptr <- inst $ GetElementPtr True con [ ConstantOperand (C.Int 32 0)
431 , ConstantOperand (C.Int 32 1)
432 , ConstantOperand (C.Int 32 i)] []
433 inst' $ Store False ptr arg Nothing 0 []
434 Just <$> inst (BitCast con (PointerType valueType (AddrSpace 0)) [])
435cgExpr (SCase inspect alts) = do
436 val <- var inspect
437 case val of
438 Nothing -> return Nothing
439 Just v -> cgCase v alts
440cgExpr (SChkCase inspect alts) = do
441 mval <- var inspect
442 case mval of
443 Nothing -> return Nothing
444 Just val ->
445 do endBBN <- getName "endChkCase"
446 notNullBBN <- getName "notNull"
447 originBlock <- gets currentBlockName
448 isNull <- inst $ ICmp IPred.EQ val (ConstantOperand nullValue) []
449 terminate $ CondBr isNull endBBN notNullBBN []
450 newBlock notNullBBN
451 ptr <- inst $ BitCast val (PointerType (IntegerType 32) (AddrSpace 0)) []
452 flag <- inst $ Load False ptr Nothing 0 []
453 isVal <- inst $ ICmp IPred.EQ flag (ConstantOperand (C.Int 32 (-1))) []
454 conBBN <- getName "constructor"
455 terminate $ CondBr isVal endBBN conBBN []
456 newBlock conBBN
457 result <- cgCase val alts
458 caseExitBlock <- gets currentBlockName
459 case result of
460 Nothing -> do
461 terminate $ Unreachable []
462 newBlock endBBN
463 return $ Just val
464 Just caseVal -> do
465 terminate $ Br endBBN []
466 newBlock endBBN
467 Just <$> inst (Phi (PointerType valueType (AddrSpace 0))
468 [(val, originBlock), (val, notNullBBN), (caseVal, caseExitBlock)] [])
469cgExpr (SProj conVar idx) = do
470 val <- var conVar
471 case val of
472 Nothing -> return Nothing
473 Just v ->
474 do ptr <- inst $ GetElementPtr True v
475 [ ConstantOperand (C.Int 32 0)
476 , ConstantOperand (C.Int 32 1)
477 , ConstantOperand (C.Int 32 (fromIntegral idx))
478 ] []
479 Just <$> inst (Load False ptr Nothing 0 [])
480cgExpr (SConst c) = Just <$> cgConst c
481cgExpr (SForeign LANG_C rty fname args) = do
482 func <- ensureCDecl fname rty (map fst args)
483 argVals <- forM args $ \(fty, v) -> do
484 v' <- var v
485 case v' of
486 Just val -> return $ Just (fty, val)
487 Nothing -> return Nothing
488 case sequence argVals of
489 Nothing -> return Nothing
490 Just argVals' -> do
491 argUVals <- mapM (uncurry unbox) argVals'
492 result <- inst Call { isTailCall = False
493 , callingConvention = CC.C
494 , returnAttributes = []
495 , function = Right func
496 , arguments = map (\v -> (v, [])) argUVals
497 , functionAttributes = []
498 , metadata = []
499 }
500 Just <$> box rty result
501cgExpr (SOp fn args) = do
502 argVals <- mapM var args
503 case sequence argVals of
504 Just ops -> Just <$> cgOp fn ops
505 Nothing -> return Nothing
506cgExpr SNothing = return . Just . ConstantOperand $ nullValue
507cgExpr (SError msg) = do -- TODO: Print message
508 str <- addGlobal' (ArrayType (2 + fromIntegral (length msg)) (IntegerType 8))
509 (cgConst' (TT.Str (msg ++ "\n")))
510 inst' $ simpleCall "putStr" [ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0
511 , C.Int 32 0]]
512 inst' Call { isTailCall = True
513 , callingConvention = CC.C
514 , returnAttributes = []
515 , function = Right . ConstantOperand . C.GlobalReference . Name $ "llvm.trap"
516 , arguments = []
517 , functionAttributes = [A.NoReturn]
518 , metadata = []
519 }
520 return Nothing
522cgCase :: Operand -> [SAlt] -> Codegen (Maybe Operand)
523cgCase val alts =
524 case find isConstCase alts of
525 Just (SConstCase (TT.BI _) _) -> cgChainCase val defExp constAlts
526 Just (SConstCase (TT.Str _) _) -> cgChainCase val defExp constAlts
527 Just (SConstCase _ _) -> cgPrimCase val defExp constAlts
528 Nothing -> cgConCase val defExp conAlts
529 where
530 defExp = getDefExp =<< find isDefCase alts
531 constAlts = filter isConstCase alts
532 conAlts = filter isConCase alts
534 isConstCase (SConstCase {}) = True
535 isConstCase _ = False
537 isConCase (SConCase {}) = True
538 isConCase _ = False
540 isDefCase (SDefaultCase _) = True
541 isDefCase _ = False
543 getDefExp (SDefaultCase e) = Just e
544 getDefExp _ = Nothing
546cgPrimCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
547cgPrimCase caseValPtr defExp alts = do
548 let caseTy = case head alts of
549 SConstCase (TT.I _) _ -> IntegerType 32
550 SConstCase (TT.B8 _) _ -> IntegerType 8
551 SConstCase (TT.B16 _) _ -> IntegerType 16
552 SConstCase (TT.B32 _) _ -> IntegerType 32
553 SConstCase (TT.B64 _) _ -> IntegerType 64
554 SConstCase (TT.Fl _) _ -> FloatingPointType 64 IEEE
555 SConstCase (TT.Ch _) _ -> IntegerType 32
556 realPtr <- inst $ BitCast caseValPtr (PointerType (primTy caseTy) (AddrSpace 0)) []
557 valPtr <- inst $ GetElementPtr True realPtr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
558 caseVal <- inst $ Load False valPtr Nothing 0 []
559 defBlockName <- getName "default"
560 exitBlockName <- getName "caseExit"
561 namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
562 terminate $ Switch caseVal defBlockName (map (\(n, SConstCase c _) -> (cgConst' c, n)) namedAlts) []
563 initEnv <- gets lexenv
564 defResult <- cgDefaultAlt exitBlockName defBlockName defExp
565 results <- forM namedAlts $ \(name, SConstCase _ exp) -> cgAlt initEnv exitBlockName name Nothing exp
566 finishCase initEnv exitBlockName (defResult:results)
568cgConCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
569cgConCase con defExp alts = do
570 tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []
571 tag <- inst $ Load False tagPtr Nothing 0 []
572 defBlockName <- getName "default"
573 exitBlockName <- getName "caseExit"
574 namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
575 terminate $ Switch tag defBlockName (map (\(n, SConCase _ tag _ _ _) ->
576 (C.Int 32 (fromIntegral tag), n)) namedAlts) []
577 initEnv <- gets lexenv
578 defResult <- cgDefaultAlt exitBlockName defBlockName defExp
579 results <- forM namedAlts $ \(name, SConCase _ _ _ argns exp) ->
580 cgAlt initEnv exitBlockName name (Just (con, map show argns)) exp
581 finishCase initEnv exitBlockName (defResult:results)
583cgChainCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
584cgChainCase caseValPtr defExp alts = do
585 let (caseTy, comparator) =
586 case head alts of
587 SConstCase (TT.BI _) _ -> (FInt ITBig, "__gmpz_cmp")
588 SConstCase (TT.Str _) _ -> (FString, "strcmp")
589 caseVal <- unbox caseTy caseValPtr
590 defBlockName <- getName "default"
591 exitBlockName <- getName "caseExit"
592 namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
593 initEnv <- gets lexenv
594 results <- forM namedAlts $ \(name, SConstCase c e) ->
595 do const <- unbox caseTy =<< cgConst c
596 cmp <- inst $ simpleCall comparator [const, caseVal]
597 cmpResult <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) []
598 elseName <- getName "else"
599 terminate $ CondBr cmpResult name elseName []
600 result <- cgAlt initEnv exitBlockName name Nothing e
601 newBlock elseName
602 return result
603 modify $ \s -> s { lexenv = initEnv }
604 fname <- getFuncName
605 defaultVal <- cgExpr (fromMaybe (SError $ "Inexhaustive case failure in " ++ fname) defExp)
606 defaultBlock <- gets currentBlockName
607 defaultEnv <- gets lexenv
608 defResult <- case defaultVal of
609 Just v -> do
610 terminate $ Br exitBlockName []
611 return $ Just (v, defaultBlock, defaultEnv)
612 Nothing -> do
613 terminate $ Unreachable []
614 return Nothing
615 finishCase initEnv exitBlockName (defResult:results)
617finishCase :: Env -> Name -> [Maybe (Operand, Name, Env)] -> Codegen (Maybe Operand)
618finishCase initEnv exitBlockName results = do
619 let definedResults = mapMaybe id results
620 case definedResults of
621 [] -> do modify $ \s -> s { lexenv = initEnv }
622 return Nothing
623 xs -> do
624 newBlock exitBlockName
625 mergeEnvs $ map (\(_, altBlock, altEnv) -> (altBlock, altEnv)) xs
626 Just <$> inst (Phi (PointerType valueType (AddrSpace 0))
627 (map (\(altVal, altBlock, _) -> (altVal, altBlock)) xs) [])
630cgDefaultAlt :: Name -> Name -> Maybe SExp -> Codegen (Maybe (Operand, Name, Env))
631cgDefaultAlt exitName name exp = do
632 newBlock name
633 fname <- getFuncName
634 val <- cgExpr (fromMaybe (SError $ "Inexhaustive case failure in " ++ fname) exp)
635 env <- gets lexenv
636 block <- gets currentBlockName
637 case val of
638 Just v ->
639 do terminate $ Br exitName []
640 return $ Just (v, block, env)
641 Nothing ->
642 do terminate $ Unreachable []
643 return Nothing
645cgAlt :: Env -> Name -> Name -> Maybe (Operand, [String]) -> SExp
646 -> Codegen (Maybe (Operand, Name, Env))
647cgAlt initEnv exitBlockName name destr exp = do
648 modify $ \s -> s { lexenv = initEnv }
649 newBlock name
650 locals <- case destr of
651 Nothing -> return []
652 Just (con, argns) ->
653 forM (zip argns [0..]) $ \(argName, i) ->
654 do ptr <- inst $ GetElementPtr True con [ ConstantOperand (C.Int 32 0)
655 , ConstantOperand (C.Int 32 1)
656 , ConstantOperand (C.Int 32 i)] []
657 Just <$> ninst argName (Load False ptr Nothing 0 [])
658 altVal <- binds locals $ cgExpr exp
659 altEnv <- gets lexenv
660 altBlock <- gets currentBlockName
661 case altVal of
662 Just v -> do
663 terminate $ Br exitBlockName []
664 return $ Just (v, altBlock, altEnv)
665 Nothing -> do
666 terminate $ Unreachable []
667 return Nothing
669mergeEnvs :: [(Name, Env)] -> Codegen ()
670mergeEnvs es = do
671 let vars = transpose
672 . map (\(block, env) -> map (\x -> (x, block)) env)
673 $ es
674 env <- forM vars $ \var ->
675 case var of
676 [] -> ierror "mergeEnvs: impossible"
677 [(v, _)] -> return v
678 vs@((v, _):_)
679 | all (== v) (map fst vs) -> return v
680 | otherwise ->
681 let valid = map (\(a, b) -> (fromJust a, b)) . filter (isJust . fst) $ vs in
682 Just <$> inst (Phi (PointerType valueType (AddrSpace 0)) valid [])
683 modify $ \s -> s { lexenv = env }
685nameAlt :: Name -> SAlt -> Codegen Name
686nameAlt d (SDefaultCase _) = return d
687nameAlt _ (SConCase _ _ name _ _) = getName (show name)
688nameAlt _ (SConstCase const _) = getName (show const)
690box :: FType -> Operand -> Codegen Operand
691box FUnit _ = return $ ConstantOperand nullValue
692box fty fval = do
693 val <- alloc (primTy (ftyToTy fty))
694 tagptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []
695 valptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
696 inst' $ Store False tagptr (ConstantOperand (C.Int 32 (-1))) Nothing 0 []
697 inst' $ Store False valptr fval Nothing 0 []
698 inst $ BitCast val (PointerType valueType (AddrSpace 0)) []
700unbox :: FType -> Operand -> Codegen Operand
701unbox FUnit x = return x
702unbox fty bval = do
703 val <- inst $ BitCast bval (PointerType (primTy (ftyToTy fty)) (AddrSpace 0)) []
704 fvalptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
705 inst $ Load False fvalptr Nothing 0 []
707cgConst' :: TT.Const -> C.Constant
708cgConst' (TT.I i) = C.Int 32 (fromIntegral i)
709cgConst' (TT.B8 i) = C.Int 8 (fromIntegral i)
710cgConst' (TT.B16 i) = C.Int 16 (fromIntegral i)
711cgConst' (TT.B32 i) = C.Int 32 (fromIntegral i)
712cgConst' (TT.B64 i) = C.Int 64 (fromIntegral i)
713cgConst' (TT.BI i) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) (show i) ++ [C.Int 8 0])
714cgConst' (TT.Fl f) = C.Float (F.Double f)
715cgConst' (TT.Ch c) = C.Int 32 . fromIntegral . fromEnum $ c
716cgConst' (TT.Str s) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) s ++ [C.Int 8 0])
717cgConst' x = ierror $ "Unsupported constant: " ++ show x
719cgConst :: TT.Const -> Codegen Operand
720cgConst c@(TT.I _) = box (FInt ITNative) (ConstantOperand $ cgConst' c)
721cgConst c@(TT.B8 _) = box (FInt IT8) (ConstantOperand $ cgConst' c)
722cgConst c@(TT.B16 _) = box (FInt IT16) (ConstantOperand $ cgConst' c)
723cgConst c@(TT.B32 _) = box (FInt IT32) (ConstantOperand $ cgConst' c)
724cgConst c@(TT.B64 _) = box (FInt IT64) (ConstantOperand $ cgConst' c)
725cgConst c@(TT.Fl _) = box FDouble (ConstantOperand $ cgConst' c)
726cgConst c@(TT.Ch _) = box FChar (ConstantOperand $ cgConst' c)
727cgConst c@(TT.Str s) = do
728 str <- addGlobal' (ArrayType (1 + fromIntegral (length s)) (IntegerType 8)) (cgConst' c)
729 box FString (ConstantOperand $ C.GetElementPtr True str [C.Int 32 0, C.Int 32 0])
730cgConst c@(TT.BI i) = do
731 str <- addGlobal' (ArrayType (1 + fromInteger (numDigits 10 i)) (IntegerType 8)) (cgConst' c)
732 mpz <- alloc mpzTy
733 inst $ simpleCall "__gmpz_init_set_str" [mpz
734 , ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0, C.Int 32 0]
735 , ConstantOperand $ C.Int 32 10
736 ]
737 box (FInt ITBig) mpz
738cgConst x = return $ ConstantOperand nullValue
740numDigits :: Integer -> Integer -> Integer
741numDigits b n = 1 + fst (ilog b n) where
742 ilog b n
743 | n < b = (0, n)
744 | otherwise = let (e, r) = ilog (b*b) n
745 in if r < b then (2*e, r) else (2*e+1, r `div` b)
747addGlobal :: Global -> Codegen ()
748addGlobal def = tell ([], [], [GlobalDefinition def])
750addGlobal' :: Type -> C.Constant -> Codegen C.Constant
751addGlobal' ty val = do
752 name <- getGlobalUnName
753 addGlobal $ globalVariableDefaults
754 { G.name = name
755 , G.linkage = L.Internal
756 , G.hasUnnamedAddr = True
757 , G.isConstant = True
758 , G.type' = ty
759 , G.initializer = Just val
760 }
761 return . C.GlobalReference $ name
764ensureCDecl :: String -> FType -> [FType] -> Codegen Operand
765ensureCDecl name rty argtys = do
766 syms <- gets foreignSyms
767 unless (S.member name syms) $
768 do addGlobal (ffunDecl name rty argtys)
769 modify $ \s -> s { foreignSyms = S.insert name (foreignSyms s) }
770 return $ ConstantOperand (C.GlobalReference (Name name))
772ffunDecl :: String -> FType -> [FType] -> Global
773ffunDecl name rty argtys =
774 functionDefaults
775 { G.returnType = ftyToTy rty
776 , G.name = Name name
777 , G.parameters = (flip map argtys $ \fty ->
778 Parameter (ftyToTy fty) (UnName 0) []
779 , False)
780 }
782ftyToTy :: FType -> Type
783ftyToTy (FInt ITNative) = IntegerType 32
784ftyToTy (FInt ITBig) = PointerType mpzTy (AddrSpace 0)
785ftyToTy (FInt ty) = IntegerType (itWidth ty)
786ftyToTy FChar = IntegerType 32
787ftyToTy FString = PointerType (IntegerType 8) (AddrSpace 0)
788ftyToTy FUnit = VoidType
789ftyToTy FPtr = PointerType (IntegerType 8) (AddrSpace 0)
790ftyToTy FDouble = FloatingPointType 64 IEEE
791ftyToTy FAny = valueType
793cgOp :: PrimFn -> [Operand] -> Codegen Operand
794cgOp (LTrunc ITBig ity) [x] = do
795 nx <- unbox (FInt ITBig) x
796 val <- inst $ simpleCall "mpz_get_ull" [nx]
797 v <- case ity of
798 IT64 -> return val
799 _ -> inst $ Trunc val (IntegerType $ itWidth ity) []
800 box (FInt ity) v
801cgOp (LZExt from ITBig) [x] = do
802 nx <- unbox (FInt from) x
803 nx' <- case from of
804 IT64 -> return nx
805 _ -> inst $ ZExt nx (IntegerType 64) []
806 mpz <- alloc mpzTy
807 inst' $ simpleCall "mpz_init_set_ull" [mpz, nx']
808 box (FInt ITBig) mpz
809cgOp (LSExt from ITBig) [x] = do
810 nx <- unbox (FInt from) x
811 nx' <- case from of
812 IT64 -> return nx
813 _ -> inst $ SExt nx (IntegerType 64) []
814 mpz <- alloc mpzTy
815 inst' $ simpleCall "mpz_init_set_sll" [mpz, nx']
816 box (FInt ITBig) mpz
818cgOp (LLt ITBig) [x,y] = mpzCmp IPred.SLT x y
819cgOp (LLe ITBig) [x,y] = mpzCmp IPred.SLE x y
820cgOp (LEq ITBig) [x,y] = mpzCmp IPred.EQ x y
821cgOp (LGe ITBig) [x,y] = mpzCmp IPred.SGE x y
822cgOp (LGt ITBig) [x,y] = mpzCmp IPred.SGT x y
823cgOp (LPlus ITBig) [x,y] = mpzBin "add" x y
824cgOp (LMinus ITBig) [x,y] = mpzBin "sub" x y
825cgOp (LTimes ITBig) [x,y] = mpzBin "mul" x y
826cgOp (LSDiv ITBig) [x,y] = mpzBin "fdiv_q" x y
827cgOp (LSRem ITBig) [x,y] = mpzBin "fdiv_r" x y
828cgOp (LAnd ITBig) [x,y] = mpzBin "and" x y
829cgOp (LOr ITBig) [x,y] = mpzBin "ior" x y
830cgOp (LXOr ITBig) [x,y] = mpzBin "xor" x y
831cgOp (LCompl ITBig) [x] = mpzUn "com" x
833cgOp (LTrunc from to) [x] | itWidth from > itWidth to = iCoerce Trunc from to x
834cgOp (LZExt from to) [x] | itWidth from < itWidth to = iCoerce ZExt from to x
835cgOp (LSExt from to) [x] | itWidth from < itWidth to = iCoerce SExt from to x
837cgOp (LLt ity) [x,y] = iCmp ity IPred.SLT x y
838cgOp (LLe ity) [x,y] = iCmp ity IPred.SLE x y
839cgOp (LEq ity) [x,y] = iCmp ity IPred.EQ x y
840cgOp (LGe ity) [x,y] = iCmp ity IPred.SGE x y
841cgOp (LGt ity) [x,y] = iCmp ity IPred.SGT x y
842cgOp (LPlus ity) [x,y] = ibin ity x y (Add False False)
843cgOp (LMinus ity) [x,y] = ibin ity x y (Sub False False)
844cgOp (LTimes ity) [x,y] = ibin ity x y (Mul False False)
845cgOp (LUDiv ity) [x,y] = ibin ity x y (UDiv False)
846cgOp (LURem ity) [x,y] = ibin ity x y URem
847cgOp (LSDiv ity) [x,y] = ibin ity x y (SDiv False)
848cgOp (LSRem ity) [x,y] = ibin ity x y SRem
849cgOp (LAnd ity) [x,y] = ibin ity x y And
850cgOp (LOr ity) [x,y] = ibin ity x y Or
851cgOp (LXOr ity) [x,y] = ibin ity x y Xor
852cgOp (LCompl ity) [x] = iun ity x (Xor (ConstantOperand (C.Int (itWidth ity) (-1))))
853cgOp (LSHL ity) [x,y] = ibin ity x y (Shl False False)
854cgOp (LLSHR ity) [x,y] = ibin ity x y (LShr False)
855cgOp (LASHR ity) [x,y] = ibin ity x y (AShr False)
857cgOp LStrEq [x,y] = do
858 x' <- unbox FString x
859 y' <- unbox FString y
860 cmp <- inst $ simpleCall "strcmp" [x', y']
861 flag <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) []
862 val <- inst $ ZExt flag (IntegerType 32) []
863 box (FInt IT32) val
865cgOp LStrLt [x,y] = do
866 nx <- unbox FString x
867 ny <- unbox FString y
868 cmp <- inst $ simpleCall "strcmp" [nx, ny]
869 flag <- inst $ ICmp IPred.ULT cmp (ConstantOperand (C.Int 32 0)) []
870 val <- inst $ ZExt flag (IntegerType 32) []
871 box (FInt IT32) val
873cgOp (LIntStr ITBig) [x] = do
874 x' <- unbox (FInt ITBig) x
875 ustr <- inst $ simpleCall "__gmpz_get_str"
876 [ ConstantOperand (C.Null (PointerType (IntegerType 8) (AddrSpace 0)))
877 , ConstantOperand (C.Int 32 10)
878 , x'
879 ]
880 box FString ustr
881cgOp (LIntStr ity) [x] = do
882 x' <- unbox (FInt ity) x
883 x'' <- if itWidth ity < 64
884 then inst $ SExt x' (IntegerType 64) []
885 else return x'
886 box FString =<< inst (idrCall "__idris_intStr" [x''])
887cgOp (LStrInt ITBig) [s] = do
888 ns <- unbox FString s
889 mpz <- alloc mpzTy
890 inst $ simpleCall "__gmpz_init_set_str" [mpz, ns, ConstantOperand $ C.Int 32 10]
891 box (FInt ITBig) mpz
892cgOp (LStrInt ity) [s] = do
893 ns <- unbox FString s
894 nx <- inst $ simpleCall "strtoll"
895 [ns
896 , ConstantOperand $ C.Null (PointerType (PointerType (IntegerType 8) (AddrSpace 0)) (AddrSpace 0))
897 , ConstantOperand $ C.Int 32 10
898 ]
899 nx' <- case ity of
900 IT64 -> return nx
901 _ -> inst $ Trunc nx (IntegerType (itWidth ity)) []
902 box (FInt ity) nx'
904cgOp LStrConcat [x,y] = cgStrCat x y
906cgOp LStrCons [c,s] = do
907 nc <- unbox FChar c
908 ns <- unbox FString s
909 nc' <- inst $ Trunc nc (IntegerType 8) []
910 r <- inst $ simpleCall "__idris_strCons" [nc', ns]
911 box FString r
913cgOp LStrHead [c] = do
914 s <- unbox FString c
915 c <- inst $ Load False s Nothing 0 []
916 c' <- inst $ ZExt c (IntegerType 32) []
917 box FChar c'
919cgOp LStrIndex [s, i] = do
920 ns <- unbox FString s
921 ni <- unbox (FInt IT32) i
922 p <- inst $ GetElementPtr True ns [ni] []
923 c <- inst $ Load False p Nothing 0 []
924 c' <- inst $ ZExt c (IntegerType 32) []
925 box FChar c'
927cgOp LStrTail [c] = do
928 s <- unbox FString c
929 c <- inst $ GetElementPtr True s [ConstantOperand $ C.Int 32 1] []
930 box FString c
932cgOp LStrLen [s] = do
933 ns <- unbox FString s
934 len <- inst $ simpleCall "strlen" [ns]
935 ws <- getWordSize
936 len' <- case ws of
937 32 -> return len
938 x | x > 32 -> inst $ Trunc len (IntegerType 32) []
939 | x < 32 -> inst $ ZExt len (IntegerType 32) []
940 box (FInt IT32) len'
942cgOp LReadStr [p] = do
943 np <- unbox FPtr p
944 s <- inst $ simpleCall "__idris_readStr" [np]
945 box FString s
947cgOp LStdIn [] = do
948 stdin <- getStdIn
949 ptr <- inst $ Load False stdin Nothing 0 []
950 box FPtr ptr
951cgOp LStdOut [] = do
952 stdout <- getStdOut
953 ptr <- inst $ Load False stdout Nothing 0 []
954 box FPtr ptr
955cgOp LStdErr [] = do
956 stdErr <- getStdErr
957 ptr <- inst $ Load False stdErr Nothing 0 []
958 box FPtr ptr
960cgOp prim args = ierror $ "Unimplemented primitive: [" ++ show prim ++ "]("
961 ++ intersperse ',' (take (length args) ['a'..]) ++ ")"
963iCoerce :: (Operand -> Type -> InstructionMetadata -> Instruction) -> IntTy -> IntTy -> Operand -> Codegen Operand
964iCoerce operator from to x = do
965 x' <- unbox (FInt from) x
966 x'' <- inst $ operator x' (IntegerType $ itWidth to) []
967 box (FInt to) x''
969cgStrCat :: Operand -> Operand -> Codegen Operand
970cgStrCat x y = do
971 x' <- unbox FString x
972 y' <- unbox FString y
973 xlen <- inst $ simpleCall "strlen" [x']
974 ylen <- inst $ simpleCall "strlen" [y']
975 zlen <- inst $ Add False True xlen ylen []
976 ws <- getWordSize
977 total <- inst $ Add False True zlen (ConstantOperand (C.Int ws 1)) []
978 mem <- allocAtomic total
979 inst $ simpleCall "memcpy" [mem, x', xlen]
980 i <- inst $ PtrToInt mem (IntegerType ws) []
981 offi <- inst $ Add False True i xlen []
982 offp <- inst $ IntToPtr offi (PointerType (IntegerType 8) (AddrSpace 0)) []
983 inst $ simpleCall "memcpy" [offp, y', ylen]
984 j <- inst $ PtrToInt offp (IntegerType ws) []
985 offj <- inst $ Add False True j ylen []
986 end <- inst $ IntToPtr offj (PointerType (IntegerType 8) (AddrSpace 0)) []
987 inst' $ Store False end (ConstantOperand (C.Int 8 0)) Nothing 0 []
988 box FString mem
990ibin :: IntTy -> Operand -> Operand
991 -> (Operand -> Operand -> InstructionMetadata -> Instruction) -> Codegen Operand
992ibin ity x y instCon = do
993 nx <- unbox (FInt ity) x
994 ny <- unbox (FInt ity) y
995 nr <- inst $ instCon nx ny []
996 box (FInt ity) nr
998iun :: IntTy -> Operand -> (Operand -> InstructionMetadata -> Instruction) -> Codegen Operand
999iun ity x instCon = do
1000 nx <- unbox (FInt ity) x
1001 nr <- inst $ instCon nx []
1002 box (FInt ity) nr
1004iCmp :: IntTy -> IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand
1005iCmp ity pred x y = do
1006 nx <- unbox (FInt ity) x
1007 ny <- unbox (FInt ity) y
1008 nr <- inst $ ICmp pred nx ny []
1009 nr' <- inst $ ZExt nr (IntegerType 32) []
1010 box (FInt IT32) nr'
1012mpzBin :: String -> Operand -> Operand -> Codegen Operand
1013mpzBin name x y = do
1014 nx <- unbox (FInt ITBig) x
1015 ny <- unbox (FInt ITBig) y
1016 nz <- alloc mpzTy
1017 inst' $ simpleCall "__gmpz_init" [nz]
1018 inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx, ny]
1019 box (FInt ITBig) nz
1021mpzUn :: String -> Operand -> Codegen Operand
1022mpzUn name x = do
1023 nx <- unbox (FInt ITBig) x
1024 nz <- alloc mpzTy
1025 inst' $ simpleCall "__gmpz_init" [nz]
1026 inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx]
1027 box (FInt ITBig) nz
1029mpzCmp :: IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand
1030mpzCmp pred x y = do
1031 nx <- unbox (FInt ITBig) x
1032 ny <- unbox (FInt ITBig) y
1033 cmp <- inst $ simpleCall "__gmpz_cmp" [nx, ny]
1034 result <- inst $ ICmp pred cmp (ConstantOperand (C.Int 32 0)) []
1035 i <- inst $ ZExt result (IntegerType 32) []
1036 box (FInt IT32) i
1038simpleCall :: String -> [Operand] -> Instruction
1039simpleCall name args =
1040 Call { isTailCall = False
1041 , callingConvention = CC.C
1042 , returnAttributes = []
1043 , function = Right . ConstantOperand . C.GlobalReference . Name $ name
1044 , arguments = map (\x -> (x, [])) args
1045 , functionAttributes = []
1046 , metadata = []
1049idrCall :: String -> [Operand] -> Instruction
1050idrCall name args =
1051 Call { isTailCall = False
1052 , callingConvention = CC.Fast
1053 , returnAttributes = []
1054 , function = Right . ConstantOperand . C.GlobalReference . Name $ name
1055 , arguments = map (\x -> (x, [])) args
1056 , functionAttributes = []
1057 , metadata = []
1060assert :: Operand -> String -> Codegen ()
1061assert condition message = do
1062 passed <- getName "assertPassed"
1063 failed <- getName "assertFailed"
1064 terminate $ CondBr condition passed failed []
1065 newBlock failed
1066 cgExpr (SError message)
1067 terminate $ Unreachable []
1068 newBlock passed