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