git.iko.soy/Idris-dev
on fbd6471 help sign in
Idris-dev/src/IRTS/CodegenLLVM.hs
1115 lines 45 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 qualified Data.Vector.Unboxed as V
40import Control.Applicative
41import Control.Monad.RWS
42import Control.Monad.Writer
43import Control.Monad.State
44import Control.Monad.Error
46import qualified System.Info as SI (arch, os)
47import System.IO
48import System.Directory (removeFile)
49import System.FilePath ((</>))
50import System.Process (rawSystem)
51import System.Exit (ExitCode(..))
52import Debug.Trace
54data Target = Target { triple :: String, dataLayout :: DataLayout }
56codegenLLVM :: [(TT.Name, SDecl)] ->
57 String -> -- target triple
58 String -> -- target CPU
59 Int -> -- Optimization degree
60 FilePath -> -- output file name
61 OutputType ->
62 IO ()
63codegenLLVM defs triple cpu optimize file outty = withContext $ \context -> do
64 initializeAllTargets
65 (target, _) <- failInIO $ lookupTarget Nothing triple
66 withTargetOptions $ \options ->
67 withTargetMachine target triple cpu S.empty options R.Default CM.Default CGO.Default $ \tm ->
68 do layout <- getTargetMachineDataLayout tm
69 let ast = codegen (Target triple layout) (map snd defs)
70 result <- runErrorT . M.withModuleFromAST context ast $ \m ->
71 do let opts = defaultCuratedPassSetSpec
72 { optLevel = Just optimize
73 , simplifyLibCalls = Just True
74 , useInlinerWithThreshold = Just 225
75 }
76 when (optimize /= 0) $ withPassManager opts $ void . flip runPassManager m
77 outputModule tm file outty m
78 case result of
79 Right _ -> return ()
80 Left msg -> ierror msg
82failInIO :: ErrorT String IO a -> IO a
83failInIO = either fail return <=< runErrorT
85outputModule :: TargetMachine -> FilePath -> OutputType -> M.Module -> IO ()
86outputModule _ file Raw m = failInIO $ M.writeBitcodeToFile file m
87outputModule tm file Object m = failInIO $ M.writeObjectToFile tm file m
88outputModule tm file Executable m = withTmpFile $ \obj -> do
89 outputModule tm obj Object m
90 cc <- getCC
91 defs <- (</> "llvm" </> "libidris_rts.a") <$> getDataDir
92 exit <- rawSystem cc [obj, defs, "-lm", "-lgmp", "-lgc", "-o", file]
93 when (exit /= ExitSuccess) $ ierror "FAILURE: Linking"
95withTmpFile :: (FilePath -> IO a) -> IO a
96withTmpFile f = do
97 (path, handle) <- tempfile
98 hClose handle
99 result <- f path
100 removeFile path
101 return result
103ierror :: String -> a
104ierror msg = error $ "INTERNAL ERROR: IRTS.CodegenLLVM: " ++ msg
106mainDef :: Global
107mainDef =
108 functionDefaults
109 { G.returnType = IntegerType 32
110 , G.parameters =
111 ([ Parameter (IntegerType 32) (Name "argc") []
112 , Parameter (PointerType (PointerType (IntegerType 8) (AddrSpace 0)) (AddrSpace 0)) (Name "argv") []
113 ], False)
114 , G.name = Name "main"
115 , G.basicBlocks =
116 [ BasicBlock (UnName 0)
117 [ Do $ simpleCall "GC_init" [] -- Initialize Boehm GC
118 , Do $ simpleCall "__gmp_set_memory_functions"
119 [ ConstantOperand . C.GlobalReference . Name $ "__idris_gmpMalloc"
120 , ConstantOperand . C.GlobalReference . Name $ "__idris_gmpRealloc"
121 , ConstantOperand . C.GlobalReference . Name $ "__idris_gmpFree"
122 ]
123 , UnName 1 := idrCall "{runMain0}" [] ]
124 (Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [])
125 ]}
127initDefs :: Target -> [Definition]
128initDefs tgt =
129 [ TypeDefinition (Name "valTy")
130 (Just $ StructureType False
131 [ IntegerType 32
132 , ArrayType 0 (PointerType valueType (AddrSpace 0))
133 ])
134 , TypeDefinition (Name "mpz")
135 (Just $ StructureType False
136 [ IntegerType 32
137 , IntegerType 32
138 , PointerType intPtr (AddrSpace 0)
139 ])
140 , GlobalDefinition $ globalVariableDefaults
141 { G.name = Name "__idris_intFmtStr"
142 , G.linkage = L.Internal
143 , G.isConstant = True
144 , G.hasUnnamedAddr = True
145 , G.type' = ArrayType 5 (IntegerType 8)
146 , G.initializer = Just $ C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) "%lld" ++ [C.Int 8 0])
147 }
148 , rtsFun "intStr" ptrI8 [IntegerType 64]
149 [ BasicBlock (UnName 0)
150 [ UnName 1 := simpleCall "GC_malloc_atomic" [ConstantOperand (C.Int (tgtWordSize tgt) 21)]
151 , UnName 2 := simpleCall "snprintf"
152 [ LocalReference (UnName 1)
153 , ConstantOperand (C.Int (tgtWordSize tgt) 21)
154 , ConstantOperand $ C.GetElementPtr True (C.GlobalReference . Name $ "__idris_intFmtStr") [C.Int 32 0, C.Int 32 0]
155 , LocalReference (UnName 0)
156 ]
157 ]
158 (Do $ Ret (Just (LocalReference (UnName 1))) [])
159 ]
160 , exfun "llvm.trap" VoidType [] False
161 -- , exfun "llvm.llvm.memcpy.p0i8.p0i8.i32" VoidType [ptrI8, ptrI8, IntegerType 32, IntegerType 32, IntegerType 1] False
162 -- , exfun "llvm.llvm.memcpy.p0i8.p0i8.i64" VoidType [ptrI8, ptrI8, IntegerType 64, IntegerType 32, IntegerType 1] False
163 , exfun "memcpy" ptrI8 [ptrI8, ptrI8, intPtr] False
164 , exfun "snprintf" (IntegerType 32) [ptrI8, intPtr, ptrI8] True
165 , exfun "strcmp" (IntegerType 32) [ptrI8, ptrI8] False
166 , exfun "strlen" intPtr [ptrI8] 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) (Just . triple $ tgt) (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 _) _ -> (FArith (ATInt 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.B8V v) = C.Vector (map ((C.Int 8) . fromIntegral) . V.toList $ v)
714cgConst' (TT.B16V v) = C.Vector (map ((C.Int 16) . fromIntegral) . V.toList $ v)
715cgConst' (TT.B32V v) = C.Vector (map ((C.Int 32) . fromIntegral) . V.toList $ v)
716cgConst' (TT.B64V v) = C.Vector (map ((C.Int 64) . fromIntegral) . V.toList $ v)
718cgConst' (TT.BI i) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) (show i) ++ [C.Int 8 0])
719cgConst' (TT.Fl f) = C.Float (F.Double f)
720cgConst' (TT.Ch c) = C.Int 32 . fromIntegral . fromEnum $ c
721cgConst' (TT.Str s) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) s ++ [C.Int 8 0])
722cgConst' x = ierror $ "Unsupported constant: " ++ show x
724cgConst :: TT.Const -> Codegen Operand
725cgConst c@(TT.I _) = box (FArith (ATInt ITNative)) (ConstantOperand $ cgConst' c)
726cgConst c@(TT.B8 _) = box (FArith (ATInt (ITFixed IT8))) (ConstantOperand $ cgConst' c)
727cgConst c@(TT.B16 _) = box (FArith (ATInt (ITFixed IT16))) (ConstantOperand $ cgConst' c)
728cgConst c@(TT.B32 _) = box (FArith (ATInt (ITFixed IT32))) (ConstantOperand $ cgConst' c)
729cgConst c@(TT.B64 _) = box (FArith (ATInt (ITFixed IT64))) (ConstantOperand $ cgConst' c)
730cgConst c@(TT.B8V v) = box (FArith (ATInt (ITVec IT8 (V.length v)))) (ConstantOperand $ cgConst' c)
731cgConst c@(TT.B16V v) = box (FArith (ATInt (ITVec IT16 (V.length v)))) (ConstantOperand $ cgConst' c)
732cgConst c@(TT.B32V v) = box (FArith (ATInt (ITVec IT32 (V.length v)))) (ConstantOperand $ cgConst' c)
733cgConst c@(TT.B64V v) = box (FArith (ATInt (ITVec IT64 (V.length v)))) (ConstantOperand $ cgConst' c)
734cgConst c@(TT.Fl _) = box (FArith ATFloat) (ConstantOperand $ cgConst' c)
735cgConst c@(TT.Ch _) = box (FArith (ATInt ITChar)) (ConstantOperand $ cgConst' c)
736cgConst c@(TT.Str s) = do
737 str <- addGlobal' (ArrayType (1 + fromIntegral (length s)) (IntegerType 8)) (cgConst' c)
738 box FString (ConstantOperand $ C.GetElementPtr True str [C.Int 32 0, C.Int 32 0])
739cgConst c@(TT.BI i) = do
740 str <- addGlobal' (ArrayType (1 + fromInteger (numDigits 10 i)) (IntegerType 8)) (cgConst' c)
741 mpz <- alloc mpzTy
742 inst $ simpleCall "__gmpz_init_set_str" [mpz
743 , ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0, C.Int 32 0]
744 , ConstantOperand $ C.Int 32 10
745 ]
746 box (FArith (ATInt ITBig)) mpz
747cgConst x = return $ ConstantOperand nullValue
749numDigits :: Integer -> Integer -> Integer
750numDigits b n = 1 + fst (ilog b n) where
751 ilog b n
752 | n < b = (0, n)
753 | otherwise = let (e, r) = ilog (b*b) n
754 in if r < b then (2*e, r) else (2*e+1, r `div` b)
756addGlobal :: Global -> Codegen ()
757addGlobal def = tell ([], [], [GlobalDefinition def])
759addGlobal' :: Type -> C.Constant -> Codegen C.Constant
760addGlobal' ty val = do
761 name <- getGlobalUnName
762 addGlobal $ globalVariableDefaults
763 { G.name = name
764 , G.linkage = L.Internal
765 , G.hasUnnamedAddr = True
766 , G.isConstant = True
767 , G.type' = ty
768 , G.initializer = Just val
769 }
770 return . C.GlobalReference $ name
773ensureCDecl :: String -> FType -> [FType] -> Codegen Operand
774ensureCDecl name rty argtys = do
775 syms <- gets foreignSyms
776 unless (S.member name syms) $
777 do addGlobal (ffunDecl name rty argtys)
778 modify $ \s -> s { foreignSyms = S.insert name (foreignSyms s) }
779 return $ ConstantOperand (C.GlobalReference (Name name))
781ffunDecl :: String -> FType -> [FType] -> Global
782ffunDecl name rty argtys =
783 functionDefaults
784 { G.returnType = ftyToTy rty
785 , G.name = Name name
786 , G.parameters = (flip map argtys $ \fty ->
787 Parameter (ftyToTy fty) (UnName 0) []
788 , False)
789 }
791ftyToTy :: FType -> Type
792ftyToTy (FArith (ATInt ITNative)) = IntegerType 32
793ftyToTy (FArith (ATInt ITBig)) = PointerType mpzTy (AddrSpace 0)
794ftyToTy (FArith (ATInt (ITFixed ty))) = IntegerType (fromIntegral $ nativeTyWidth ty)
795ftyToTy (FArith (ATInt (ITVec e c)))
796 = VectorType (fromIntegral c) (IntegerType (fromIntegral $ nativeTyWidth e))
797ftyToTy (FArith (ATInt ITChar)) = IntegerType 32
798ftyToTy FString = PointerType (IntegerType 8) (AddrSpace 0)
799ftyToTy FUnit = VoidType
800ftyToTy FPtr = PointerType (IntegerType 8) (AddrSpace 0)
801ftyToTy (FArith ATFloat) = FloatingPointType 64 IEEE
802ftyToTy FAny = valueType
804-- Only use when known not to be ITBig
805itWidth :: IntTy -> Word32
806itWidth ITNative = 32
807itWidth ITChar = 32
808itWidth (ITFixed x) = fromIntegral $ nativeTyWidth x
810cgOp :: PrimFn -> [Operand] -> Codegen Operand
811cgOp (LTrunc ITBig ity) [x] = do
812 nx <- unbox (FArith (ATInt ITBig)) x
813 val <- inst $ simpleCall "mpz_get_ull" [nx]
814 v <- case ity of
815 (ITFixed IT64) -> return val
816 _ -> inst $ Trunc val (ftyToTy (FArith (ATInt ity))) []
817 box (FArith (ATInt ity)) v
818cgOp (LZExt from ITBig) [x] = do
819 nx <- unbox (FArith (ATInt from)) x
820 nx' <- case from of
821 (ITFixed IT64) -> return nx
822 _ -> inst $ ZExt nx (IntegerType 64) []
823 mpz <- alloc mpzTy
824 inst' $ simpleCall "mpz_init_set_ull" [mpz, nx']
825 box (FArith (ATInt ITBig)) mpz
826cgOp (LSExt from ITBig) [x] = do
827 nx <- unbox (FArith (ATInt from)) x
828 nx' <- case from of
829 (ITFixed IT64) -> return nx
830 _ -> inst $ SExt nx (IntegerType 64) []
831 mpz <- alloc mpzTy
832 inst' $ simpleCall "mpz_init_set_sll" [mpz, nx']
833 box (FArith (ATInt ITBig)) mpz
835cgOp (LLt (ATInt ITBig)) [x,y] = mpzCmp IPred.SLT x y
836cgOp (LLe (ATInt ITBig)) [x,y] = mpzCmp IPred.SLE x y
837cgOp (LEq (ATInt ITBig)) [x,y] = mpzCmp IPred.EQ x y
838cgOp (LGe (ATInt ITBig)) [x,y] = mpzCmp IPred.SGE x y
839cgOp (LGt (ATInt ITBig)) [x,y] = mpzCmp IPred.SGT x y
840cgOp (LPlus (ATInt ITBig)) [x,y] = mpzBin "add" x y
841cgOp (LMinus (ATInt ITBig)) [x,y] = mpzBin "sub" x y
842cgOp (LTimes (ATInt ITBig)) [x,y] = mpzBin "mul" x y
843cgOp (LSDiv (ATInt ITBig)) [x,y] = mpzBin "fdiv_q" x y
844cgOp (LSRem (ATInt ITBig)) [x,y] = mpzBin "fdiv_r" x y
845cgOp (LAnd ITBig) [x,y] = mpzBin "and" x y
846cgOp (LOr ITBig) [x,y] = mpzBin "ior" x y
847cgOp (LXOr ITBig) [x,y] = mpzBin "xor" x y
848cgOp (LCompl ITBig) [x] = mpzUn "com" x
850cgOp (LTrunc (ITFixed from) (ITFixed to)) [x]
851 | nativeTyWidth from > nativeTyWidth to = iCoerce Trunc from to x
852cgOp (LZExt (ITFixed from) (ITFixed to)) [x]
853 | nativeTyWidth from < nativeTyWidth to = iCoerce ZExt from to x
854cgOp (LSExt (ITFixed from) (ITFixed to)) [x]
855 | nativeTyWidth from < nativeTyWidth to = iCoerce SExt from to x
857cgOp (LLt (ATInt ity)) [x,y] = iCmp ity IPred.SLT x y
858cgOp (LLe (ATInt ity)) [x,y] = iCmp ity IPred.SLE x y
859cgOp (LEq (ATInt ity)) [x,y] = iCmp ity IPred.EQ x y
860cgOp (LGe (ATInt ity)) [x,y] = iCmp ity IPred.SGE x y
861cgOp (LGt (ATInt ity)) [x,y] = iCmp ity IPred.SGT x y
862cgOp (LPlus (ATInt ity)) [x,y] = ibin ity x y (Add False False)
863cgOp (LMinus (ATInt ity)) [x,y] = ibin ity x y (Sub False False)
864cgOp (LTimes (ATInt ity)) [x,y] = ibin ity x y (Mul False False)
865cgOp (LSDiv (ATInt ity)) [x,y] = ibin ity x y (SDiv False)
866cgOp (LSRem (ATInt ity)) [x,y] = ibin ity x y SRem
867cgOp (LUDiv ity) [x,y] = ibin ity x y (UDiv False)
868cgOp (LURem ity) [x,y] = ibin ity x y URem
869cgOp (LAnd ity) [x,y] = ibin ity x y And
870cgOp (LOr ity) [x,y] = ibin ity x y Or
871cgOp (LXOr ity) [x,y] = ibin ity x y Xor
872cgOp (LCompl ity) [x] = iun ity x (Xor (ConstantOperand (C.Int (itWidth ity) (-1))))
873cgOp (LSHL ity) [x,y] = ibin ity x y (Shl False False)
874cgOp (LLSHR ity) [x,y] = ibin ity x y (LShr False)
875cgOp (LASHR ity) [x,y] = ibin ity x y (AShr False)
877cgOp LNoOp xs = return $ last xs
879cgOp (LMkVec ety c) xs | c == length xs = do
880 nxs <- mapM (unbox (FArith (ATInt (ITFixed ety)))) xs
881 vec <- foldM (\v (e, i) -> inst $ InsertElement v e (ConstantOperand (C.Int 32 i)) [])
882 (ConstantOperand $ C.Vector (replicate c (C.Undef (IntegerType . fromIntegral $ nativeTyWidth ety))))
883 (zip nxs [0..])
884 box (FArith (ATInt (ITVec ety c))) vec
886cgOp (LIdxVec ety c) [v,i] = do
887 nv <- unbox (FArith (ATInt (ITVec ety c))) v
888 ni <- unbox (FArith (ATInt (ITFixed IT32))) i
889 elt <- inst $ ExtractElement nv ni []
890 box (FArith (ATInt (ITFixed ety))) elt
892cgOp (LUpdateVec ety c) [v,i,e] = do
893 let fty = FArith (ATInt (ITVec ety c))
894 nv <- unbox fty v
895 ni <- unbox (FArith (ATInt (ITFixed IT32))) i
896 ne <- unbox (FArith (ATInt (ITFixed ety))) e
897 nv' <- inst $ InsertElement nv ne ni []
898 box fty nv'
900cgOp LStrEq [x,y] = do
901 x' <- unbox FString x
902 y' <- unbox FString y
903 cmp <- inst $ simpleCall "strcmp" [x', y']
904 flag <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) []
905 val <- inst $ ZExt flag (IntegerType 32) []
906 box (FArith (ATInt (ITFixed IT32))) val
908cgOp LStrLt [x,y] = do
909 nx <- unbox FString x
910 ny <- unbox FString y
911 cmp <- inst $ simpleCall "strcmp" [nx, ny]
912 flag <- inst $ ICmp IPred.ULT cmp (ConstantOperand (C.Int 32 0)) []
913 val <- inst $ ZExt flag (IntegerType 32) []
914 box (FArith (ATInt (ITFixed IT32))) val
916cgOp (LIntStr ITBig) [x] = do
917 x' <- unbox (FArith (ATInt ITBig)) x
918 ustr <- inst $ simpleCall "__gmpz_get_str"
919 [ ConstantOperand (C.Null (PointerType (IntegerType 8) (AddrSpace 0)))
920 , ConstantOperand (C.Int 32 10)
921 , x'
922 ]
923 box FString ustr
924cgOp (LIntStr ity) [x] = do
925 x' <- unbox (FArith (ATInt ity)) x
926 x'' <- if itWidth ity < 64
927 then inst $ SExt x' (IntegerType 64) []
928 else return x'
929 box FString =<< inst (idrCall "__idris_intStr" [x''])
930cgOp (LStrInt ITBig) [s] = do
931 ns <- unbox FString s
932 mpz <- alloc mpzTy
933 inst $ simpleCall "__gmpz_init_set_str" [mpz, ns, ConstantOperand $ C.Int 32 10]
934 box (FArith (ATInt ITBig)) mpz
935cgOp (LStrInt ity) [s] = do
936 ns <- unbox FString s
937 nx <- inst $ simpleCall "strtoll"
938 [ns
939 , ConstantOperand $ C.Null (PointerType (PointerType (IntegerType 8) (AddrSpace 0)) (AddrSpace 0))
940 , ConstantOperand $ C.Int 32 10
941 ]
942 nx' <- case ity of
943 (ITFixed IT64) -> return nx
944 _ -> inst $ Trunc nx (IntegerType (itWidth ity)) []
945 box (FArith (ATInt ity)) nx'
947cgOp LStrConcat [x,y] = cgStrCat x y
949cgOp LStrCons [c,s] = do
950 nc <- unbox (FArith (ATInt ITChar)) c
951 ns <- unbox FString s
952 nc' <- inst $ Trunc nc (IntegerType 8) []
953 r <- inst $ simpleCall "__idris_strCons" [nc', ns]
954 box FString r
956cgOp LStrHead [c] = do
957 s <- unbox FString c
958 c <- inst $ Load False s Nothing 0 []
959 c' <- inst $ ZExt c (IntegerType 32) []
960 box (FArith (ATInt ITChar)) c'
962cgOp LStrIndex [s, i] = do
963 ns <- unbox FString s
964 ni <- unbox (FArith (ATInt (ITFixed IT32))) i
965 p <- inst $ GetElementPtr True ns [ni] []
966 c <- inst $ Load False p Nothing 0 []
967 c' <- inst $ ZExt c (IntegerType 32) []
968 box (FArith (ATInt ITChar)) c'
970cgOp LStrTail [c] = do
971 s <- unbox FString c
972 c <- inst $ GetElementPtr True s [ConstantOperand $ C.Int 32 1] []
973 box FString c
975cgOp LStrLen [s] = do
976 ns <- unbox FString s
977 len <- inst $ simpleCall "strlen" [ns]
978 ws <- getWordSize
979 len' <- case ws of
980 32 -> return len
981 x | x > 32 -> inst $ Trunc len (IntegerType 32) []
982 | x < 32 -> inst $ ZExt len (IntegerType 32) []
983 box (FArith (ATInt (ITFixed IT32))) len'
985cgOp LReadStr [p] = do
986 np <- unbox FPtr p
987 s <- inst $ simpleCall "__idris_readStr" [np]
988 box FString s
990cgOp LStdIn [] = do
991 stdin <- getStdIn
992 ptr <- inst $ Load False stdin Nothing 0 []
993 box FPtr ptr
994cgOp LStdOut [] = do
995 stdout <- getStdOut
996 ptr <- inst $ Load False stdout Nothing 0 []
997 box FPtr ptr
998cgOp LStdErr [] = do
999 stdErr <- getStdErr
1000 ptr <- inst $ Load False stdErr Nothing 0 []
1001 box FPtr ptr
1003cgOp prim args = ierror $ "Unimplemented primitive: [" ++ show prim ++ "]("
1004 ++ intersperse ',' (take (length args) ['a'..]) ++ ")"
1006iCoerce :: (Operand -> Type -> InstructionMetadata -> Instruction) -> NativeTy -> NativeTy -> Operand -> Codegen Operand
1007iCoerce operator from to x = do
1008 x' <- unbox (FArith (ATInt (ITFixed from))) x
1009 x'' <- inst $ operator x' (ftyToTy (FArith (ATInt (ITFixed from)))) []
1010 box (FArith (ATInt (ITFixed to))) x''
1012cgStrCat :: Operand -> Operand -> Codegen Operand
1013cgStrCat x y = do
1014 x' <- unbox FString x
1015 y' <- unbox FString y
1016 xlen <- inst $ simpleCall "strlen" [x']
1017 ylen <- inst $ simpleCall "strlen" [y']
1018 zlen <- inst $ Add False True xlen ylen []
1019 ws <- getWordSize
1020 total <- inst $ Add False True zlen (ConstantOperand (C.Int ws 1)) []
1021 mem <- allocAtomic total
1022 inst $ simpleCall "memcpy" [mem, x', xlen]
1023 i <- inst $ PtrToInt mem (IntegerType ws) []
1024 offi <- inst $ Add False True i xlen []
1025 offp <- inst $ IntToPtr offi (PointerType (IntegerType 8) (AddrSpace 0)) []
1026 inst $ simpleCall "memcpy" [offp, y', ylen]
1027 j <- inst $ PtrToInt offp (IntegerType ws) []
1028 offj <- inst $ Add False True j ylen []
1029 end <- inst $ IntToPtr offj (PointerType (IntegerType 8) (AddrSpace 0)) []
1030 inst' $ Store False end (ConstantOperand (C.Int 8 0)) Nothing 0 []
1031 box FString mem
1033ibin :: IntTy -> Operand -> Operand
1034 -> (Operand -> Operand -> InstructionMetadata -> Instruction) -> Codegen Operand
1035ibin ity x y instCon = do
1036 nx <- unbox (FArith (ATInt ity)) x
1037 ny <- unbox (FArith (ATInt ity)) y
1038 nr <- inst $ instCon nx ny []
1039 box (FArith (ATInt ity)) nr
1041iun :: IntTy -> Operand -> (Operand -> InstructionMetadata -> Instruction) -> Codegen Operand
1042iun ity x instCon = do
1043 nx <- unbox (FArith (ATInt ity)) x
1044 nr <- inst $ instCon nx []
1045 box (FArith (ATInt ity)) nr
1047iCmp :: IntTy -> IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand
1048iCmp ity pred x y = do
1049 nx <- unbox (FArith (ATInt ity)) x
1050 ny <- unbox (FArith (ATInt ity)) y
1051 nr <- inst $ ICmp pred nx ny []
1052 nr' <- inst $ SExt nr (ftyToTy $ cmpResultTy ity) []
1053 box (cmpResultTy ity) nr'
1055cmpResultTy :: IntTy -> FType
1056cmpResultTy v@(ITVec _ _) = FArith (ATInt v)
1057cmpResultTy _ = FArith (ATInt (ITFixed IT32))
1059mpzBin :: String -> Operand -> Operand -> Codegen Operand
1060mpzBin name x y = do
1061 nx <- unbox (FArith (ATInt ITBig)) x
1062 ny <- unbox (FArith (ATInt ITBig)) y
1063 nz <- alloc mpzTy
1064 inst' $ simpleCall "__gmpz_init" [nz]
1065 inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx, ny]
1066 box (FArith (ATInt ITBig)) nz
1068mpzUn :: String -> Operand -> Codegen Operand
1069mpzUn name x = do
1070 nx <- unbox (FArith (ATInt ITBig)) x
1071 nz <- alloc mpzTy
1072 inst' $ simpleCall "__gmpz_init" [nz]
1073 inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx]
1074 box (FArith (ATInt ITBig)) nz
1076mpzCmp :: IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand
1077mpzCmp pred x y = do
1078 nx <- unbox (FArith (ATInt ITBig)) x
1079 ny <- unbox (FArith (ATInt ITBig)) y
1080 cmp <- inst $ simpleCall "__gmpz_cmp" [nx, ny]
1081 result <- inst $ ICmp pred cmp (ConstantOperand (C.Int 32 0)) []
1082 i <- inst $ ZExt result (IntegerType 32) []
1083 box (FArith (ATInt (ITFixed IT32))) i
1085simpleCall :: String -> [Operand] -> Instruction
1086simpleCall name args =
1087 Call { isTailCall = False
1088 , callingConvention = CC.C
1089 , returnAttributes = []
1090 , function = Right . ConstantOperand . C.GlobalReference . Name $ name
1091 , arguments = map (\x -> (x, [])) args
1092 , functionAttributes = []
1093 , metadata = []
1096idrCall :: String -> [Operand] -> Instruction
1097idrCall name args =
1098 Call { isTailCall = False
1099 , callingConvention = CC.Fast
1100 , returnAttributes = []
1101 , function = Right . ConstantOperand . C.GlobalReference . Name $ name
1102 , arguments = map (\x -> (x, [])) args
1103 , functionAttributes = []
1104 , metadata = []
1107assert :: Operand -> String -> Codegen ()
1108assert condition message = do
1109 passed <- getName "assertPassed"
1110 failed <- getName "assertFailed"
1111 terminate $ CondBr condition passed failed []
1112 newBlock failed
1113 cgExpr (SError message)
1114 terminate $ Unreachable []
1115 newBlock passed