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