git.iko.soy/Idris-dev
on f553076 help sign in
Idris-dev/src/IRTS/CodegenLLVM.hs
777 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 case result of
343 Nothing -> do
344 terminate $ Unreachable []
345 newBlock valBBN
346 return $ Just val
347 Just r -> do
348 terminate $ Br valBBN []
349 newBlock valBBN
350 Just <$> (inst $ Phi (PointerType valueType (AddrSpace 0))
351 [(val, originBlock), (r, conBBN)] [])
352cgExpr (SProj conVar idx) = do
353 val <- var conVar
354 case val of
355 Nothing -> return Nothing
356 Just v ->
357 do ptr <- inst $ GetElementPtr True v
358 [ ConstantOperand (C.Int 32 0)
359 , ConstantOperand (C.Int 32 1)
360 , ConstantOperand (C.Int 32 (fromIntegral idx))
361 ] []
362 Just <$> (inst $ Load False ptr Nothing 0 [])
363cgExpr (SConst c) = Just <$> cgConst c
364cgExpr (SForeign LANG_C rty fname args) = do
365 func <- ensureCDecl fname rty (map fst args)
366 argVals <- forM args $ \(fty, v) -> do
367 v' <- var v
368 case v' of
369 Just val -> return $ Just (fty, val)
370 Nothing -> return Nothing
371 case sequence argVals of
372 Nothing -> return Nothing
373 Just argVals' -> do
374 argUVals <- mapM (uncurry unbox) argVals'
375 result <- inst $ Call { isTailCall = False
376 , callingConvention = CC.C
377 , returnAttributes = []
378 , function = Right func
379 , arguments = map (\v -> (v, [])) argUVals
380 , functionAttributes = []
381 , metadata = []
382 }
383 Just <$> box rty result
384cgExpr (SOp fn args) = do
385 argVals <- mapM var args
386 case sequence argVals of
387 Just ops -> Just <$> cgOp fn ops
388 Nothing -> return Nothing
389cgExpr SNothing = return . Just . ConstantOperand $ nullValue
390cgExpr (SError msg) = do -- TODO: Print message
391 str <- addGlobal' (ArrayType (2 + fromIntegral (length msg)) (IntegerType 8))
392 (cgConst' (TT.Str (msg ++ "\n")))
393 inst' $ simpleCall "putStr" [ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0
394 , C.Int 32 0]]
395 inst' $ Call { isTailCall = True
396 , callingConvention = CC.C
397 , returnAttributes = []
398 , function = Right . ConstantOperand . C.GlobalReference . Name $ "llvm.trap"
399 , arguments = []
400 , functionAttributes = [A.NoReturn]
401 , metadata = []
402 }
403 return Nothing
405cgCase :: Operand -> [SAlt] -> Codegen (Maybe Operand)
406cgCase val alts =
407 case find isConstCase alts of
408 Just (SConstCase (TT.BI _) _) -> cgChainCase val defExp constAlts
409 Just (SConstCase (TT.Str _) _) -> cgChainCase val defExp constAlts
410 Just (SConstCase _ _) -> cgPrimCase val defExp constAlts
411 Nothing -> cgConCase val defExp conAlts
412 where
413 defExp = getDefExp =<< find isDefCase alts
414 constAlts = filter isConstCase alts
415 conAlts = filter isConCase alts
417 isConstCase (SConstCase _ _) = True
418 isConstCase _ = False
420 isConCase (SConCase _ _ _ _ _) = True
421 isConCase _ = False
423 isDefCase (SDefaultCase _) = True
424 isDefCase _ = False
426 getDefExp (SDefaultCase e) = Just e
427 getDefExp _ = Nothing
429cgPrimCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
430cgPrimCase caseValPtr defExp alts = do
431 let caseTy = case head alts of
432 SConstCase (TT.I _) _ -> IntegerType 32
433 SConstCase (TT.B8 _) _ -> IntegerType 8
434 SConstCase (TT.B16 _) _ -> IntegerType 16
435 SConstCase (TT.B32 _) _ -> IntegerType 32
436 SConstCase (TT.B64 _) _ -> IntegerType 64
437 SConstCase (TT.Fl _) _ -> FloatingPointType 64 IEEE
438 SConstCase (TT.Ch _) _ -> IntegerType 32
439 realPtr <- inst $ BitCast caseValPtr (PointerType (primTy caseTy) (AddrSpace 0)) []
440 valPtr <- inst $ GetElementPtr True realPtr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
441 caseVal <- inst $ Load False valPtr Nothing 0 []
442 defBlockName <- getName "default"
443 exitBlockName <- getName "caseExit"
444 namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
445 terminate $ Switch caseVal defBlockName (map (\(n, SConstCase c _) -> (cgConst' c, n)) namedAlts) []
446 initEnv <- gets lexenv
447 defResult <- cgDefaultAlt exitBlockName defBlockName defExp
448 results <- forM namedAlts $ \(name, SConstCase _ exp) -> cgAlt initEnv exitBlockName name Nothing exp
449 finishCase initEnv exitBlockName (defResult:results)
451cgConCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
452cgConCase con defExp alts = do
453 tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []
454 tag <- inst $ Load False tagPtr Nothing 0 []
455 defBlockName <- getName "default"
456 exitBlockName <- getName "caseExit"
457 namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
458 terminate $ Switch tag defBlockName (map (\(n, SConCase _ tag _ _ _) ->
459 (C.Int 32 (fromIntegral tag), n)) namedAlts) []
460 initEnv <- gets lexenv
461 defResult <- cgDefaultAlt exitBlockName defBlockName defExp
462 results <- forM namedAlts $ \(name, SConCase _ _ _ argns exp) ->
463 cgAlt initEnv exitBlockName name (Just (con, (map show argns))) exp
464 finishCase initEnv exitBlockName (defResult:results)
466cgChainCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
467cgChainCase caseValPtr defExp alts = do
468 (caseTy, comparator, caseVal) <-
469 case head alts of
470 SConstCase (TT.BI _) _ -> do
471 realPtr <- inst $ BitCast caseValPtr (PointerType (primTy mpzTy) (AddrSpace 0)) []
472 valPtr <- inst $ GetElementPtr True realPtr [ ConstantOperand (C.Int 32 0)
473 , ConstantOperand (C.Int 32 1)] []
474 return (mpzTy, "__gmpz_cmp", valPtr)
475 SConstCase (TT.Str _) _ -> do
476 let caseTy = PointerType (IntegerType 8) (AddrSpace 0)
477 realPtr <- inst $ BitCast caseValPtr (PointerType (primTy caseTy) (AddrSpace 0)) []
478 valPtr <- inst $ GetElementPtr True realPtr [ ConstantOperand (C.Int 32 0)
479 , ConstantOperand (C.Int 32 1)] []
480 strPtr <- inst $ Load False valPtr Nothing 0 []
481 return (caseTy, "strcmp", strPtr)
482 defBlockName <- getName "default"
483 exitBlockName <- getName "caseExit"
484 namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
485 initEnv <- gets lexenv
486 results <- forM namedAlts $ \(name, SConstCase c e) ->
487 do const <- cgConst c
488 cmp <- inst $ simpleCall comparator [const, caseVal]
489 cmpResult <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) []
490 elseName <- getName "else"
491 terminate $ CondBr cmpResult name elseName []
492 result <- cgAlt initEnv exitBlockName name Nothing e
493 newBlock elseName
494 return result
495 modify $ \s -> s { lexenv = initEnv }
496 defaultVal <- cgExpr (fromMaybe (SError "Inexhaustive case failure") defExp)
497 defaultBlock <- gets currentBlockName
498 defaultEnv <- gets lexenv
499 defResult <- case defaultVal of
500 Just v -> do
501 terminate $ Br exitBlockName []
502 return $ Just (v, defaultBlock, defaultEnv)
503 Nothing -> do
504 terminate $ Unreachable []
505 return Nothing
506 finishCase initEnv exitBlockName (defResult:results)
508finishCase :: Env -> Name -> [Maybe (Operand, Name, Env)] -> Codegen (Maybe Operand)
509finishCase initEnv exitBlockName results = do
510 let definedResults = mapMaybe id results
511 case definedResults of
512 [] -> do modify $ \s -> s { lexenv = initEnv }
513 return Nothing
514 xs -> do
515 newBlock exitBlockName
516 mergeEnvs $ map (\(_, altBlock, altEnv) -> (altBlock, altEnv)) xs
517 Just <$> (inst $ Phi (PointerType valueType (AddrSpace 0))
518 (map (\(altVal, altBlock, _) -> (altVal, altBlock)) xs) [])
521cgDefaultAlt :: Name -> Name -> Maybe SExp -> Codegen (Maybe (Operand, Name, Env))
522cgDefaultAlt exitName name exp = do
523 newBlock name
524 val <- cgExpr (fromMaybe (SError "Inexhaustive case failure") exp)
525 env <- gets lexenv
526 block <- gets currentBlockName
527 case val of
528 Just v ->
529 do terminate $ Br exitName []
530 return $ Just (v, block, env)
531 Nothing ->
532 do terminate $ Unreachable []
533 return Nothing
535cgAlt :: Env -> Name -> Name -> Maybe (Operand, [String]) -> SExp
536 -> Codegen (Maybe (Operand, Name, Env))
537cgAlt initEnv exitBlockName name destr exp = do
538 modify $ \s -> s { lexenv = initEnv }
539 newBlock name
540 locals <- case destr of
541 Nothing -> return []
542 Just (con, argns) ->
543 forM (zip argns [0..]) $ \(argName, i) ->
544 do ptr <- inst $ GetElementPtr True con [ ConstantOperand (C.Int 32 0)
545 , ConstantOperand (C.Int 32 1)
546 , ConstantOperand (C.Int 32 i)] []
547 Just <$> (ninst argName $ Load False ptr Nothing 0 [])
548 altVal <- binds locals $ cgExpr exp
549 altEnv <- gets lexenv
550 altBlock <- gets currentBlockName
551 case altVal of
552 Just v -> do
553 terminate $ Br exitBlockName []
554 return $ Just (v, altBlock, altEnv)
555 Nothing -> do
556 terminate $ Unreachable []
557 return Nothing
559mergeEnvs :: [(Name, Env)] -> Codegen ()
560mergeEnvs es = do
561 let vars = transpose
562 . map (\(block, env) -> map (\x -> (x, block)) env)
563 $ es
564 env <- forM vars $ \var ->
565 case var of
566 [] -> ierror "mergeEnvs: impossible"
567 [(v, _)] -> return v
568 vs@((v, _):_)
569 | all (== v) (map fst vs) -> return v
570 | otherwise ->
571 let valid = map (\(a, b) -> (fromJust a, b)) . filter (isJust . fst) $ vs in
572 Just <$> (inst $ Phi (PointerType valueType (AddrSpace 0)) valid [])
573 modify $ \s -> s { lexenv = env }
575nameAlt :: Name -> SAlt -> Codegen Name
576nameAlt d (SDefaultCase _) = return d
577nameAlt _ (SConCase _ _ name _ _) = getName (show name)
578nameAlt _ (SConstCase const _) = getName (show const)
580box :: FType -> Operand -> Codegen Operand
581box FUnit _ = return $ ConstantOperand nullValue
582box fty fval = do
583 val <- alloc (primTy (ftyToTy fty))
584 tagptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []
585 valptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
586 inst' $ Store False tagptr (ConstantOperand (C.Int 8 (-1))) Nothing 0 []
587 inst' $ Store False valptr fval Nothing 0 []
588 inst $ BitCast val (PointerType valueType (AddrSpace 0)) []
590unbox :: FType -> Operand -> Codegen Operand
591unbox FUnit x = return x
592unbox fty bval = do
593 val <- inst $ BitCast bval (PointerType (primTy (ftyToTy fty)) (AddrSpace 0)) []
594 fvalptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
595 inst $ Load False fvalptr Nothing 0 []
597cgConst' :: TT.Const -> C.Constant
598cgConst' (TT.I i) = C.Int 32 (fromIntegral i)
599cgConst' (TT.B8 i) = C.Int 8 (fromIntegral i)
600cgConst' (TT.B16 i) = C.Int 16 (fromIntegral i)
601cgConst' (TT.B32 i) = C.Int 32 (fromIntegral i)
602cgConst' (TT.B64 i) = C.Int 64 (fromIntegral i)
603cgConst' (TT.BI i) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) (show i) ++ [C.Int 8 0])
604cgConst' (TT.Fl f) = C.Float (F.Double f)
605cgConst' (TT.Ch c) = C.Int 32 . fromIntegral . fromEnum $ c
606cgConst' (TT.Str s) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) s ++ [C.Int 8 0])
607cgConst' x = ierror $ "Unsupported constant: " ++ show x
609cgConst :: TT.Const -> Codegen Operand
610cgConst c@(TT.I _) = box (FInt ITNative) (ConstantOperand $ cgConst' c)
611cgConst c@(TT.B8 _) = box (FInt IT8) (ConstantOperand $ cgConst' c)
612cgConst c@(TT.B16 _) = box (FInt IT16) (ConstantOperand $ cgConst' c)
613cgConst c@(TT.B32 _) = box (FInt IT32) (ConstantOperand $ cgConst' c)
614cgConst c@(TT.B64 _) = box (FInt IT64) (ConstantOperand $ cgConst' c)
615cgConst c@(TT.Fl _) = box FDouble (ConstantOperand $ cgConst' c)
616cgConst c@(TT.Ch _) = box FChar (ConstantOperand $ cgConst' c)
617cgConst c@(TT.Str s) = do
618 str <- addGlobal' (ArrayType (1 + fromIntegral (length s)) (IntegerType 8)) (cgConst' c)
619 box FString (ConstantOperand $ C.GetElementPtr True str [C.Int 32 0, C.Int 32 0])
620cgConst c@(TT.BI i) = do
621 str <- addGlobal' (ArrayType (1 + fromInteger (numDigits 10 i)) (IntegerType 8)) (cgConst' c)
622 mpz <- alloc mpzTy
623 inst $ simpleCall "__gmpz_init_set_str" [mpz, ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0
624 , C.Int 32 0]]
625 box (FInt ITBig) mpz
626cgConst x = return $ ConstantOperand nullValue
628numDigits :: Integer -> Integer -> Integer
629numDigits b n = 1 + fst (ilog b n) where
630 ilog b n
631 | n < b = (0, n)
632 | otherwise = let (e, r) = ilog (b*b) n
633 in if r < b then (2*e, r) else (2*e+1, r `div` b)
635addGlobal :: Global -> Codegen ()
636addGlobal def = tell ([], [], [GlobalDefinition def])
638addGlobal' :: Type -> C.Constant -> Codegen C.Constant
639addGlobal' ty val = do
640 name <- getGlobalUnName
641 addGlobal $ globalVariableDefaults
642 { G.name = name
643 , G.linkage = L.Internal
644 , G.hasUnnamedAddr = True
645 , G.isConstant = True
646 , G.type' = ty
647 , G.initializer = Just val
648 }
649 return . C.GlobalReference $ name
652ensureCDecl :: String -> FType -> [FType] -> Codegen Operand
653ensureCDecl name rty argtys = do
654 syms <- gets foreignSyms
655 unless (S.member name syms) $
656 do addGlobal (ffunDecl name rty argtys)
657 modify $ \s -> s { foreignSyms = S.insert name (foreignSyms s) }
658 return $ ConstantOperand (C.GlobalReference (Name name))
660ffunDecl :: String -> FType -> [FType] -> Global
661ffunDecl name rty argtys =
662 functionDefaults
663 { G.returnType = ftyToTy rty
664 , G.name = Name name
665 , G.parameters = (flip map argtys $ \fty ->
666 Parameter (ftyToTy fty) (UnName 0) []
667 , False)
668 }
670ftyToTy :: FType -> Type
671ftyToTy (FInt ITNative) = IntegerType 32
672ftyToTy (FInt ITBig) = PointerType mpzTy (AddrSpace 0)
673ftyToTy (FInt ty) = IntegerType (fromIntegral (intTyWidth ty))
674ftyToTy FChar = IntegerType 32
675ftyToTy FString = PointerType (IntegerType 8) (AddrSpace 0)
676ftyToTy FUnit = VoidType
677ftyToTy FPtr = PointerType (IntegerType 8) (AddrSpace 0)
678ftyToTy FDouble = FloatingPointType 64 IEEE
679ftyToTy FAny = valueType
681cgOp :: PrimFn -> [Operand] -> Codegen Operand
682cgOp (LPlus ITBig) [x,y] = mpzBin "__gmpz_add" x y
683cgOp (LMinus ITBig) [x,y] = mpzBin "__gmpz_sub" x y
684cgOp (LTimes ITBig) [x,y] = mpzBin "__gmpz_mul" x y
685cgOp (LSDiv ITBig) [x,y] = mpzBin "__gmpz_fdiv_q" x y
686cgOp (LSRem ITBig) [x,y] = mpzBin "__gmpz_fdiv_r" x y
687cgOp (LAnd ITBig) [x,y] = mpzBin "__gmpz_and" x y
688cgOp (LOr ITBig) [x,y] = mpzBin "__gmpz_ior" x y
689cgOp (LXOr ITBig) [x,y] = mpzBin "__gmpz_xor" x y
691cgOp (LPlus ity) [x,y] = ibin ity x y (Add False False)
692cgOp (LMinus ity) [x,y] = ibin ity x y (Sub False False)
693cgOp (LTimes ity) [x,y] = ibin ity x y (Mul False False)
694cgOp (LUDiv ity) [x,y] = ibin ity x y (UDiv True)
695cgOp (LURem ity) [x,y] = ibin ity x y URem
696cgOp (LSDiv ity) [x,y] = ibin ity x y (SDiv True)
697cgOp (LSRem ity) [x,y] = ibin ity x y SRem
698cgOp (LAnd ity) [x,y] = ibin ity x y And
699cgOp (LOr ity) [x,y] = ibin ity x y Or
700cgOp (LXOr ity) [x,y] = ibin ity x y Xor
702cgOp (LIntStr ITBig) [x] = do
703 x' <- unbox (FInt ITBig) x
704 ustr <- inst $ simpleCall "__gmpz_get_str"
705 [ ConstantOperand (C.Null (PointerType (IntegerType 8) (AddrSpace 0)))
706 , ConstantOperand (C.Int 32 10), x']
707 box FString ustr
708cgOp (LIntStr ity) [x] = do
709 x' <- unbox (FInt ity) x
710 x'' <- if ity == ITNative || intTyWidth ity < 64
711 then inst $ SExt x' (IntegerType 64) []
712 else return x'
713 box FString =<< inst (rtsCall "intStr" [x''])
715cgOp LStrConcat [x,y] = cgStrCat x y
716cgOp prim args = ierror $ "Unimplemented primitive: [" ++ show prim ++ "]("
717 ++ (intersperse ',' $ take (length args) ['a'..]) ++ ")"
719cgStrCat :: Operand -> Operand -> Codegen Operand
720cgStrCat x y = do
721 x' <- unbox FString x
722 y' <- unbox FString y
723 xlen <- inst $ simpleCall "strlen" [x']
724 ylen <- inst $ simpleCall "strlen" [y']
725 zlen <- inst $ Add False True xlen ylen []
726 ws <- fromIntegral <$> wordSize
727 total <- inst $ Add False True zlen (ConstantOperand (C.Int ws 1)) []
728 mem <- allocAtomic total
729 inst $ simpleCall "memcpy" [mem, x', xlen]
730 i <- inst $ PtrToInt mem (IntegerType ws) []
731 offi <- inst $ Add False True i xlen []
732 offp <- inst $ IntToPtr offi (PointerType (IntegerType 8) (AddrSpace 0)) []
733 inst $ simpleCall "memcpy" [offp, y', ylen]
734 j <- inst $ PtrToInt offp (IntegerType ws) []
735 offj <- inst $ Add False True j ylen []
736 end <- inst $ IntToPtr offj (PointerType (IntegerType 8) (AddrSpace 0)) []
737 inst' $ Store False end (ConstantOperand (C.Int 8 0)) Nothing 0 []
738 box FString mem
740ibin :: IntTy -> Operand -> Operand
741 -> (Operand -> Operand -> InstructionMetadata -> Instruction) -> Codegen Operand
742ibin ity x y instCon = do
743 nx <- unbox (FInt ity) x
744 ny <- unbox (FInt ity) y
745 nr <- inst $ instCon nx ny []
746 box (FInt ity) nr
748mpzBin :: String -> Operand -> Operand -> Codegen Operand
749mpzBin name x y = do
750 nx <- unbox (FInt ITBig) x
751 ny <- unbox (FInt ITBig) y
752 nz <- alloc mpzTy
753 inst' $ simpleCall "__gmpz_init" [nz]
754 inst' $ simpleCall name [nz, nx, ny]
755 box (FInt ITBig) nz
757simpleCall :: String -> [Operand] -> Instruction
758simpleCall name args =
759 Call { isTailCall = False
760 , callingConvention = CC.C
761 , returnAttributes = []
762 , function = Right . ConstantOperand . C.GlobalReference . Name $ name
763 , arguments = map (\x -> (x, [])) args
764 , functionAttributes = []
765 , metadata = []
766 }
768rtsCall :: String -> [Operand] -> Instruction
769rtsCall name args =
770 Call { isTailCall = False
771 , callingConvention = CC.Fast
772 , returnAttributes = []
773 , function = Right . ConstantOperand . C.GlobalReference . Name $ "__idris_" ++ name
774 , arguments = map (\x -> (x, [])) args
775 , functionAttributes = []
776 , metadata = []
777 }