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