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