git.iko.soy/Idris-dev
on 4b2570e help sign in
Idris-dev/src/IRTS/CodegenLLVM.hs
850 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}" [] ] -- TODO: Set GMP memory functions
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 ((idrCall (show fname) argVals) { isTailCall = tailcall })
340cgExpr (SLet _ varExpr bodyExpr) = do
341 val <- cgExpr varExpr
342 binds [val] $ cgExpr bodyExpr
343cgExpr (SUpdate (Loc level) expr) = do
344 val <- cgExpr expr
345 modify $ \s -> s { lexenv = replaceElt level val (lexenv s) }
346 return val
347cgExpr (SCon tag name args) = do
348 argSlots <- mapM var args
349 case sequence argSlots of
350 Nothing -> return Nothing
351 Just argVals -> do
352 con <- alloc . conType . fromIntegral . length $ argVals
353 tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []
354 inst' $ Store False tagPtr (ConstantOperand (C.Int 32 (fromIntegral tag))) Nothing 0 []
355 forM_ (zip argVals [0..]) $ \(arg, i) -> do
356 ptr <- inst $ GetElementPtr True con [ ConstantOperand (C.Int 32 0)
357 , ConstantOperand (C.Int 32 1)
358 , ConstantOperand (C.Int 32 i)] []
359 inst' $ Store False ptr arg Nothing 0 []
360 Just <$> inst (BitCast con (PointerType valueType (AddrSpace 0)) [])
361cgExpr (SCase inspect alts) = do
362 val <- var inspect
363 case val of
364 Nothing -> return Nothing
365 Just v -> cgCase v alts
366cgExpr (SChkCase inspect alts) = do
367 mval <- var inspect
368 case mval of
369 Nothing -> return Nothing
370 Just val ->
371 do endBBN <- getName "endChkCase"
372 notNullBBN <- getName "notNull"
373 originBlock <- gets currentBlockName
374 isNull <- inst $ ICmp IPred.EQ val (ConstantOperand nullValue) []
375 terminate $ CondBr isNull endBBN notNullBBN []
376 newBlock notNullBBN
377 ptr <- inst $ BitCast val (PointerType (IntegerType 8) (AddrSpace 0)) []
378 flag <- inst $ Load False ptr Nothing 0 []
379 isVal <- inst $ ICmp IPred.EQ flag (ConstantOperand (C.Int 8 (-1))) []
380 conBBN <- getName "constructor"
381 terminate $ CondBr isVal endBBN conBBN []
382 newBlock conBBN
383 result <- cgCase val alts
384 caseExitBlock <- gets currentBlockName
385 case result of
386 Nothing -> do
387 terminate $ Unreachable []
388 newBlock endBBN
389 return $ Just val
390 Just caseVal -> do
391 terminate $ Br endBBN []
392 newBlock endBBN
393 Just <$> inst (Phi (PointerType valueType (AddrSpace 0))
394 [(val, originBlock), (val, notNullBBN), (caseVal, caseExitBlock)] [])
395cgExpr (SProj conVar idx) = do
396 val <- var conVar
397 case val of
398 Nothing -> return Nothing
399 Just v ->
400 do ptr <- inst $ GetElementPtr True v
401 [ ConstantOperand (C.Int 32 0)
402 , ConstantOperand (C.Int 32 1)
403 , ConstantOperand (C.Int 32 (fromIntegral idx))
404 ] []
405 Just <$> inst (Load False ptr Nothing 0 [])
406cgExpr (SConst c) = Just <$> cgConst c
407cgExpr (SForeign LANG_C rty fname args) = do
408 func <- ensureCDecl fname rty (map fst args)
409 argVals <- forM args $ \(fty, v) -> do
410 v' <- var v
411 case v' of
412 Just val -> return $ Just (fty, val)
413 Nothing -> return Nothing
414 case sequence argVals of
415 Nothing -> return Nothing
416 Just argVals' -> do
417 argUVals <- mapM (uncurry unbox) argVals'
418 result <- inst Call { isTailCall = False
419 , callingConvention = CC.C
420 , returnAttributes = []
421 , function = Right func
422 , arguments = map (\v -> (v, [])) argUVals
423 , functionAttributes = []
424 , metadata = []
425 }
426 Just <$> box rty result
427cgExpr (SOp fn args) = do
428 argVals <- mapM var args
429 case sequence argVals of
430 Just ops -> Just <$> cgOp fn ops
431 Nothing -> return Nothing
432cgExpr SNothing = return . Just . ConstantOperand $ nullValue
433cgExpr (SError msg) = do -- TODO: Print message
434 str <- addGlobal' (ArrayType (2 + fromIntegral (length msg)) (IntegerType 8))
435 (cgConst' (TT.Str (msg ++ "\n")))
436 inst' $ simpleCall "putStr" [ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0
437 , C.Int 32 0]]
438 inst' Call { isTailCall = True
439 , callingConvention = CC.C
440 , returnAttributes = []
441 , function = Right . ConstantOperand . C.GlobalReference . Name $ "llvm.trap"
442 , arguments = []
443 , functionAttributes = [A.NoReturn]
444 , metadata = []
445 }
446 return Nothing
448cgCase :: Operand -> [SAlt] -> Codegen (Maybe Operand)
449cgCase val alts =
450 case find isConstCase alts of
451 Just (SConstCase (TT.BI _) _) -> cgChainCase val defExp constAlts
452 Just (SConstCase (TT.Str _) _) -> cgChainCase val defExp constAlts
453 Just (SConstCase _ _) -> cgPrimCase val defExp constAlts
454 Nothing -> cgConCase val defExp conAlts
455 where
456 defExp = getDefExp =<< find isDefCase alts
457 constAlts = filter isConstCase alts
458 conAlts = filter isConCase alts
460 isConstCase (SConstCase {}) = True
461 isConstCase _ = False
463 isConCase (SConCase {}) = True
464 isConCase _ = False
466 isDefCase (SDefaultCase _) = True
467 isDefCase _ = False
469 getDefExp (SDefaultCase e) = Just e
470 getDefExp _ = Nothing
472cgPrimCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
473cgPrimCase caseValPtr defExp alts = do
474 let caseTy = case head alts of
475 SConstCase (TT.I _) _ -> IntegerType 32
476 SConstCase (TT.B8 _) _ -> IntegerType 8
477 SConstCase (TT.B16 _) _ -> IntegerType 16
478 SConstCase (TT.B32 _) _ -> IntegerType 32
479 SConstCase (TT.B64 _) _ -> IntegerType 64
480 SConstCase (TT.Fl _) _ -> FloatingPointType 64 IEEE
481 SConstCase (TT.Ch _) _ -> IntegerType 32
482 realPtr <- inst $ BitCast caseValPtr (PointerType (primTy caseTy) (AddrSpace 0)) []
483 valPtr <- inst $ GetElementPtr True realPtr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
484 caseVal <- inst $ Load False valPtr Nothing 0 []
485 defBlockName <- getName "default"
486 exitBlockName <- getName "caseExit"
487 namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
488 terminate $ Switch caseVal defBlockName (map (\(n, SConstCase c _) -> (cgConst' c, n)) namedAlts) []
489 initEnv <- gets lexenv
490 defResult <- cgDefaultAlt exitBlockName defBlockName defExp
491 results <- forM namedAlts $ \(name, SConstCase _ exp) -> cgAlt initEnv exitBlockName name Nothing exp
492 finishCase initEnv exitBlockName (defResult:results)
494cgConCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
495cgConCase con defExp alts = do
496 tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []
497 tag <- inst $ Load False tagPtr Nothing 0 []
498 defBlockName <- getName "default"
499 exitBlockName <- getName "caseExit"
500 namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
501 terminate $ Switch tag defBlockName (map (\(n, SConCase _ tag _ _ _) ->
502 (C.Int 32 (fromIntegral tag), n)) namedAlts) []
503 initEnv <- gets lexenv
504 defResult <- cgDefaultAlt exitBlockName defBlockName defExp
505 results <- forM namedAlts $ \(name, SConCase _ _ _ argns exp) ->
506 cgAlt initEnv exitBlockName name (Just (con, map show argns)) exp
507 finishCase initEnv exitBlockName (defResult:results)
509cgChainCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
510cgChainCase caseValPtr defExp alts = do
511 let (caseTy, comparator) =
512 case head alts of
513 SConstCase (TT.BI _) _ -> (FInt ITBig, "__gmpz_cmp")
514 SConstCase (TT.Str _) _ -> (FString, "strcmp")
515 caseVal <- unbox caseTy caseValPtr
516 defBlockName <- getName "default"
517 exitBlockName <- getName "caseExit"
518 namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
519 initEnv <- gets lexenv
520 results <- forM namedAlts $ \(name, SConstCase c e) ->
521 do const <- unbox caseTy =<< cgConst c
522 cmp <- inst $ simpleCall comparator [const, caseVal]
523 cmpResult <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) []
524 elseName <- getName "else"
525 terminate $ CondBr cmpResult name elseName []
526 result <- cgAlt initEnv exitBlockName name Nothing e
527 newBlock elseName
528 return result
529 modify $ \s -> s { lexenv = initEnv }
530 defaultVal <- cgExpr (fromMaybe (SError "Inexhaustive case failure") defExp)
531 defaultBlock <- gets currentBlockName
532 defaultEnv <- gets lexenv
533 defResult <- case defaultVal of
534 Just v -> do
535 terminate $ Br exitBlockName []
536 return $ Just (v, defaultBlock, defaultEnv)
537 Nothing -> do
538 terminate $ Unreachable []
539 return Nothing
540 finishCase initEnv exitBlockName (defResult:results)
542finishCase :: Env -> Name -> [Maybe (Operand, Name, Env)] -> Codegen (Maybe Operand)
543finishCase initEnv exitBlockName results = do
544 let definedResults = mapMaybe id results
545 case definedResults of
546 [] -> do modify $ \s -> s { lexenv = initEnv }
547 return Nothing
548 xs -> do
549 newBlock exitBlockName
550 mergeEnvs $ map (\(_, altBlock, altEnv) -> (altBlock, altEnv)) xs
551 Just <$> inst (Phi (PointerType valueType (AddrSpace 0))
552 (map (\(altVal, altBlock, _) -> (altVal, altBlock)) xs) [])
555cgDefaultAlt :: Name -> Name -> Maybe SExp -> Codegen (Maybe (Operand, Name, Env))
556cgDefaultAlt exitName name exp = do
557 newBlock name
558 val <- cgExpr (fromMaybe (SError "Inexhaustive case failure") exp)
559 env <- gets lexenv
560 block <- gets currentBlockName
561 case val of
562 Just v ->
563 do terminate $ Br exitName []
564 return $ Just (v, block, env)
565 Nothing ->
566 do terminate $ Unreachable []
567 return Nothing
569cgAlt :: Env -> Name -> Name -> Maybe (Operand, [String]) -> SExp
570 -> Codegen (Maybe (Operand, Name, Env))
571cgAlt initEnv exitBlockName name destr exp = do
572 modify $ \s -> s { lexenv = initEnv }
573 newBlock name
574 locals <- case destr of
575 Nothing -> return []
576 Just (con, argns) ->
577 forM (zip argns [0..]) $ \(argName, i) ->
578 do ptr <- inst $ GetElementPtr True con [ ConstantOperand (C.Int 32 0)
579 , ConstantOperand (C.Int 32 1)
580 , ConstantOperand (C.Int 32 i)] []
581 Just <$> ninst argName (Load False ptr Nothing 0 [])
582 altVal <- binds locals $ cgExpr exp
583 altEnv <- gets lexenv
584 altBlock <- gets currentBlockName
585 case altVal of
586 Just v -> do
587 terminate $ Br exitBlockName []
588 return $ Just (v, altBlock, altEnv)
589 Nothing -> do
590 terminate $ Unreachable []
591 return Nothing
593mergeEnvs :: [(Name, Env)] -> Codegen ()
594mergeEnvs es = do
595 let vars = transpose
596 . map (\(block, env) -> map (\x -> (x, block)) env)
597 $ es
598 env <- forM vars $ \var ->
599 case var of
600 [] -> ierror "mergeEnvs: impossible"
601 [(v, _)] -> return v
602 vs@((v, _):_)
603 | all (== v) (map fst vs) -> return v
604 | otherwise ->
605 let valid = map (\(a, b) -> (fromJust a, b)) . filter (isJust . fst) $ vs in
606 Just <$> inst (Phi (PointerType valueType (AddrSpace 0)) valid [])
607 modify $ \s -> s { lexenv = env }
609nameAlt :: Name -> SAlt -> Codegen Name
610nameAlt d (SDefaultCase _) = return d
611nameAlt _ (SConCase _ _ name _ _) = getName (show name)
612nameAlt _ (SConstCase const _) = getName (show const)
614box :: FType -> Operand -> Codegen Operand
615box FUnit _ = return $ ConstantOperand nullValue
616box fty fval = do
617 val <- alloc (primTy (ftyToTy fty))
618 tagptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []
619 valptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
620 inst' $ Store False tagptr (ConstantOperand (C.Int 8 (-1))) Nothing 0 []
621 inst' $ Store False valptr fval Nothing 0 []
622 inst $ BitCast val (PointerType valueType (AddrSpace 0)) []
624unbox :: FType -> Operand -> Codegen Operand
625unbox FUnit x = return x
626unbox fty bval = do
627 val <- inst $ BitCast bval (PointerType (primTy (ftyToTy fty)) (AddrSpace 0)) []
628 fvalptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
629 inst $ Load False fvalptr Nothing 0 []
631cgConst' :: TT.Const -> C.Constant
632cgConst' (TT.I i) = C.Int 32 (fromIntegral i)
633cgConst' (TT.B8 i) = C.Int 8 (fromIntegral i)
634cgConst' (TT.B16 i) = C.Int 16 (fromIntegral i)
635cgConst' (TT.B32 i) = C.Int 32 (fromIntegral i)
636cgConst' (TT.B64 i) = C.Int 64 (fromIntegral i)
637cgConst' (TT.BI i) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) (show i) ++ [C.Int 8 0])
638cgConst' (TT.Fl f) = C.Float (F.Double f)
639cgConst' (TT.Ch c) = C.Int 32 . fromIntegral . fromEnum $ c
640cgConst' (TT.Str s) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) s ++ [C.Int 8 0])
641cgConst' x = ierror $ "Unsupported constant: " ++ show x
643cgConst :: TT.Const -> Codegen Operand
644cgConst c@(TT.I _) = box (FInt ITNative) (ConstantOperand $ cgConst' c)
645cgConst c@(TT.B8 _) = box (FInt IT8) (ConstantOperand $ cgConst' c)
646cgConst c@(TT.B16 _) = box (FInt IT16) (ConstantOperand $ cgConst' c)
647cgConst c@(TT.B32 _) = box (FInt IT32) (ConstantOperand $ cgConst' c)
648cgConst c@(TT.B64 _) = box (FInt IT64) (ConstantOperand $ cgConst' c)
649cgConst c@(TT.Fl _) = box FDouble (ConstantOperand $ cgConst' c)
650cgConst c@(TT.Ch _) = box FChar (ConstantOperand $ cgConst' c)
651cgConst c@(TT.Str s) = do
652 str <- addGlobal' (ArrayType (1 + fromIntegral (length s)) (IntegerType 8)) (cgConst' c)
653 box FString (ConstantOperand $ C.GetElementPtr True str [C.Int 32 0, C.Int 32 0])
654cgConst c@(TT.BI i) = do
655 str <- addGlobal' (ArrayType (1 + fromInteger (numDigits 10 i)) (IntegerType 8)) (cgConst' c)
656 mpz <- alloc mpzTy
657 inst $ simpleCall "__gmpz_init_set_str" [mpz
658 , ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0, C.Int 32 0]
659 , ConstantOperand $ C.Int 32 10
660 ]
661 box (FInt ITBig) mpz
662cgConst x = return $ ConstantOperand nullValue
664numDigits :: Integer -> Integer -> Integer
665numDigits b n = 1 + fst (ilog b n) where
666 ilog b n
667 | n < b = (0, n)
668 | otherwise = let (e, r) = ilog (b*b) n
669 in if r < b then (2*e, r) else (2*e+1, r `div` b)
671addGlobal :: Global -> Codegen ()
672addGlobal def = tell ([], [], [GlobalDefinition def])
674addGlobal' :: Type -> C.Constant -> Codegen C.Constant
675addGlobal' ty val = do
676 name <- getGlobalUnName
677 addGlobal $ globalVariableDefaults
678 { G.name = name
679 , G.linkage = L.Internal
680 , G.hasUnnamedAddr = True
681 , G.isConstant = True
682 , G.type' = ty
683 , G.initializer = Just val
684 }
685 return . C.GlobalReference $ name
688ensureCDecl :: String -> FType -> [FType] -> Codegen Operand
689ensureCDecl name rty argtys = do
690 syms <- gets foreignSyms
691 unless (S.member name syms) $
692 do addGlobal (ffunDecl name rty argtys)
693 modify $ \s -> s { foreignSyms = S.insert name (foreignSyms s) }
694 return $ ConstantOperand (C.GlobalReference (Name name))
696ffunDecl :: String -> FType -> [FType] -> Global
697ffunDecl name rty argtys =
698 functionDefaults
699 { G.returnType = ftyToTy rty
700 , G.name = Name name
701 , G.parameters = (flip map argtys $ \fty ->
702 Parameter (ftyToTy fty) (UnName 0) []
703 , False)
704 }
706ftyToTy :: FType -> Type
707ftyToTy (FInt ITNative) = IntegerType 32
708ftyToTy (FInt ITBig) = PointerType mpzTy (AddrSpace 0)
709ftyToTy (FInt ty) = IntegerType (fromIntegral (intTyWidth ty))
710ftyToTy FChar = IntegerType 32
711ftyToTy FString = PointerType (IntegerType 8) (AddrSpace 0)
712ftyToTy FUnit = VoidType
713ftyToTy FPtr = PointerType (IntegerType 8) (AddrSpace 0)
714ftyToTy FDouble = FloatingPointType 64 IEEE
715ftyToTy FAny = valueType
717cgOp :: PrimFn -> [Operand] -> Codegen Operand
718cgOp (LLt ITBig) [x,y] = mpzCmp IPred.SLT x y
719cgOp (LLe ITBig) [x,y] = mpzCmp IPred.SLE x y
720cgOp (LEq ITBig) [x,y] = mpzCmp IPred.EQ x y
721cgOp (LGe ITBig) [x,y] = mpzCmp IPred.SGE x y
722cgOp (LGt ITBig) [x,y] = mpzCmp IPred.SGT x y
723cgOp (LPlus ITBig) [x,y] = mpzBin "add" x y
724cgOp (LMinus ITBig) [x,y] = mpzBin "sub" x y
725cgOp (LTimes ITBig) [x,y] = mpzBin "mul" x y
726cgOp (LSDiv ITBig) [x,y] = mpzBin "fdiv_q" x y
727cgOp (LSRem ITBig) [x,y] = mpzBin "fdiv_r" x y
728cgOp (LAnd ITBig) [x,y] = mpzBin "and" x y
729cgOp (LOr ITBig) [x,y] = mpzBin "ior" x y
730cgOp (LXOr ITBig) [x,y] = mpzBin "xor" x y
732cgOp (LLt ity) [x,y] = iCmp ity IPred.SLT x y
733cgOp (LLe ity) [x,y] = iCmp ity IPred.SLE x y
734cgOp (LEq ity) [x,y] = iCmp ity IPred.EQ x y
735cgOp (LGe ity) [x,y] = iCmp ity IPred.SGE x y
736cgOp (LGt ity) [x,y] = iCmp ity IPred.SGT x y
737cgOp (LPlus ity) [x,y] = ibin ity x y (Add False False)
738cgOp (LMinus ity) [x,y] = ibin ity x y (Sub False False)
739cgOp (LTimes ity) [x,y] = ibin ity x y (Mul False False)
740cgOp (LUDiv ity) [x,y] = ibin ity x y (UDiv True)
741cgOp (LURem ity) [x,y] = ibin ity x y URem
742cgOp (LSDiv ity) [x,y] = ibin ity x y (SDiv True)
743cgOp (LSRem ity) [x,y] = ibin ity x y SRem
744cgOp (LAnd ity) [x,y] = ibin ity x y And
745cgOp (LOr ity) [x,y] = ibin ity x y Or
746cgOp (LXOr ity) [x,y] = ibin ity x y Xor
748cgOp LStrEq [x,y] = do
749 x' <- unbox FString x
750 y' <- unbox FString y
751 cmp <- inst $ simpleCall "strcmp" [x', y']
752 flag <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) []
753 val <- inst $ ZExt flag (IntegerType 32) []
754 box (FInt IT32) val
756cgOp (LIntStr ITBig) [x] = do
757 x' <- unbox (FInt ITBig) x
758 ustr <- inst $ simpleCall "__gmpz_get_str"
759 [ ConstantOperand (C.Null (PointerType (IntegerType 8) (AddrSpace 0)))
760 , ConstantOperand (C.Int 32 10)
761 , x'
762 ]
763 box FString ustr
764cgOp (LIntStr ity) [x] = do
765 x' <- unbox (FInt ity) x
766 x'' <- if ity == ITNative || intTyWidth ity < 64
767 then inst $ SExt x' (IntegerType 64) []
768 else return x'
769 box FString =<< inst (idrCall "__idris_intStr" [x''])
771cgOp LStrConcat [x,y] = cgStrCat x y
772cgOp prim args = ierror $ "Unimplemented primitive: [" ++ show prim ++ "]("
773 ++ intersperse ',' (take (length args) ['a'..]) ++ ")"
775cgStrCat :: Operand -> Operand -> Codegen Operand
776cgStrCat x y = do
777 x' <- unbox FString x
778 y' <- unbox FString y
779 xlen <- inst $ simpleCall "strlen" [x']
780 ylen <- inst $ simpleCall "strlen" [y']
781 zlen <- inst $ Add False True xlen ylen []
782 ws <- fromIntegral <$> wordSize
783 total <- inst $ Add False True zlen (ConstantOperand (C.Int ws 1)) []
784 mem <- allocAtomic total
785 inst $ simpleCall "memcpy" [mem, x', xlen]
786 i <- inst $ PtrToInt mem (IntegerType ws) []
787 offi <- inst $ Add False True i xlen []
788 offp <- inst $ IntToPtr offi (PointerType (IntegerType 8) (AddrSpace 0)) []
789 inst $ simpleCall "memcpy" [offp, y', ylen]
790 j <- inst $ PtrToInt offp (IntegerType ws) []
791 offj <- inst $ Add False True j ylen []
792 end <- inst $ IntToPtr offj (PointerType (IntegerType 8) (AddrSpace 0)) []
793 inst' $ Store False end (ConstantOperand (C.Int 8 0)) Nothing 0 []
794 box FString mem
796ibin :: IntTy -> Operand -> Operand
797 -> (Operand -> Operand -> InstructionMetadata -> Instruction) -> Codegen Operand
798ibin ity x y instCon = do
799 nx <- unbox (FInt ity) x
800 ny <- unbox (FInt ity) y
801 nr <- inst $ instCon nx ny []
802 box (FInt ity) nr
804iCmp :: IntTy -> IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand
805iCmp ity pred x y = do
806 nx <- unbox (FInt ity) x
807 ny <- unbox (FInt ity) y
808 nr <- inst $ ICmp pred nx ny []
809 nr' <- inst $ ZExt nr (IntegerType . fromIntegral $ intTyWidth ity) []
810 box (FInt ity) nr'
812mpzBin :: String -> Operand -> Operand -> Codegen Operand
813mpzBin name x y = do
814 nx <- unbox (FInt ITBig) x
815 ny <- unbox (FInt ITBig) y
816 nz <- alloc mpzTy
817 inst' $ simpleCall "__gmpz_init" [nz]
818 inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx, ny]
819 box (FInt ITBig) nz
821mpzCmp :: IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand
822mpzCmp pred x y = do
823 nx <- unbox (FInt ITBig) x
824 ny <- unbox (FInt ITBig) y
825 cmp <- inst $ simpleCall "__gmpz_cmp" [nx, ny]
826 result <- inst $ ICmp pred cmp (ConstantOperand (C.Int 32 0)) []
827 i <- inst $ ZExt result (IntegerType 32) []
828 box (FInt IT32) i
830simpleCall :: String -> [Operand] -> Instruction
831simpleCall name args =
832 Call { isTailCall = False
833 , callingConvention = CC.C
834 , returnAttributes = []
835 , function = Right . ConstantOperand . C.GlobalReference . Name $ name
836 , arguments = map (\x -> (x, [])) args
837 , functionAttributes = []
838 , metadata = []
839 }
841idrCall :: String -> [Operand] -> Instruction
842idrCall name args =
843 Call { isTailCall = False
844 , callingConvention = CC.Fast
845 , returnAttributes = []
846 , function = Right . ConstantOperand . C.GlobalReference . Name $ name
847 , arguments = map (\x -> (x, [])) args
848 , functionAttributes = []
849 , metadata = []
850 }