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