git.iko.soy/Idris-dev
on b0709a7 help sign in
Idris-dev/src/IRTS/CodegenLLVM.hs
846 lines 34 kB history raw
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2module IRTS.CodegenLLVM (codegenLLVM) where
4import IRTS.CodegenCommon
5import IRTS.Lang
6import IRTS.Simplified
7import qualified Core.TT as TT
9import Util.System
10import Paths_idris
12import LLVM.General.Context
13import LLVM.General.Diagnostic
14import LLVM.General.AST
15import LLVM.General.AST.AddrSpace
16import qualified LLVM.General.Module as M
17import qualified LLVM.General.AST.IntegerPredicate as IPred
18import qualified LLVM.General.AST.Linkage as L
19import qualified LLVM.General.AST.Visibility as V
20import qualified LLVM.General.AST.CallingConvention as CC
21import qualified LLVM.General.AST.Attribute as A
22import qualified LLVM.General.AST.Global as G
23import qualified LLVM.General.AST.Constant as C
24import qualified LLVM.General.AST.Float as F
26import Data.List
27import Data.Maybe
28import Data.Word
29import Data.Set (Set)
30import qualified Data.Set as S
31import Control.Applicative
32import Control.Monad.RWS
33import Control.Monad.Writer
34import Control.Monad.State
36import System.Info (arch)
37import System.IO
38import System.Directory (removeFile)
39import System.FilePath ((</>))
40import System.Process (rawSystem)
41import System.Exit (ExitCode(..))
42import Debug.Trace
44codegenLLVM :: [(TT.Name, SDecl)] ->
45 FilePath -> -- output file name
46 OutputType ->
47 IO ()
48codegenLLVM defs file outty = withContext $ \context -> do
49 let ast = codegen arch (map snd defs)
50 result <- M.withModuleFromAST context ast (outputModule file outty)
51 case result of
52 Right _ -> return ()
53 Left msg -> ierror msg
55outputModule :: FilePath -> OutputType -> M.Module -> IO ()
56outputModule file Raw m = M.writeBitcodeToFile file m
57outputModule file Object m = withTmpFile $ \bc -> do
58 outputModule bc Raw m
59 exit <- rawSystem "llc" ["-filetype=obj", "--disable-fp-elim", "-o", file, bc]
60 when (exit /= ExitSuccess) $ ierror "FAILURE: Object generation"
61outputModule file Executable m = withTmpFile $ \obj -> do
62 outputModule obj Object m
63 cc <- getCC
64 defs <- (</> "llvm" </> "libidris_rts.a") <$> getDataDir
65 exit <- rawSystem cc [obj, defs, "-lm", "-lgmp", "-lgc", "-o", file]
66 when (exit /= ExitSuccess) $ ierror "FAILURE: Linking"
68withTmpFile :: (FilePath -> IO a) -> IO a
69withTmpFile f = do
70 (path, handle) <- tempfile
71 hClose handle
72 result <- f path
73 removeFile path
74 return result
76ierror :: String -> a
77ierror msg = error $ "INTERNAL ERROR: IRTS.CodegenLLVM: " ++ msg
79mainDef :: Global
80mainDef =
81 functionDefaults
82 { G.returnType = IntegerType 32
83 , G.parameters =
84 ([ Parameter (IntegerType 32) (Name "argc") []
85 , Parameter (PointerType (PointerType (IntegerType 8) (AddrSpace 0)) (AddrSpace 0)) (Name "argv") []
86 ], False)
87 , G.name = Name "main"
88 , G.basicBlocks =
89 [ BasicBlock (UnName 0)
90 [ UnName 1 := idrCall "{runMain0}" [] ]
91 (Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [])
92 ]}
94initDefs :: String -> [Definition]
95initDefs tgt =
96 [ TypeDefinition (Name "valTy")
97 (Just $ StructureType False
98 [ IntegerType 32
99 , ArrayType 0 (PointerType valueType (AddrSpace 0))
100 ])
101 , TypeDefinition (Name "mpz")
102 (Just $ StructureType False
103 [ IntegerType 32
104 , IntegerType 32
105 , PointerType intPtr (AddrSpace 0)
106 ])
107 , GlobalDefinition $ globalVariableDefaults
108 { G.name = Name "__idris_intFmtStr"
109 , G.linkage = L.Internal
110 , G.isConstant = True
111 , G.hasUnnamedAddr = True
112 , G.type' = ArrayType 5 (IntegerType 8)
113 , G.initializer = Just $ C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) "%lld" ++ [C.Int 8 0])
114 }
115 , rtsFun "intStr" ptrI8 [IntegerType 64]
116 [ BasicBlock (UnName 0)
117 [ UnName 1 := simpleCall "GC_malloc_atomic" [ConstantOperand (C.Int (fromInteger $ tgtWordSize tgt) 12)]
118 , UnName 2 := simpleCall "snprintf"
119 [ LocalReference (UnName 1)
120 , ConstantOperand (C.Int (fromInteger $ tgtWordSize tgt) 12)
121 , ConstantOperand $ C.GetElementPtr True (C.GlobalReference . Name $ "__idris_intFmtStr") [C.Int 32 0, C.Int 32 0]
122 , LocalReference (UnName 0)
123 ]
124 ]
125 (Do $ Ret (Just (LocalReference (UnName 1))) [])
126 ]
127 , exfun "llvm.trap" VoidType [] False
128 , exfun "snprintf" (IntegerType 32) [ptrI8, intPtr, ptrI8] True
129 , exfun "strcmp" (IntegerType 32) [ptrI8, ptrI8] False
130 , exfun "strlen" intPtr [ptrI8] False
131 , exfun "memcpy" ptrI8 [ptrI8, ptrI8, intPtr] False
132 , exfun "GC_malloc" ptrI8 [intPtr] False
133 , exfun "GC_malloc_atomic" ptrI8 [intPtr] False
134 , exfun "__gmpz_init" VoidType [pmpz] False
135 , exfun "__gmpz_init_set_str" (IntegerType 32) [pmpz, ptrI8, IntegerType 32] False
136 , exfun "__gmpz_get_str" ptrI8 [ptrI8, IntegerType 32, pmpz] False
137 , exfun "__gmpz_cmp" (IntegerType 32) [pmpz, pmpz] False
138 , GlobalDefinition mainDef
139 ] ++ map mpzBinFun ["add", "sub", "mul", "fdiv_q", "fdiv_r", "and", "ior", "xor"]
140 where
141 intPtr = IntegerType (fromInteger $ tgtWordSize tgt)
142 ptrI8 = PointerType (IntegerType 8) (AddrSpace 0)
143 pmpz = PointerType mpzTy (AddrSpace 0)
145 mpzBinFun n = exfun ("__gmpz_" ++ n) VoidType [pmpz, pmpz, pmpz] False
147 rtsFun :: String -> Type -> [Type] -> [BasicBlock] -> Definition
148 rtsFun name rty argtys def =
149 GlobalDefinition $ functionDefaults
150 { G.linkage = L.Internal
151 , G.returnType = rty
152 , G.parameters = (flip map argtys $ \ty -> Parameter ty (UnName 0) [], False)
153 , G.name = Name $ "__idris_" ++ name
154 , G.basicBlocks = def
155 }
157 exfun :: String -> Type -> [Type] -> Bool -> Definition
158 exfun name rty argtys vari =
159 GlobalDefinition $ functionDefaults
160 { G.returnType = rty
161 , G.name = Name name
162 , G.parameters = (flip map argtys $ \ty -> Parameter ty (UnName 0) [], vari)
163 }
165codegen :: String -> [SDecl] -> Module
166codegen tgt defs = Module "idris" Nothing Nothing (initDefs tgt ++ globals ++ gendefs)
167 where
168 ((gendefs, globals), _) = (runState . runWriterT) (mapM cgDef defs) 0
170valueType :: Type
171valueType = NamedTypeReference (Name "valTy")
173nullValue :: C.Constant
174nullValue = C.Null (PointerType valueType (AddrSpace 0))
176primTy :: Type -> Type
177primTy inner = StructureType False [IntegerType 8, inner]
179mpzTy :: Type
180mpzTy = NamedTypeReference (Name "mpz")
182conType :: Word64 -> Type
183conType nargs = StructureType False
184 [ IntegerType 32
185 , ArrayType nargs (PointerType valueType (AddrSpace 0))
186 ]
188type Modgen = WriterT [Definition] (State Word)
190cgDef :: SDecl -> Modgen Definition
191cgDef (SFun name argNames _ expr) = do
192 nextGlobal <- get
193 let (_, CGS { nextGlobalName = nextGlobal' }, (allocas, bbs, globals)) =
194 runRWS (do r <- cgExpr expr
195 case r of
196 Nothing -> terminate $ Unreachable []
197 Just r' -> terminate $ Ret (Just r') [])
198 (CGR arch (Name . show $ name))
199 (CGS 0 nextGlobal (Name "begin") [] (map (Just . LocalReference . Name . show) argNames) S.empty)
200 entryTerm = case bbs of
201 [] -> Do $ Ret Nothing []
202 BasicBlock n _ _:_ -> Do $ Br n []
203 tell globals
204 put nextGlobal'
205 return . GlobalDefinition $ functionDefaults
206 { G.linkage = L.Internal
207 , G.callingConvention = CC.Fast
208 , G.name = Name (show name)
209 , G.returnType = PointerType valueType (AddrSpace 0)
210 , G.parameters = (flip map argNames $ \argName ->
211 Parameter (PointerType valueType (AddrSpace 0)) (Name (show argName)) []
212 , False)
213 , G.basicBlocks =
214 BasicBlock (Name "entry")
215 (map (\(n, t) -> n := Alloca t Nothing 0 []) allocas)
216 entryTerm
217 : bbs
218 }
220type CGW = ([(Name, Type)], [BasicBlock], [Definition])
222type Env = [Maybe Operand]
224data CGS = CGS { nextName :: Word
225 , nextGlobalName :: Word
226 , currentBlockName :: Name
227 , instAccum :: [Named Instruction]
228 , lexenv :: Env
229 , foreignSyms :: Set String
230 }
232data CGR = CGR { target :: String
233 , funcName :: Name }
235type Codegen = RWS CGR CGW CGS
237getGlobalUnName :: Codegen Name
238getGlobalUnName = do
239 i <- gets nextGlobalName
240 modify $ \s -> s { nextGlobalName = 1 + i }
241 return (UnName i)
243getUnName :: Codegen Name
244getUnName = do
245 i <- gets nextName
246 modify $ \s -> s { nextName = 1 + i }
247 return (UnName i)
249getName :: String -> Codegen Name
250getName n = do
251 i <- gets nextName
252 modify $ \s -> s { nextName = 1 + i }
253 return (Name $ n ++ show i)
255alloca :: Name -> Type -> Codegen ()
256alloca n t = tell ([(n, t)], [], [])
258terminate :: Terminator -> Codegen ()
259terminate term = do
260 name <- gets currentBlockName
261 insts <- gets instAccum
262 modify $ \s -> s { instAccum = ierror "Not in a block"
263 , currentBlockName = ierror "Not in a block" }
264 tell ([], [BasicBlock name insts (Do term)], [])
266newBlock :: Name -> Codegen ()
267newBlock name = modify $ \s -> s { instAccum = []
268 , currentBlockName = name
269 }
271inst :: Instruction -> Codegen Operand
272inst i = do
273 n <- getUnName
274 modify $ \s -> s { instAccum = instAccum s ++ [n := i] }
275 return $ LocalReference n
277ninst :: String -> Instruction -> Codegen Operand
278ninst name i = do
279 n <- getName name
280 modify $ \s -> s { instAccum = instAccum s ++ [n := i] }
281 return $ LocalReference n
283inst' :: Instruction -> Codegen ()
284inst' i = modify $ \s -> s { instAccum = instAccum s ++ [Do i] }
286insts :: [Named Instruction] -> Codegen ()
287insts is = modify $ \s -> s { instAccum = instAccum s ++ is }
289var :: LVar -> Codegen (Maybe Operand)
290var (Loc level) = (!! level) <$> gets lexenv
291var (Glob n) = return . Just . ConstantOperand . C.GlobalReference . Name $ show n
293binds :: Env -> Codegen (Maybe Operand) -> Codegen (Maybe Operand)
294binds vals cg = do
295 envLen <- length <$> gets lexenv
296 modify $ \s -> s { lexenv = lexenv s ++ vals }
297 value <- cg
298 modify $ \s -> s { lexenv = take envLen $ lexenv s }
299 return value
301replaceElt :: Int -> a -> [a] -> [a]
302replaceElt _ val [] = error "replaceElt: Ran out of list"
303replaceElt 0 val (x:xs) = val:xs
304replaceElt n val (x:xs) = x : replaceElt (n-1) val xs
306alloc' :: Operand -> Codegen Operand
307alloc' size = inst $ simpleCall "GC_malloc" [size]
309allocAtomic :: Operand -> Codegen Operand
310allocAtomic size = inst $ simpleCall "GC_malloc_atomic" [size]
312alloc :: Type -> Codegen Operand
313alloc ty = do
314 size <- sizeOf ty
315 mem <- alloc' size
316 inst $ BitCast mem (PointerType ty (AddrSpace 0)) []
318sizeOf :: Type -> Codegen Operand
319sizeOf ty = ConstantOperand . C.PtrToInt
320 (C.GetElementPtr True (C.Null (PointerType ty (AddrSpace 0))) [C.Int 32 1])
321 . IntegerType . fromIntegral <$> wordSize
323tgtWordSize :: String -> Integer
324tgtWordSize tgt = case tgt of
325 "x86_64" -> 64
326 "i386" -> 32
328wordSize :: Codegen Integer
329wordSize = tgtWordSize <$> asks target
331cgExpr :: SExp -> Codegen (Maybe Operand)
332cgExpr (SV v) = var v
333cgExpr (SApp tailcall fname args) = do
334 argSlots <- mapM var args
335 case sequence argSlots of
336 Nothing -> return Nothing
337 Just argVals -> do
338 fn <- var (Glob fname)
339 Just <$> inst
340 Call { isTailCall = tailcall
341 , callingConvention = CC.Fast
342 , returnAttributes = []
343 , function = Right . ConstantOperand . C.GlobalReference . Name $ show fname
344 , arguments = map (\v -> (v, [])) argVals
345 , functionAttributes = []
346 , metadata = []
347 }
348cgExpr (SLet _ varExpr bodyExpr) = do
349 val <- cgExpr varExpr
350 binds [val] $ cgExpr bodyExpr
351cgExpr (SUpdate (Loc level) expr) = do
352 val <- cgExpr expr
353 modify $ \s -> s { lexenv = replaceElt level val (lexenv s) }
354 return val
355cgExpr (SCon tag name args) = do
356 argSlots <- mapM var args
357 case sequence argSlots of
358 Nothing -> return Nothing
359 Just argVals -> do
360 con <- alloc . conType . fromIntegral . length $ argVals
361 tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []
362 inst' $ Store False tagPtr (ConstantOperand (C.Int 32 (fromIntegral tag))) Nothing 0 []
363 forM_ (zip argVals [0..]) $ \(arg, i) -> do
364 ptr <- inst $ GetElementPtr True con [ ConstantOperand (C.Int 32 0)
365 , ConstantOperand (C.Int 32 1)
366 , ConstantOperand (C.Int 32 i)] []
367 inst' $ Store False ptr arg Nothing 0 []
368 Just <$> inst (BitCast con (PointerType valueType (AddrSpace 0)) [])
369cgExpr (SCase inspect alts) = do
370 val <- var inspect
371 case val of
372 Nothing -> return Nothing
373 Just v -> cgCase v alts
374cgExpr (SChkCase inspect alts) = do
375 mval <- var inspect
376 case mval of
377 Nothing -> return Nothing
378 Just val ->
379 do endBBN <- getName "endChkCase"
380 notNullBBN <- getName "notNull"
381 originBlock <- gets currentBlockName
382 isNull <- inst $ ICmp IPred.EQ val (ConstantOperand nullValue) []
383 terminate $ CondBr isNull endBBN notNullBBN []
384 newBlock notNullBBN
385 ptr <- inst $ BitCast val (PointerType (IntegerType 8) (AddrSpace 0)) []
386 flag <- inst $ Load False ptr Nothing 0 []
387 isVal <- inst $ ICmp IPred.EQ flag (ConstantOperand (C.Int 8 (-1))) []
388 conBBN <- getName "constructor"
389 terminate $ CondBr isVal endBBN conBBN []
390 newBlock conBBN
391 result <- cgCase val alts
392 caseExitBlock <- gets currentBlockName
393 case result of
394 Nothing -> do
395 terminate $ Unreachable []
396 newBlock endBBN
397 return $ Just val
398 Just caseVal -> do
399 terminate $ Br endBBN []
400 newBlock endBBN
401 Just <$> inst (Phi (PointerType valueType (AddrSpace 0))
402 [(val, originBlock), (val, notNullBBN), (caseVal, caseExitBlock)] [])
403cgExpr (SProj conVar idx) = do
404 val <- var conVar
405 case val of
406 Nothing -> return Nothing
407 Just v ->
408 do ptr <- inst $ GetElementPtr True v
409 [ ConstantOperand (C.Int 32 0)
410 , ConstantOperand (C.Int 32 1)
411 , ConstantOperand (C.Int 32 (fromIntegral idx))
412 ] []
413 Just <$> inst (Load False ptr Nothing 0 [])
414cgExpr (SConst c) = Just <$> cgConst c
415cgExpr (SForeign LANG_C rty fname args) = do
416 func <- ensureCDecl fname rty (map fst args)
417 argVals <- forM args $ \(fty, v) -> do
418 v' <- var v
419 case v' of
420 Just val -> return $ Just (fty, val)
421 Nothing -> return Nothing
422 case sequence argVals of
423 Nothing -> return Nothing
424 Just argVals' -> do
425 argUVals <- mapM (uncurry unbox) argVals'
426 result <- inst Call { isTailCall = False
427 , callingConvention = CC.C
428 , returnAttributes = []
429 , function = Right func
430 , arguments = map (\v -> (v, [])) argUVals
431 , functionAttributes = []
432 , metadata = []
433 }
434 Just <$> box rty result
435cgExpr (SOp fn args) = do
436 argVals <- mapM var args
437 case sequence argVals of
438 Just ops -> Just <$> cgOp fn ops
439 Nothing -> return Nothing
440cgExpr SNothing = return . Just . ConstantOperand $ nullValue
441cgExpr (SError msg) = do -- TODO: Print message
442 str <- addGlobal' (ArrayType (2 + fromIntegral (length msg)) (IntegerType 8))
443 (cgConst' (TT.Str (msg ++ "\n")))
444 inst' $ simpleCall "putStr" [ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0
445 , C.Int 32 0]]
446 inst' Call { isTailCall = True
447 , callingConvention = CC.C
448 , returnAttributes = []
449 , function = Right . ConstantOperand . C.GlobalReference . Name $ "llvm.trap"
450 , arguments = []
451 , functionAttributes = [A.NoReturn]
452 , metadata = []
453 }
454 return Nothing
456cgCase :: Operand -> [SAlt] -> Codegen (Maybe Operand)
457cgCase val alts =
458 case find isConstCase alts of
459 Just (SConstCase (TT.BI _) _) -> cgChainCase val defExp constAlts
460 Just (SConstCase (TT.Str _) _) -> cgChainCase val defExp constAlts
461 Just (SConstCase _ _) -> cgPrimCase val defExp constAlts
462 Nothing -> cgConCase val defExp conAlts
463 where
464 defExp = getDefExp =<< find isDefCase alts
465 constAlts = filter isConstCase alts
466 conAlts = filter isConCase alts
468 isConstCase (SConstCase {}) = True
469 isConstCase _ = False
471 isConCase (SConCase {}) = True
472 isConCase _ = False
474 isDefCase (SDefaultCase _) = True
475 isDefCase _ = False
477 getDefExp (SDefaultCase e) = Just e
478 getDefExp _ = Nothing
480cgPrimCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
481cgPrimCase caseValPtr defExp alts = do
482 let caseTy = case head alts of
483 SConstCase (TT.I _) _ -> IntegerType 32
484 SConstCase (TT.B8 _) _ -> IntegerType 8
485 SConstCase (TT.B16 _) _ -> IntegerType 16
486 SConstCase (TT.B32 _) _ -> IntegerType 32
487 SConstCase (TT.B64 _) _ -> IntegerType 64
488 SConstCase (TT.Fl _) _ -> FloatingPointType 64 IEEE
489 SConstCase (TT.Ch _) _ -> IntegerType 32
490 realPtr <- inst $ BitCast caseValPtr (PointerType (primTy caseTy) (AddrSpace 0)) []
491 valPtr <- inst $ GetElementPtr True realPtr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
492 caseVal <- inst $ Load False valPtr Nothing 0 []
493 defBlockName <- getName "default"
494 exitBlockName <- getName "caseExit"
495 namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
496 terminate $ Switch caseVal defBlockName (map (\(n, SConstCase c _) -> (cgConst' c, n)) namedAlts) []
497 initEnv <- gets lexenv
498 defResult <- cgDefaultAlt exitBlockName defBlockName defExp
499 results <- forM namedAlts $ \(name, SConstCase _ exp) -> cgAlt initEnv exitBlockName name Nothing exp
500 finishCase initEnv exitBlockName (defResult:results)
502cgConCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
503cgConCase con defExp alts = do
504 tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []
505 tag <- inst $ Load False tagPtr Nothing 0 []
506 defBlockName <- getName "default"
507 exitBlockName <- getName "caseExit"
508 namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
509 terminate $ Switch tag defBlockName (map (\(n, SConCase _ tag _ _ _) ->
510 (C.Int 32 (fromIntegral tag), n)) namedAlts) []
511 initEnv <- gets lexenv
512 defResult <- cgDefaultAlt exitBlockName defBlockName defExp
513 results <- forM namedAlts $ \(name, SConCase _ _ _ argns exp) ->
514 cgAlt initEnv exitBlockName name (Just (con, map show argns)) exp
515 finishCase initEnv exitBlockName (defResult:results)
517cgChainCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
518cgChainCase caseValPtr defExp alts = do
519 (caseTy, comparator, caseVal) <-
520 case head alts of
521 SConstCase (TT.BI _) _ -> do
522 realPtr <- inst $ BitCast caseValPtr (PointerType (primTy mpzTy) (AddrSpace 0)) []
523 valPtr <- inst $ GetElementPtr True realPtr [ ConstantOperand (C.Int 32 0)
524 , ConstantOperand (C.Int 32 1)] []
525 return (mpzTy, "__gmpz_cmp", valPtr)
526 SConstCase (TT.Str _) _ -> do
527 let caseTy = PointerType (IntegerType 8) (AddrSpace 0)
528 realPtr <- inst $ BitCast caseValPtr (PointerType (primTy caseTy) (AddrSpace 0)) []
529 valPtr <- inst $ GetElementPtr True realPtr [ ConstantOperand (C.Int 32 0)
530 , ConstantOperand (C.Int 32 1)] []
531 strPtr <- inst $ Load False valPtr Nothing 0 []
532 return (caseTy, "strcmp", strPtr)
533 defBlockName <- getName "default"
534 exitBlockName <- getName "caseExit"
535 namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
536 initEnv <- gets lexenv
537 results <- forM namedAlts $ \(name, SConstCase c e) ->
538 do const <- cgConst c
539 cmp <- inst $ simpleCall comparator [const, caseVal]
540 cmpResult <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) []
541 elseName <- getName "else"
542 terminate $ CondBr cmpResult name elseName []
543 result <- cgAlt initEnv exitBlockName name Nothing e
544 newBlock elseName
545 return result
546 modify $ \s -> s { lexenv = initEnv }
547 defaultVal <- cgExpr (fromMaybe (SError "Inexhaustive case failure") defExp)
548 defaultBlock <- gets currentBlockName
549 defaultEnv <- gets lexenv
550 defResult <- case defaultVal of
551 Just v -> do
552 terminate $ Br exitBlockName []
553 return $ Just (v, defaultBlock, defaultEnv)
554 Nothing -> do
555 terminate $ Unreachable []
556 return Nothing
557 finishCase initEnv exitBlockName (defResult:results)
559finishCase :: Env -> Name -> [Maybe (Operand, Name, Env)] -> Codegen (Maybe Operand)
560finishCase initEnv exitBlockName results = do
561 let definedResults = mapMaybe id results
562 case definedResults of
563 [] -> do modify $ \s -> s { lexenv = initEnv }
564 return Nothing
565 xs -> do
566 newBlock exitBlockName
567 mergeEnvs $ map (\(_, altBlock, altEnv) -> (altBlock, altEnv)) xs
568 Just <$> inst (Phi (PointerType valueType (AddrSpace 0))
569 (map (\(altVal, altBlock, _) -> (altVal, altBlock)) xs) [])
572cgDefaultAlt :: Name -> Name -> Maybe SExp -> Codegen (Maybe (Operand, Name, Env))
573cgDefaultAlt exitName name exp = do
574 newBlock name
575 val <- cgExpr (fromMaybe (SError "Inexhaustive case failure") exp)
576 env <- gets lexenv
577 block <- gets currentBlockName
578 case val of
579 Just v ->
580 do terminate $ Br exitName []
581 return $ Just (v, block, env)
582 Nothing ->
583 do terminate $ Unreachable []
584 return Nothing
586cgAlt :: Env -> Name -> Name -> Maybe (Operand, [String]) -> SExp
587 -> Codegen (Maybe (Operand, Name, Env))
588cgAlt initEnv exitBlockName name destr exp = do
589 modify $ \s -> s { lexenv = initEnv }
590 newBlock name
591 locals <- case destr of
592 Nothing -> return []
593 Just (con, argns) ->
594 forM (zip argns [0..]) $ \(argName, i) ->
595 do ptr <- inst $ GetElementPtr True con [ ConstantOperand (C.Int 32 0)
596 , ConstantOperand (C.Int 32 1)
597 , ConstantOperand (C.Int 32 i)] []
598 Just <$> ninst argName (Load False ptr Nothing 0 [])
599 altVal <- binds locals $ cgExpr exp
600 altEnv <- gets lexenv
601 altBlock <- gets currentBlockName
602 case altVal of
603 Just v -> do
604 terminate $ Br exitBlockName []
605 return $ Just (v, altBlock, altEnv)
606 Nothing -> do
607 terminate $ Unreachable []
608 return Nothing
610mergeEnvs :: [(Name, Env)] -> Codegen ()
611mergeEnvs es = do
612 let vars = transpose
613 . map (\(block, env) -> map (\x -> (x, block)) env)
614 $ es
615 env <- forM vars $ \var ->
616 case var of
617 [] -> ierror "mergeEnvs: impossible"
618 [(v, _)] -> return v
619 vs@((v, _):_)
620 | all (== v) (map fst vs) -> return v
621 | otherwise ->
622 let valid = map (\(a, b) -> (fromJust a, b)) . filter (isJust . fst) $ vs in
623 Just <$> inst (Phi (PointerType valueType (AddrSpace 0)) valid [])
624 modify $ \s -> s { lexenv = env }
626nameAlt :: Name -> SAlt -> Codegen Name
627nameAlt d (SDefaultCase _) = return d
628nameAlt _ (SConCase _ _ name _ _) = getName (show name)
629nameAlt _ (SConstCase const _) = getName (show const)
631box :: FType -> Operand -> Codegen Operand
632box FUnit _ = return $ ConstantOperand nullValue
633box fty fval = do
634 val <- alloc (primTy (ftyToTy fty))
635 tagptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []
636 valptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
637 inst' $ Store False tagptr (ConstantOperand (C.Int 8 (-1))) Nothing 0 []
638 inst' $ Store False valptr fval Nothing 0 []
639 inst $ BitCast val (PointerType valueType (AddrSpace 0)) []
641unbox :: FType -> Operand -> Codegen Operand
642unbox FUnit x = return x
643unbox fty bval = do
644 val <- inst $ BitCast bval (PointerType (primTy (ftyToTy fty)) (AddrSpace 0)) []
645 fvalptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
646 inst $ Load False fvalptr Nothing 0 []
648cgConst' :: TT.Const -> C.Constant
649cgConst' (TT.I i) = C.Int 32 (fromIntegral i)
650cgConst' (TT.B8 i) = C.Int 8 (fromIntegral i)
651cgConst' (TT.B16 i) = C.Int 16 (fromIntegral i)
652cgConst' (TT.B32 i) = C.Int 32 (fromIntegral i)
653cgConst' (TT.B64 i) = C.Int 64 (fromIntegral i)
654cgConst' (TT.BI i) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) (show i) ++ [C.Int 8 0])
655cgConst' (TT.Fl f) = C.Float (F.Double f)
656cgConst' (TT.Ch c) = C.Int 32 . fromIntegral . fromEnum $ c
657cgConst' (TT.Str s) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) s ++ [C.Int 8 0])
658cgConst' x = ierror $ "Unsupported constant: " ++ show x
660cgConst :: TT.Const -> Codegen Operand
661cgConst c@(TT.I _) = box (FInt ITNative) (ConstantOperand $ cgConst' c)
662cgConst c@(TT.B8 _) = box (FInt IT8) (ConstantOperand $ cgConst' c)
663cgConst c@(TT.B16 _) = box (FInt IT16) (ConstantOperand $ cgConst' c)
664cgConst c@(TT.B32 _) = box (FInt IT32) (ConstantOperand $ cgConst' c)
665cgConst c@(TT.B64 _) = box (FInt IT64) (ConstantOperand $ cgConst' c)
666cgConst c@(TT.Fl _) = box FDouble (ConstantOperand $ cgConst' c)
667cgConst c@(TT.Ch _) = box FChar (ConstantOperand $ cgConst' c)
668cgConst c@(TT.Str s) = do
669 str <- addGlobal' (ArrayType (1 + fromIntegral (length s)) (IntegerType 8)) (cgConst' c)
670 box FString (ConstantOperand $ C.GetElementPtr True str [C.Int 32 0, C.Int 32 0])
671cgConst c@(TT.BI i) = do
672 str <- addGlobal' (ArrayType (1 + fromInteger (numDigits 10 i)) (IntegerType 8)) (cgConst' c)
673 mpz <- alloc mpzTy
674 inst $ simpleCall "__gmpz_init_set_str" [mpz
675 , ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0, C.Int 32 0]
676 , ConstantOperand $ C.Int 32 10
677 ]
678 box (FInt ITBig) mpz
679cgConst x = return $ ConstantOperand nullValue
681numDigits :: Integer -> Integer -> Integer
682numDigits b n = 1 + fst (ilog b n) where
683 ilog b n
684 | n < b = (0, n)
685 | otherwise = let (e, r) = ilog (b*b) n
686 in if r < b then (2*e, r) else (2*e+1, r `div` b)
688addGlobal :: Global -> Codegen ()
689addGlobal def = tell ([], [], [GlobalDefinition def])
691addGlobal' :: Type -> C.Constant -> Codegen C.Constant
692addGlobal' ty val = do
693 name <- getGlobalUnName
694 addGlobal $ globalVariableDefaults
695 { G.name = name
696 , G.linkage = L.Internal
697 , G.hasUnnamedAddr = True
698 , G.isConstant = True
699 , G.type' = ty
700 , G.initializer = Just val
701 }
702 return . C.GlobalReference $ name
705ensureCDecl :: String -> FType -> [FType] -> Codegen Operand
706ensureCDecl name rty argtys = do
707 syms <- gets foreignSyms
708 unless (S.member name syms) $
709 do addGlobal (ffunDecl name rty argtys)
710 modify $ \s -> s { foreignSyms = S.insert name (foreignSyms s) }
711 return $ ConstantOperand (C.GlobalReference (Name name))
713ffunDecl :: String -> FType -> [FType] -> Global
714ffunDecl name rty argtys =
715 functionDefaults
716 { G.returnType = ftyToTy rty
717 , G.name = Name name
718 , G.parameters = (flip map argtys $ \fty ->
719 Parameter (ftyToTy fty) (UnName 0) []
720 , False)
721 }
723ftyToTy :: FType -> Type
724ftyToTy (FInt ITNative) = IntegerType 32
725ftyToTy (FInt ITBig) = PointerType mpzTy (AddrSpace 0)
726ftyToTy (FInt ty) = IntegerType (fromIntegral (intTyWidth ty))
727ftyToTy FChar = IntegerType 32
728ftyToTy FString = PointerType (IntegerType 8) (AddrSpace 0)
729ftyToTy FUnit = VoidType
730ftyToTy FPtr = PointerType (IntegerType 8) (AddrSpace 0)
731ftyToTy FDouble = FloatingPointType 64 IEEE
732ftyToTy FAny = valueType
734cgOp :: PrimFn -> [Operand] -> Codegen Operand
735cgOp (LLt ITBig) [x,y] = mpzCmp IPred.SLT x y
736cgOp (LLe ITBig) [x,y] = mpzCmp IPred.SLE x y
737cgOp (LEq ITBig) [x,y] = mpzCmp IPred.EQ x y
738cgOp (LGe ITBig) [x,y] = mpzCmp IPred.SGE x y
739cgOp (LGt ITBig) [x,y] = mpzCmp IPred.SGT x y
740cgOp (LPlus ITBig) [x,y] = mpzBin "add" x y
741cgOp (LMinus ITBig) [x,y] = mpzBin "sub" x y
742cgOp (LTimes ITBig) [x,y] = mpzBin "mul" x y
743cgOp (LSDiv ITBig) [x,y] = mpzBin "fdiv_q" x y
744cgOp (LSRem ITBig) [x,y] = mpzBin "fdiv_r" x y
745cgOp (LAnd ITBig) [x,y] = mpzBin "and" x y
746cgOp (LOr ITBig) [x,y] = mpzBin "ior" x y
747cgOp (LXOr ITBig) [x,y] = mpzBin "xor" x y
749cgOp (LPlus ity) [x,y] = ibin ity x y (Add False False)
750cgOp (LMinus ity) [x,y] = ibin ity x y (Sub False False)
751cgOp (LTimes ity) [x,y] = ibin ity x y (Mul False False)
752cgOp (LUDiv ity) [x,y] = ibin ity x y (UDiv True)
753cgOp (LURem ity) [x,y] = ibin ity x y URem
754cgOp (LSDiv ity) [x,y] = ibin ity x y (SDiv True)
755cgOp (LSRem ity) [x,y] = ibin ity x y SRem
756cgOp (LAnd ity) [x,y] = ibin ity x y And
757cgOp (LOr ity) [x,y] = ibin ity x y Or
758cgOp (LXOr ity) [x,y] = ibin ity x y Xor
760cgOp (LIntStr ITBig) [x] = do
761 x' <- unbox (FInt ITBig) x
762 ustr <- inst $ simpleCall "__gmpz_get_str"
763 [ ConstantOperand (C.Null (PointerType (IntegerType 8) (AddrSpace 0)))
764 , ConstantOperand (C.Int 32 10)
765 , x'
766 ]
767 box FString ustr
768cgOp (LIntStr ity) [x] = do
769 x' <- unbox (FInt ity) x
770 x'' <- if ity == ITNative || intTyWidth ity < 64
771 then inst $ SExt x' (IntegerType 64) []
772 else return x'
773 box FString =<< inst (idrCall "__idris_intStr" [x''])
775cgOp LStrConcat [x,y] = cgStrCat x y
776cgOp prim args = ierror $ "Unimplemented primitive: [" ++ show prim ++ "]("
777 ++ intersperse ',' (take (length args) ['a'..]) ++ ")"
779cgStrCat :: Operand -> Operand -> Codegen Operand
780cgStrCat x y = do
781 x' <- unbox FString x
782 y' <- unbox FString y
783 xlen <- inst $ simpleCall "strlen" [x']
784 ylen <- inst $ simpleCall "strlen" [y']
785 zlen <- inst $ Add False True xlen ylen []
786 ws <- fromIntegral <$> wordSize
787 total <- inst $ Add False True zlen (ConstantOperand (C.Int ws 1)) []
788 mem <- allocAtomic total
789 inst $ simpleCall "memcpy" [mem, x', xlen]
790 i <- inst $ PtrToInt mem (IntegerType ws) []
791 offi <- inst $ Add False True i xlen []
792 offp <- inst $ IntToPtr offi (PointerType (IntegerType 8) (AddrSpace 0)) []
793 inst $ simpleCall "memcpy" [offp, y', ylen]
794 j <- inst $ PtrToInt offp (IntegerType ws) []
795 offj <- inst $ Add False True j ylen []
796 end <- inst $ IntToPtr offj (PointerType (IntegerType 8) (AddrSpace 0)) []
797 inst' $ Store False end (ConstantOperand (C.Int 8 0)) Nothing 0 []
798 box FString mem
800ibin :: IntTy -> Operand -> Operand
801 -> (Operand -> Operand -> InstructionMetadata -> Instruction) -> Codegen Operand
802ibin ity x y instCon = do
803 nx <- unbox (FInt ity) x
804 ny <- unbox (FInt ity) y
805 nr <- inst $ instCon nx ny []
806 box (FInt ity) nr
808mpzBin :: String -> Operand -> Operand -> Codegen Operand
809mpzBin name x y = do
810 nx <- unbox (FInt ITBig) x
811 ny <- unbox (FInt ITBig) y
812 nz <- alloc mpzTy
813 inst' $ simpleCall "__gmpz_init" [nz]
814 inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx, ny]
815 box (FInt ITBig) nz
817mpzCmp :: IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand
818mpzCmp pred x y = do
819 nx <- unbox (FInt ITBig) x
820 ny <- unbox (FInt ITBig) y
821 cmp <- inst $ simpleCall "__gmpz_cmp" [nx, ny]
822 result <- inst $ ICmp pred cmp (ConstantOperand (C.Int 32 0)) []
823 i <- inst $ ZExt result (IntegerType 32) []
824 box (FInt IT32) i
826simpleCall :: String -> [Operand] -> Instruction
827simpleCall name args =
828 Call { isTailCall = False
829 , callingConvention = CC.C
830 , returnAttributes = []
831 , function = Right . ConstantOperand . C.GlobalReference . Name $ name
832 , arguments = map (\x -> (x, [])) args
833 , functionAttributes = []
834 , metadata = []
835 }
837idrCall :: String -> [Operand] -> Instruction
838idrCall name args =
839 Call { isTailCall = False
840 , callingConvention = CC.Fast
841 , returnAttributes = []
842 , function = Right . ConstantOperand . C.GlobalReference . Name $ name
843 , arguments = map (\x -> (x, [])) args
844 , functionAttributes = []
845 , metadata = []
846 }