git.iko.soy/Idris-dev
on c2efadd help sign in
Idris-dev/src/IRTS/CodegenLLVM.hs
1156 lines 47 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
8import Core.TT (ArithTy(..), IntTy(..), NativeTy(..), nativeTyWidth)
10import Util.System
11import Paths_idris
13import LLVM.General.Context
14import LLVM.General.Diagnostic
15import LLVM.General.AST
16import LLVM.General.AST.AddrSpace
17import LLVM.General.Target
18import LLVM.General.AST.DataLayout
19import LLVM.General.PassManager
20import qualified LLVM.General.Module as M
21import qualified LLVM.General.AST.IntegerPredicate as IPred
22import qualified LLVM.General.AST.Linkage as L
23import qualified LLVM.General.AST.Visibility as V
24import qualified LLVM.General.AST.CallingConvention as CC
25import qualified LLVM.General.AST.Attribute as A
26import qualified LLVM.General.AST.Global as G
27import qualified LLVM.General.AST.Constant as C
28import qualified LLVM.General.AST.Float as F
29import qualified LLVM.General.Relocation as R
30import qualified LLVM.General.CodeModel as CM
31import qualified LLVM.General.CodeGenOpt as CGO
33import Data.List
34import Data.Maybe
35import Data.Word
36import Data.Set (Set)
37import qualified Data.Set as S
38import qualified Data.Map as M
39import qualified Data.Vector.Unboxed as V
40import Control.Applicative
41import Control.Monad.RWS
42import Control.Monad.Writer
43import Control.Monad.State
44import Control.Monad.Error
46import qualified System.Info as SI (arch, os)
47import System.IO
48import System.Directory (removeFile)
49import System.FilePath ((</>))
50import System.Process (rawSystem)
51import System.Exit (ExitCode(..))
52import Debug.Trace
54data Target = Target { triple :: String, dataLayout :: DataLayout }
56codegenLLVM :: [(TT.Name, SDecl)] ->
57 String -> -- target triple
58 String -> -- target CPU
59 Int -> -- Optimization degree
60 FilePath -> -- output file name
61 OutputType ->
62 IO ()
63codegenLLVM defs triple cpu optimize file outty = withContext $ \context -> do
64 initializeAllTargets
65 (target, _) <- failInIO $ lookupTarget Nothing triple
66 withTargetOptions $ \options ->
67 withTargetMachine target triple cpu S.empty options R.Default CM.Default CGO.Default $ \tm ->
68 do layout <- getTargetMachineDataLayout tm
69 let ast = codegen (Target triple layout) (map snd defs)
70 result <- runErrorT . M.withModuleFromAST context ast $ \m ->
71 do let opts = defaultCuratedPassSetSpec
72 { optLevel = Just optimize
73 , simplifyLibCalls = Just True
74 , useInlinerWithThreshold = Just 225
75 }
76 when (optimize /= 0) $ withPassManager opts $ void . flip runPassManager m
77 outputModule tm file outty m
78 case result of
79 Right _ -> return ()
80 Left msg -> ierror msg
82failInIO :: ErrorT String IO a -> IO a
83failInIO = either fail return <=< runErrorT
85outputModule :: TargetMachine -> FilePath -> OutputType -> M.Module -> IO ()
86outputModule _ file Raw m = failInIO $ M.writeBitcodeToFile file m
87outputModule tm file Object m = failInIO $ M.writeObjectToFile tm file m
88outputModule tm file Executable m = withTmpFile $ \obj -> do
89 outputModule tm obj Object m
90 cc <- getCC
91 defs <- (</> "llvm" </> "libidris_rts.a") <$> getDataDir
92 exit <- rawSystem cc [obj, defs, "-lm", "-lgmp", "-lgc", "-o", file]
93 when (exit /= ExitSuccess) $ ierror "FAILURE: Linking"
95withTmpFile :: (FilePath -> IO a) -> IO a
96withTmpFile f = do
97 (path, handle) <- tempfile
98 hClose handle
99 result <- f path
100 removeFile path
101 return result
103ierror :: String -> a
104ierror msg = error $ "INTERNAL ERROR: IRTS.CodegenLLVM: " ++ msg
106mainDef :: Global
107mainDef =
108 functionDefaults
109 { G.returnType = IntegerType 32
110 , G.parameters =
111 ([ Parameter (IntegerType 32) (Name "argc") []
112 , Parameter (PointerType (PointerType (IntegerType 8) (AddrSpace 0)) (AddrSpace 0)) (Name "argv") []
113 ], False)
114 , G.name = Name "main"
115 , G.basicBlocks =
116 [ BasicBlock (UnName 0)
117 [ Do $ simpleCall "GC_init" [] -- Initialize Boehm GC
118 , Do $ simpleCall "__gmp_set_memory_functions"
119 [ ConstantOperand . C.GlobalReference . Name $ "__idris_gmpMalloc"
120 , ConstantOperand . C.GlobalReference . Name $ "__idris_gmpRealloc"
121 , ConstantOperand . C.GlobalReference . Name $ "__idris_gmpFree"
122 ]
123 , UnName 1 := idrCall "{runMain0}" [] ]
124 (Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [])
125 ]}
127initDefs :: Target -> [Definition]
128initDefs tgt =
129 [ TypeDefinition (Name "valTy")
130 (Just $ StructureType False
131 [ IntegerType 32
132 , ArrayType 0 (PointerType valueType (AddrSpace 0))
133 ])
134 , TypeDefinition (Name "mpz")
135 (Just $ StructureType False
136 [ IntegerType 32
137 , IntegerType 32
138 , PointerType intPtr (AddrSpace 0)
139 ])
140 , GlobalDefinition $ globalVariableDefaults
141 { G.name = Name "__idris_intFmtStr"
142 , G.linkage = L.Internal
143 , G.isConstant = True
144 , G.hasUnnamedAddr = True
145 , G.type' = ArrayType 5 (IntegerType 8)
146 , G.initializer = Just $ C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) "%lld" ++ [C.Int 8 0])
147 }
148 , rtsFun "intStr" ptrI8 [IntegerType 64]
149 [ BasicBlock (UnName 0)
150 [ UnName 1 := simpleCall "GC_malloc_atomic" [ConstantOperand (C.Int (tgtWordSize tgt) 21)]
151 , UnName 2 := simpleCall "snprintf"
152 [ LocalReference (UnName 1)
153 , ConstantOperand (C.Int (tgtWordSize tgt) 21)
154 , ConstantOperand $ C.GetElementPtr True (C.GlobalReference . Name $ "__idris_intFmtStr") [C.Int 32 0, C.Int 32 0]
155 , LocalReference (UnName 0)
156 ]
157 ]
158 (Do $ Ret (Just (LocalReference (UnName 1))) [])
159 ]
160 , exfun "llvm.trap" VoidType [] False
161 -- , exfun "llvm.llvm.memcpy.p0i8.p0i8.i32" VoidType [ptrI8, ptrI8, IntegerType 32, IntegerType 32, IntegerType 1] False
162 -- , exfun "llvm.llvm.memcpy.p0i8.p0i8.i64" VoidType [ptrI8, ptrI8, IntegerType 64, IntegerType 32, IntegerType 1] False
163 , exfun "memcpy" ptrI8 [ptrI8, ptrI8, intPtr] False
164 , exfun "llvm.invariant.start" (PointerType (StructureType False []) (AddrSpace 0)) [IntegerType 64, ptrI8] False
165 , exfun "snprintf" (IntegerType 32) [ptrI8, intPtr, ptrI8] True
166 , exfun "strcmp" (IntegerType 32) [ptrI8, ptrI8] False
167 , exfun "strlen" intPtr [ptrI8] False
168 , exfun "GC_init" VoidType [] False
169 , exfun "GC_malloc" ptrI8 [intPtr] False
170 , exfun "GC_malloc_atomic" ptrI8 [intPtr] False
171 , exfun "__gmp_set_memory_functions" VoidType
172 [ PointerType (FunctionType ptrI8 [intPtr] False) (AddrSpace 0)
173 , PointerType (FunctionType ptrI8 [ptrI8, intPtr, intPtr] False) (AddrSpace 0)
174 , PointerType (FunctionType VoidType [ptrI8, intPtr] False) (AddrSpace 0)
175 ] False
176 , exfun "__gmpz_init" VoidType [pmpz] False
177 , exfun "__gmpz_init_set_str" (IntegerType 32) [pmpz, ptrI8, IntegerType 32] False
178 , exfun "__gmpz_get_str" ptrI8 [ptrI8, IntegerType 32, pmpz] False
179 , exfun "__gmpz_cmp" (IntegerType 32) [pmpz, pmpz] False
180 , exfun "mpz_get_ull" (IntegerType 64) [pmpz] False
181 , exfun "mpz_init_set_ull" VoidType [pmpz, IntegerType 64] False
182 , exfun "mpz_init_set_sll" VoidType [pmpz, IntegerType 64] False
183 , exfun "__idris_strCons" ptrI8 [IntegerType 8, ptrI8] False
184 , exfun "__idris_readStr" ptrI8 [ptrI8] False -- Actually pointer to FILE, but it's opaque anyway
185 , exfun "__idris_gmpMalloc" ptrI8 [intPtr] False
186 , exfun "__idris_gmpRealloc" ptrI8 [ptrI8, intPtr, intPtr] False
187 , exfun "__idris_gmpFree" VoidType [ptrI8, intPtr] False
188 , exfun "strtoll" (IntegerType 64) [ptrI8, PointerType ptrI8 (AddrSpace 0), IntegerType 32] False
189 , exVar (stdinName tgt) ptrI8
190 , exVar (stdoutName tgt) ptrI8
191 , exVar (stderrName tgt) ptrI8
192 , GlobalDefinition mainDef
193 ] ++ map mpzBinFun ["add", "sub", "mul", "fdiv_q", "fdiv_r", "and", "ior", "xor"]
194 where
195 intPtr = IntegerType (tgtWordSize tgt)
196 ptrI8 = PointerType (IntegerType 8) (AddrSpace 0)
197 pmpz = PointerType mpzTy (AddrSpace 0)
199 mpzBinFun n = exfun ("__gmpz_" ++ n) VoidType [pmpz, pmpz, pmpz] False
201 rtsFun :: String -> Type -> [Type] -> [BasicBlock] -> Definition
202 rtsFun name rty argtys def =
203 GlobalDefinition $ functionDefaults
204 { G.linkage = L.Internal
205 , G.returnType = rty
206 , G.parameters = (flip map argtys $ \ty -> Parameter ty (UnName 0) [], False)
207 , G.name = Name $ "__idris_" ++ name
208 , G.basicBlocks = def
209 }
211 exfun :: String -> Type -> [Type] -> Bool -> Definition
212 exfun name rty argtys vari =
213 GlobalDefinition $ functionDefaults
214 { G.returnType = rty
215 , G.name = Name name
216 , G.parameters = (flip map argtys $ \ty -> Parameter ty (UnName 0) [], vari)
217 }
218 exVar :: String -> Type -> Definition
219 exVar name ty = GlobalDefinition $ globalVariableDefaults { G.name = Name name, G.type' = ty }
221isApple :: Target -> Bool
222isApple (Target { triple = t }) = isJust . stripPrefix "-apple" $ dropWhile (/= '-') t
224stdinName, stdoutName, stderrName :: Target -> String
225stdinName t | isApple t = "__stdinp"
226stdinName _ = "stdin"
227stdoutName t | isApple t = "__stdoutp"
228stdoutName _ = "stdout"
229stderrName t | isApple t = "__stderrp"
230stderrName _ = "stderr"
232getStdIn, getStdOut, getStdErr :: Codegen Operand
233getStdIn = ConstantOperand . C.GlobalReference . Name . stdinName <$> asks target
234getStdOut = ConstantOperand . C.GlobalReference . Name . stdoutName <$> asks target
235getStdErr = ConstantOperand . C.GlobalReference . Name . stderrName <$> asks target
237codegen :: Target -> [SDecl] -> Module
238codegen tgt defs = Module "idris" (Just . dataLayout $ tgt) (Just . triple $ tgt) (initDefs tgt ++ globals ++ gendefs)
239 where
240 (gendefs, _, globals) = runRWS (mapM cgDef defs) tgt 0
242valueType :: Type
243valueType = NamedTypeReference (Name "valTy")
245nullValue :: C.Constant
246nullValue = C.Null (PointerType valueType (AddrSpace 0))
248primTy :: Type -> Type
249primTy inner = StructureType False [IntegerType 32, inner]
251mpzTy :: Type
252mpzTy = NamedTypeReference (Name "mpz")
254conType :: Word64 -> Type
255conType nargs = StructureType False
256 [ IntegerType 32
257 , ArrayType nargs (PointerType valueType (AddrSpace 0))
258 ]
260type Modgen = RWS Target [Definition] Word
262cgDef :: SDecl -> Modgen Definition
263cgDef (SFun name argNames _ expr) = do
264 nextGlobal <- get
265 tgt <- ask
266 let (_, CGS { nextGlobalName = nextGlobal' }, (allocas, bbs, globals)) =
267 runRWS (do r <- cgExpr expr
268 case r of
269 Nothing -> terminate $ Unreachable []
270 Just r' -> terminate $ Ret (Just r') [])
271 (CGR tgt (show name))
272 (CGS 0 nextGlobal (Name "begin") [] (map (Just . LocalReference . Name . show) argNames) S.empty)
273 entryTerm = case bbs of
274 [] -> Do $ Ret Nothing []
275 BasicBlock n _ _:_ -> Do $ Br n []
276 tell globals
277 put nextGlobal'
278 return . GlobalDefinition $ functionDefaults
279 { G.linkage = L.Internal
280 , G.callingConvention = CC.Fast
281 , G.name = Name (show name)
282 , G.returnType = PointerType valueType (AddrSpace 0)
283 , G.parameters = (flip map argNames $ \argName ->
284 Parameter (PointerType valueType (AddrSpace 0)) (Name (show argName)) []
285 , False)
286 , G.basicBlocks =
287 BasicBlock (Name "entry")
288 (map (\(n, t) -> n := Alloca t Nothing 0 []) allocas)
289 entryTerm
290 : bbs
291 }
293type CGW = ([(Name, Type)], [BasicBlock], [Definition])
295type Env = [Maybe Operand]
297data CGS = CGS { nextName :: Word
298 , nextGlobalName :: Word
299 , currentBlockName :: Name
300 , instAccum :: [Named Instruction]
301 , lexenv :: Env
302 , foreignSyms :: Set String
303 }
305data CGR = CGR { target :: Target
306 , funcName :: String }
308type Codegen = RWS CGR CGW CGS
310getFuncName :: Codegen String
311getFuncName = asks funcName
313getGlobalUnName :: Codegen Name
314getGlobalUnName = do
315 i <- gets nextGlobalName
316 modify $ \s -> s { nextGlobalName = 1 + i }
317 return (UnName i)
319getUnName :: Codegen Name
320getUnName = do
321 i <- gets nextName
322 modify $ \s -> s { nextName = 1 + i }
323 return (UnName i)
325getName :: String -> Codegen Name
326getName n = do
327 i <- gets nextName
328 modify $ \s -> s { nextName = 1 + i }
329 return (Name $ n ++ show i)
331alloca :: Name -> Type -> Codegen ()
332alloca n t = tell ([(n, t)], [], [])
334terminate :: Terminator -> Codegen ()
335terminate term = do
336 name <- gets currentBlockName
337 insts <- gets instAccum
338 modify $ \s -> s { instAccum = ierror "Not in a block"
339 , currentBlockName = ierror "Not in a block" }
340 tell ([], [BasicBlock name insts (Do term)], [])
342newBlock :: Name -> Codegen ()
343newBlock name = modify $ \s -> s { instAccum = []
344 , currentBlockName = name
345 }
347inst :: Instruction -> Codegen Operand
348inst i = do
349 n <- getUnName
350 modify $ \s -> s { instAccum = instAccum s ++ [n := i] }
351 return $ LocalReference n
353ninst :: String -> Instruction -> Codegen Operand
354ninst name i = do
355 n <- getName name
356 modify $ \s -> s { instAccum = instAccum s ++ [n := i] }
357 return $ LocalReference n
359inst' :: Instruction -> Codegen ()
360inst' i = modify $ \s -> s { instAccum = instAccum s ++ [Do i] }
362insts :: [Named Instruction] -> Codegen ()
363insts is = modify $ \s -> s { instAccum = instAccum s ++ is }
365var :: LVar -> Codegen (Maybe Operand)
366var (Loc level) = (!! level) <$> gets lexenv
367var (Glob n) = return . Just . ConstantOperand . C.GlobalReference . Name $ show n
369binds :: Env -> Codegen (Maybe Operand) -> Codegen (Maybe Operand)
370binds vals cg = do
371 envLen <- length <$> gets lexenv
372 modify $ \s -> s { lexenv = lexenv s ++ vals }
373 value <- cg
374 modify $ \s -> s { lexenv = take envLen $ lexenv s }
375 return value
377replaceElt :: Int -> a -> [a] -> [a]
378replaceElt _ val [] = error "replaceElt: Ran out of list"
379replaceElt 0 val (x:xs) = val:xs
380replaceElt n val (x:xs) = x : replaceElt (n-1) val xs
382alloc' :: Operand -> Codegen Operand
383alloc' size = inst $ simpleCall "GC_malloc" [size]
385allocAtomic :: Operand -> Codegen Operand
386allocAtomic size = inst $ simpleCall "GC_malloc_atomic" [size]
388alloc :: Type -> Codegen Operand
389alloc ty = do
390 size <- sizeOf ty
391 mem <- alloc' size
392 inst $ BitCast mem (PointerType ty (AddrSpace 0)) []
394sizeOf :: Type -> Codegen Operand
395sizeOf ty = ConstantOperand . C.PtrToInt
396 (C.GetElementPtr True (C.Null (PointerType ty (AddrSpace 0))) [C.Int 32 1])
397 . IntegerType <$> getWordSize
399loadInv :: Operand -> Instruction
400loadInv ptr = Load False ptr Nothing 0 [("invariant.load", MetadataNode [])]
402tgtWordSize :: Target -> Word32
403tgtWordSize (Target { dataLayout = DataLayout { pointerLayouts = l } }) =
404 fst . fromJust $ M.lookup (AddrSpace 0) l
406getWordSize :: Codegen Word32
407getWordSize = tgtWordSize <$> asks target
409cgExpr :: SExp -> Codegen (Maybe Operand)
410cgExpr (SV v) = var v
411cgExpr (SApp tailcall fname args) = do
412 argSlots <- mapM var args
413 case sequence argSlots of
414 Nothing -> return Nothing
415 Just argVals -> do
416 fn <- var (Glob fname)
417 Just <$> inst ((idrCall (show fname) argVals) { isTailCall = tailcall })
418cgExpr (SLet _ varExpr bodyExpr) = do
419 val <- cgExpr varExpr
420 binds [val] $ cgExpr bodyExpr
421cgExpr (SUpdate (Loc level) expr) = do
422 val <- cgExpr expr
423 modify $ \s -> s { lexenv = replaceElt level val (lexenv s) }
424 return val
425cgExpr (SCon tag name args) = do
426 argSlots <- mapM var args
427 case sequence argSlots of
428 Nothing -> return Nothing
429 Just argVals -> do
430 let ty = conType . fromIntegral . length $ argVals
431 con <- alloc ty
432 tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []
433 inst' $ Store False tagPtr (ConstantOperand (C.Int 32 (fromIntegral tag))) Nothing 0 []
434 forM_ (zip argVals [0..]) $ \(arg, i) -> do
435 ptr <- inst $ GetElementPtr True con [ ConstantOperand (C.Int 32 0)
436 , ConstantOperand (C.Int 32 1)
437 , ConstantOperand (C.Int 32 i)] []
438 inst' $ Store False ptr arg Nothing 0 []
439 ptrI8 <- inst $ BitCast con (PointerType (IntegerType 8) (AddrSpace 0)) []
440 inst' $ simpleCall "llvm.invariant.start" [ConstantOperand $ C.Int 64 (-1), ptrI8]
441 Just <$> inst (BitCast con (PointerType valueType (AddrSpace 0)) [])
442cgExpr (SCase inspect alts) = do
443 val <- var inspect
444 case val of
445 Nothing -> return Nothing
446 Just v -> cgCase v alts
447cgExpr (SChkCase inspect alts) = do
448 mval <- var inspect
449 case mval of
450 Nothing -> return Nothing
451 Just val ->
452 do endBBN <- getName "endChkCase"
453 notNullBBN <- getName "notNull"
454 originBlock <- gets currentBlockName
455 isNull <- inst $ ICmp IPred.EQ val (ConstantOperand nullValue) []
456 terminate $ CondBr isNull endBBN notNullBBN []
457 newBlock notNullBBN
458 ptr <- inst $ BitCast val (PointerType (IntegerType 32) (AddrSpace 0)) []
459 flag <- inst $ loadInv ptr
460 isVal <- inst $ ICmp IPred.EQ flag (ConstantOperand (C.Int 32 (-1))) []
461 conBBN <- getName "constructor"
462 terminate $ CondBr isVal endBBN conBBN []
463 newBlock conBBN
464 result <- cgCase val alts
465 caseExitBlock <- gets currentBlockName
466 case result of
467 Nothing -> do
468 terminate $ Unreachable []
469 newBlock endBBN
470 return $ Just val
471 Just caseVal -> do
472 terminate $ Br endBBN []
473 newBlock endBBN
474 Just <$> inst (Phi (PointerType valueType (AddrSpace 0))
475 [(val, originBlock), (val, notNullBBN), (caseVal, caseExitBlock)] [])
476cgExpr (SProj conVar idx) = do
477 val <- var conVar
478 case val of
479 Nothing -> return Nothing
480 Just v ->
481 do ptr <- inst $ GetElementPtr True v
482 [ ConstantOperand (C.Int 32 0)
483 , ConstantOperand (C.Int 32 1)
484 , ConstantOperand (C.Int 32 (fromIntegral idx))
485 ] []
486 Just <$> inst (loadInv ptr)
487cgExpr (SConst c) = Just <$> cgConst c
488cgExpr (SForeign LANG_C rty fname args) = do
489 func <- ensureCDecl fname rty (map fst args)
490 argVals <- forM args $ \(fty, v) -> do
491 v' <- var v
492 case v' of
493 Just val -> return $ Just (fty, val)
494 Nothing -> return Nothing
495 case sequence argVals of
496 Nothing -> return Nothing
497 Just argVals' -> do
498 argUVals <- mapM (uncurry unbox) argVals'
499 result <- inst Call { isTailCall = False
500 , callingConvention = CC.C
501 , returnAttributes = []
502 , function = Right func
503 , arguments = map (\v -> (v, [])) argUVals
504 , functionAttributes = []
505 , metadata = []
506 }
507 Just <$> box rty result
508cgExpr (SOp fn args) = do
509 argVals <- mapM var args
510 case sequence argVals of
511 Just ops -> Just <$> cgOp fn ops
512 Nothing -> return Nothing
513cgExpr SNothing = return . Just . ConstantOperand $ nullValue
514cgExpr (SError msg) = do -- TODO: Print message
515 str <- addGlobal' (ArrayType (2 + fromIntegral (length msg)) (IntegerType 8))
516 (cgConst' (TT.Str (msg ++ "\n")))
517 inst' $ simpleCall "putStr" [ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0
518 , C.Int 32 0]]
519 inst' Call { isTailCall = True
520 , callingConvention = CC.C
521 , returnAttributes = []
522 , function = Right . ConstantOperand . C.GlobalReference . Name $ "llvm.trap"
523 , arguments = []
524 , functionAttributes = [A.NoReturn]
525 , metadata = []
526 }
527 return Nothing
529cgCase :: Operand -> [SAlt] -> Codegen (Maybe Operand)
530cgCase val alts =
531 case find isConstCase alts of
532 Just (SConstCase (TT.BI _) _) -> cgChainCase val defExp constAlts
533 Just (SConstCase (TT.Str _) _) -> cgChainCase val defExp constAlts
534 Just (SConstCase _ _) -> cgPrimCase val defExp constAlts
535 Nothing -> cgConCase val defExp conAlts
536 where
537 defExp = getDefExp =<< find isDefCase alts
538 constAlts = filter isConstCase alts
539 conAlts = filter isConCase alts
541 isConstCase (SConstCase {}) = True
542 isConstCase _ = False
544 isConCase (SConCase {}) = True
545 isConCase _ = False
547 isDefCase (SDefaultCase _) = True
548 isDefCase _ = False
550 getDefExp (SDefaultCase e) = Just e
551 getDefExp _ = Nothing
553cgPrimCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
554cgPrimCase caseValPtr defExp alts = do
555 let caseTy = case head alts of
556 SConstCase (TT.I _) _ -> IntegerType 32
557 SConstCase (TT.B8 _) _ -> IntegerType 8
558 SConstCase (TT.B16 _) _ -> IntegerType 16
559 SConstCase (TT.B32 _) _ -> IntegerType 32
560 SConstCase (TT.B64 _) _ -> IntegerType 64
561 SConstCase (TT.Fl _) _ -> FloatingPointType 64 IEEE
562 SConstCase (TT.Ch _) _ -> IntegerType 32
563 realPtr <- inst $ BitCast caseValPtr (PointerType (primTy caseTy) (AddrSpace 0)) []
564 valPtr <- inst $ GetElementPtr True realPtr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
565 caseVal <- inst $ loadInv valPtr
566 defBlockName <- getName "default"
567 exitBlockName <- getName "caseExit"
568 namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
569 terminate $ Switch caseVal defBlockName (map (\(n, SConstCase c _) -> (cgConst' c, n)) namedAlts) []
570 initEnv <- gets lexenv
571 defResult <- cgDefaultAlt exitBlockName defBlockName defExp
572 results <- forM namedAlts $ \(name, SConstCase _ exp) -> cgAlt initEnv exitBlockName name Nothing exp
573 finishCase initEnv exitBlockName (defResult:results)
575cgConCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
576cgConCase con defExp alts = do
577 tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []
578 tag <- inst $ loadInv tagPtr
579 defBlockName <- getName "default"
580 exitBlockName <- getName "caseExit"
581 namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
582 terminate $ Switch tag defBlockName (map (\(n, SConCase _ tag _ _ _) ->
583 (C.Int 32 (fromIntegral tag), n)) namedAlts) []
584 initEnv <- gets lexenv
585 defResult <- cgDefaultAlt exitBlockName defBlockName defExp
586 results <- forM namedAlts $ \(name, SConCase _ _ _ argns exp) ->
587 cgAlt initEnv exitBlockName name (Just (con, map show argns)) exp
588 finishCase initEnv exitBlockName (defResult:results)
590cgChainCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
591cgChainCase caseValPtr defExp alts = do
592 let (caseTy, comparator) =
593 case head alts of
594 SConstCase (TT.BI _) _ -> (FArith (ATInt ITBig), "__gmpz_cmp")
595 SConstCase (TT.Str _) _ -> (FString, "strcmp")
596 caseVal <- unbox caseTy caseValPtr
597 defBlockName <- getName "default"
598 exitBlockName <- getName "caseExit"
599 namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
600 initEnv <- gets lexenv
601 results <- forM namedAlts $ \(name, SConstCase c e) ->
602 do const <- unbox caseTy =<< cgConst c
603 cmp <- inst $ simpleCall comparator [const, caseVal]
604 cmpResult <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) []
605 elseName <- getName "else"
606 terminate $ CondBr cmpResult name elseName []
607 result <- cgAlt initEnv exitBlockName name Nothing e
608 newBlock elseName
609 return result
610 modify $ \s -> s { lexenv = initEnv }
611 fname <- getFuncName
612 defaultVal <- cgExpr (fromMaybe (SError $ "Inexhaustive case failure in " ++ fname) defExp)
613 defaultBlock <- gets currentBlockName
614 defaultEnv <- gets lexenv
615 defResult <- case defaultVal of
616 Just v -> do
617 terminate $ Br exitBlockName []
618 return $ Just (v, defaultBlock, defaultEnv)
619 Nothing -> do
620 terminate $ Unreachable []
621 return Nothing
622 finishCase initEnv exitBlockName (defResult:results)
624finishCase :: Env -> Name -> [Maybe (Operand, Name, Env)] -> Codegen (Maybe Operand)
625finishCase initEnv exitBlockName results = do
626 let definedResults = mapMaybe id results
627 case definedResults of
628 [] -> do modify $ \s -> s { lexenv = initEnv }
629 return Nothing
630 xs -> do
631 newBlock exitBlockName
632 mergeEnvs $ map (\(_, altBlock, altEnv) -> (altBlock, altEnv)) xs
633 Just <$> inst (Phi (PointerType valueType (AddrSpace 0))
634 (map (\(altVal, altBlock, _) -> (altVal, altBlock)) xs) [])
637cgDefaultAlt :: Name -> Name -> Maybe SExp -> Codegen (Maybe (Operand, Name, Env))
638cgDefaultAlt exitName name exp = do
639 newBlock name
640 fname <- getFuncName
641 val <- cgExpr (fromMaybe (SError $ "Inexhaustive case failure in " ++ fname) exp)
642 env <- gets lexenv
643 block <- gets currentBlockName
644 case val of
645 Just v ->
646 do terminate $ Br exitName []
647 return $ Just (v, block, env)
648 Nothing ->
649 do terminate $ Unreachable []
650 return Nothing
652cgAlt :: Env -> Name -> Name -> Maybe (Operand, [String]) -> SExp
653 -> Codegen (Maybe (Operand, Name, Env))
654cgAlt initEnv exitBlockName name destr exp = do
655 modify $ \s -> s { lexenv = initEnv }
656 newBlock name
657 locals <- case destr of
658 Nothing -> return []
659 Just (con, argns) ->
660 forM (zip argns [0..]) $ \(argName, i) ->
661 do ptr <- inst $ GetElementPtr True con [ ConstantOperand (C.Int 32 0)
662 , ConstantOperand (C.Int 32 1)
663 , ConstantOperand (C.Int 32 i)] []
664 Just <$> ninst argName (loadInv ptr)
665 altVal <- binds locals $ cgExpr exp
666 altEnv <- gets lexenv
667 altBlock <- gets currentBlockName
668 case altVal of
669 Just v -> do
670 terminate $ Br exitBlockName []
671 return $ Just (v, altBlock, altEnv)
672 Nothing -> do
673 terminate $ Unreachable []
674 return Nothing
676mergeEnvs :: [(Name, Env)] -> Codegen ()
677mergeEnvs es = do
678 let vars = transpose
679 . map (\(block, env) -> map (\x -> (x, block)) env)
680 $ es
681 env <- forM vars $ \var ->
682 case var of
683 [] -> ierror "mergeEnvs: impossible"
684 [(v, _)] -> return v
685 vs@((v, _):_)
686 | all (== v) (map fst vs) -> return v
687 | otherwise ->
688 let valid = map (\(a, b) -> (fromJust a, b)) . filter (isJust . fst) $ vs in
689 Just <$> inst (Phi (PointerType valueType (AddrSpace 0)) valid [])
690 modify $ \s -> s { lexenv = env }
692nameAlt :: Name -> SAlt -> Codegen Name
693nameAlt d (SDefaultCase _) = return d
694nameAlt _ (SConCase _ _ name _ _) = getName (show name)
695nameAlt _ (SConstCase const _) = getName (show const)
697box :: FType -> Operand -> Codegen Operand
698box FUnit _ = return $ ConstantOperand nullValue
699box fty fval = do
700 let ty = primTy (ftyToTy fty)
701 val <- alloc ty
702 tagptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []
703 valptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
704 inst' $ Store False tagptr (ConstantOperand (C.Int 32 (-1))) Nothing 0 []
705 inst' $ Store False valptr fval Nothing 0 []
706 ptrI8 <- inst $ BitCast val (PointerType (IntegerType 8) (AddrSpace 0)) []
707 inst' $ simpleCall "llvm.invariant.start" [ConstantOperand $ C.Int 64 (-1), ptrI8]
708 inst $ BitCast val (PointerType valueType (AddrSpace 0)) []
710unbox :: FType -> Operand -> Codegen Operand
711unbox FUnit x = return x
712unbox fty bval = do
713 val <- inst $ BitCast bval (PointerType (primTy (ftyToTy fty)) (AddrSpace 0)) []
714 fvalptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
715 inst $ loadInv fvalptr
717cgConst' :: TT.Const -> C.Constant
718cgConst' (TT.I i) = C.Int 32 (fromIntegral i)
719cgConst' (TT.B8 i) = C.Int 8 (fromIntegral i)
720cgConst' (TT.B16 i) = C.Int 16 (fromIntegral i)
721cgConst' (TT.B32 i) = C.Int 32 (fromIntegral i)
722cgConst' (TT.B64 i) = C.Int 64 (fromIntegral i)
723cgConst' (TT.B8V v) = C.Vector (map ((C.Int 8) . fromIntegral) . V.toList $ v)
724cgConst' (TT.B16V v) = C.Vector (map ((C.Int 16) . fromIntegral) . V.toList $ v)
725cgConst' (TT.B32V v) = C.Vector (map ((C.Int 32) . fromIntegral) . V.toList $ v)
726cgConst' (TT.B64V v) = C.Vector (map ((C.Int 64) . fromIntegral) . V.toList $ v)
728cgConst' (TT.BI i) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) (show i) ++ [C.Int 8 0])
729cgConst' (TT.Fl f) = C.Float (F.Double f)
730cgConst' (TT.Ch c) = C.Int 32 . fromIntegral . fromEnum $ c
731cgConst' (TT.Str s) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) s ++ [C.Int 8 0])
732cgConst' x = ierror $ "Unsupported constant: " ++ show x
734cgConst :: TT.Const -> Codegen Operand
735cgConst c@(TT.I _) = box (FArith (ATInt ITNative)) (ConstantOperand $ cgConst' c)
736cgConst c@(TT.B8 _) = box (FArith (ATInt (ITFixed IT8))) (ConstantOperand $ cgConst' c)
737cgConst c@(TT.B16 _) = box (FArith (ATInt (ITFixed IT16))) (ConstantOperand $ cgConst' c)
738cgConst c@(TT.B32 _) = box (FArith (ATInt (ITFixed IT32))) (ConstantOperand $ cgConst' c)
739cgConst c@(TT.B64 _) = box (FArith (ATInt (ITFixed IT64))) (ConstantOperand $ cgConst' c)
740cgConst c@(TT.B8V v) = box (FArith (ATInt (ITVec IT8 (V.length v)))) (ConstantOperand $ cgConst' c)
741cgConst c@(TT.B16V v) = box (FArith (ATInt (ITVec IT16 (V.length v)))) (ConstantOperand $ cgConst' c)
742cgConst c@(TT.B32V v) = box (FArith (ATInt (ITVec IT32 (V.length v)))) (ConstantOperand $ cgConst' c)
743cgConst c@(TT.B64V v) = box (FArith (ATInt (ITVec IT64 (V.length v)))) (ConstantOperand $ cgConst' c)
744cgConst c@(TT.Fl _) = box (FArith ATFloat) (ConstantOperand $ cgConst' c)
745cgConst c@(TT.Ch _) = box (FArith (ATInt ITChar)) (ConstantOperand $ cgConst' c)
746cgConst c@(TT.Str s) = do
747 str <- addGlobal' (ArrayType (1 + fromIntegral (length s)) (IntegerType 8)) (cgConst' c)
748 box FString (ConstantOperand $ C.GetElementPtr True str [C.Int 32 0, C.Int 32 0])
749cgConst c@(TT.BI i) = do
750 str <- addGlobal' (ArrayType (1 + fromInteger (numDigits 10 i)) (IntegerType 8)) (cgConst' c)
751 mpz <- alloc mpzTy
752 inst $ simpleCall "__gmpz_init_set_str" [mpz
753 , ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0, C.Int 32 0]
754 , ConstantOperand $ C.Int 32 10
755 ]
756 box (FArith (ATInt ITBig)) mpz
757cgConst x = return $ ConstantOperand nullValue
759numDigits :: Integer -> Integer -> Integer
760numDigits b n = 1 + fst (ilog b n) where
761 ilog b n
762 | n < b = (0, n)
763 | otherwise = let (e, r) = ilog (b*b) n
764 in if r < b then (2*e, r) else (2*e+1, r `div` b)
766addGlobal :: Global -> Codegen ()
767addGlobal def = tell ([], [], [GlobalDefinition def])
769addGlobal' :: Type -> C.Constant -> Codegen C.Constant
770addGlobal' ty val = do
771 name <- getGlobalUnName
772 addGlobal $ globalVariableDefaults
773 { G.name = name
774 , G.linkage = L.Internal
775 , G.hasUnnamedAddr = True
776 , G.isConstant = True
777 , G.type' = ty
778 , G.initializer = Just val
779 }
780 return . C.GlobalReference $ name
783ensureCDecl :: String -> FType -> [FType] -> Codegen Operand
784ensureCDecl name rty argtys = do
785 syms <- gets foreignSyms
786 unless (S.member name syms) $
787 do addGlobal (ffunDecl name rty argtys)
788 modify $ \s -> s { foreignSyms = S.insert name (foreignSyms s) }
789 return $ ConstantOperand (C.GlobalReference (Name name))
791ffunDecl :: String -> FType -> [FType] -> Global
792ffunDecl name rty argtys =
793 functionDefaults
794 { G.returnType = ftyToTy rty
795 , G.name = Name name
796 , G.parameters = (flip map argtys $ \fty ->
797 Parameter (ftyToTy fty) (UnName 0) []
798 , False)
799 }
801ftyToTy :: FType -> Type
802ftyToTy (FArith (ATInt ITNative)) = IntegerType 32
803ftyToTy (FArith (ATInt ITBig)) = PointerType mpzTy (AddrSpace 0)
804ftyToTy (FArith (ATInt (ITFixed ty))) = IntegerType (fromIntegral $ nativeTyWidth ty)
805ftyToTy (FArith (ATInt (ITVec e c)))
806 = VectorType (fromIntegral c) (IntegerType (fromIntegral $ nativeTyWidth e))
807ftyToTy (FArith (ATInt ITChar)) = IntegerType 32
808ftyToTy FString = PointerType (IntegerType 8) (AddrSpace 0)
809ftyToTy FUnit = VoidType
810ftyToTy FPtr = PointerType (IntegerType 8) (AddrSpace 0)
811ftyToTy (FArith ATFloat) = FloatingPointType 64 IEEE
812ftyToTy FAny = valueType
814-- Only use when known not to be ITBig
815itWidth :: IntTy -> Word32
816itWidth ITNative = 32
817itWidth ITChar = 32
818itWidth (ITFixed x) = fromIntegral $ nativeTyWidth x
819itWidth x = ierror $ "itWidth: " ++ show x
821itConst :: IntTy -> Integer -> C.Constant
822itConst (ITFixed n) x = C.Int (fromIntegral $ nativeTyWidth n) x
823itConst ITNative x = itConst (ITFixed IT32) x
824itConst ITChar x = itConst (ITFixed IT32) x
825itConst (ITVec elts size) x = C.Vector (replicate size (itConst (ITFixed elts) x))
827cgOp :: PrimFn -> [Operand] -> Codegen Operand
828cgOp (LTrunc ITBig ity) [x] = do
829 nx <- unbox (FArith (ATInt ITBig)) x
830 val <- inst $ simpleCall "mpz_get_ull" [nx]
831 v <- case ity of
832 (ITFixed IT64) -> return val
833 _ -> inst $ Trunc val (ftyToTy (FArith (ATInt ity))) []
834 box (FArith (ATInt ity)) v
835cgOp (LZExt from ITBig) [x] = do
836 nx <- unbox (FArith (ATInt from)) x
837 nx' <- case from of
838 (ITFixed IT64) -> return nx
839 _ -> inst $ ZExt nx (IntegerType 64) []
840 mpz <- alloc mpzTy
841 inst' $ simpleCall "mpz_init_set_ull" [mpz, nx']
842 box (FArith (ATInt ITBig)) mpz
843cgOp (LSExt from ITBig) [x] = do
844 nx <- unbox (FArith (ATInt from)) x
845 nx' <- case from of
846 (ITFixed IT64) -> return nx
847 _ -> inst $ SExt nx (IntegerType 64) []
848 mpz <- alloc mpzTy
849 inst' $ simpleCall "mpz_init_set_sll" [mpz, nx']
850 box (FArith (ATInt ITBig)) mpz
852-- ITChar, ITNative, and IT32 all share representation
853cgOp (LChInt ITNative) [x] = return x
854cgOp (LIntCh ITNative) [x] = return x
856cgOp (LLt (ATInt ITBig)) [x,y] = mpzCmp IPred.SLT x y
857cgOp (LLe (ATInt ITBig)) [x,y] = mpzCmp IPred.SLE x y
858cgOp (LEq (ATInt ITBig)) [x,y] = mpzCmp IPred.EQ x y
859cgOp (LGe (ATInt ITBig)) [x,y] = mpzCmp IPred.SGE x y
860cgOp (LGt (ATInt ITBig)) [x,y] = mpzCmp IPred.SGT x y
861cgOp (LPlus (ATInt ITBig)) [x,y] = mpzBin "add" x y
862cgOp (LMinus (ATInt ITBig)) [x,y] = mpzBin "sub" x y
863cgOp (LTimes (ATInt ITBig)) [x,y] = mpzBin "mul" x y
864cgOp (LSDiv (ATInt ITBig)) [x,y] = mpzBin "fdiv_q" x y
865cgOp (LSRem (ATInt ITBig)) [x,y] = mpzBin "fdiv_r" x y
866cgOp (LAnd ITBig) [x,y] = mpzBin "and" x y
867cgOp (LOr ITBig) [x,y] = mpzBin "ior" x y
868cgOp (LXOr ITBig) [x,y] = mpzBin "xor" x y
869cgOp (LCompl ITBig) [x] = mpzUn "com" x
871cgOp (LTrunc ITNative (ITFixed to)) [x]
872 | 32 >= nativeTyWidth to = iCoerce Trunc IT32 to x
873cgOp (LZExt ITNative (ITFixed to)) [x]
874 | 32 <= nativeTyWidth to = iCoerce ZExt IT32 to x
875cgOp (LSExt ITNative (ITFixed to)) [x]
876 | 32 <= nativeTyWidth to = iCoerce SExt IT32 to x
878cgOp (LTrunc (ITFixed from) ITNative) [x]
879 | nativeTyWidth from >= 32 = iCoerce Trunc from IT32 x
880cgOp (LZExt (ITFixed from) ITNative) [x]
881 | nativeTyWidth from <= 32 = iCoerce ZExt from IT32 x
882cgOp (LSExt (ITFixed from) ITNative) [x]
883 | nativeTyWidth from <= 32 = iCoerce SExt from IT32 x
885cgOp (LTrunc (ITFixed from) (ITFixed to)) [x]
886 | nativeTyWidth from > nativeTyWidth to = iCoerce Trunc from to x
887cgOp (LZExt (ITFixed from) (ITFixed to)) [x]
888 | nativeTyWidth from < nativeTyWidth to = iCoerce ZExt from to x
889cgOp (LSExt (ITFixed from) (ITFixed to)) [x]
890 | nativeTyWidth from < nativeTyWidth to = iCoerce SExt from to x
892cgOp (LLt (ATInt ity)) [x,y] = iCmp ity IPred.SLT x y
893cgOp (LLe (ATInt ity)) [x,y] = iCmp ity IPred.SLE x y
894cgOp (LEq (ATInt ity)) [x,y] = iCmp ity IPred.EQ x y
895cgOp (LGe (ATInt ity)) [x,y] = iCmp ity IPred.SGE x y
896cgOp (LGt (ATInt ity)) [x,y] = iCmp ity IPred.SGT x y
897cgOp (LPlus (ATInt ity)) [x,y] = ibin ity x y (Add False False)
898cgOp (LMinus (ATInt ity)) [x,y] = ibin ity x y (Sub False False)
899cgOp (LTimes (ATInt ity)) [x,y] = ibin ity x y (Mul False False)
900cgOp (LSDiv (ATInt ity)) [x,y] = ibin ity x y (SDiv False)
901cgOp (LSRem (ATInt ity)) [x,y] = ibin ity x y SRem
902cgOp (LUDiv ity) [x,y] = ibin ity x y (UDiv False)
903cgOp (LURem ity) [x,y] = ibin ity x y URem
904cgOp (LAnd ity) [x,y] = ibin ity x y And
905cgOp (LOr ity) [x,y] = ibin ity x y Or
906cgOp (LXOr ity) [x,y] = ibin ity x y Xor
907cgOp (LCompl ity) [x] = iun ity x (Xor . ConstantOperand $ itConst ity (-1))
908cgOp (LSHL ity) [x,y] = ibin ity x y (Shl False False)
909cgOp (LLSHR ity) [x,y] = ibin ity x y (LShr False)
910cgOp (LASHR ity) [x,y] = ibin ity x y (AShr False)
912cgOp LNoOp xs = return $ last xs
914cgOp (LMkVec ety c) xs | c == length xs = do
915 nxs <- mapM (unbox (FArith (ATInt (ITFixed ety)))) xs
916 vec <- foldM (\v (e, i) -> inst $ InsertElement v e (ConstantOperand (C.Int 32 i)) [])
917 (ConstantOperand $ C.Vector (replicate c (C.Undef (IntegerType . fromIntegral $ nativeTyWidth ety))))
918 (zip nxs [0..])
919 box (FArith (ATInt (ITVec ety c))) vec
921cgOp (LIdxVec ety c) [v,i] = do
922 nv <- unbox (FArith (ATInt (ITVec ety c))) v
923 ni <- unbox (FArith (ATInt (ITFixed IT32))) i
924 elt <- inst $ ExtractElement nv ni []
925 box (FArith (ATInt (ITFixed ety))) elt
927cgOp (LUpdateVec ety c) [v,i,e] = do
928 let fty = FArith (ATInt (ITVec ety c))
929 nv <- unbox fty v
930 ni <- unbox (FArith (ATInt (ITFixed IT32))) i
931 ne <- unbox (FArith (ATInt (ITFixed ety))) e
932 nv' <- inst $ InsertElement nv ne ni []
933 box fty nv'
935cgOp (LBitCast from to) [x] = do
936 nx <- unbox (FArith from) x
937 nx' <- inst $ BitCast nx (ftyToTy (FArith to)) []
938 box (FArith to) nx'
940cgOp LStrEq [x,y] = do
941 x' <- unbox FString x
942 y' <- unbox FString y
943 cmp <- inst $ simpleCall "strcmp" [x', y']
944 flag <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) []
945 val <- inst $ ZExt flag (IntegerType 32) []
946 box (FArith (ATInt (ITFixed IT32))) val
948cgOp LStrLt [x,y] = do
949 nx <- unbox FString x
950 ny <- unbox FString y
951 cmp <- inst $ simpleCall "strcmp" [nx, ny]
952 flag <- inst $ ICmp IPred.ULT cmp (ConstantOperand (C.Int 32 0)) []
953 val <- inst $ ZExt flag (IntegerType 32) []
954 box (FArith (ATInt (ITFixed IT32))) val
956cgOp (LIntStr ITBig) [x] = do
957 x' <- unbox (FArith (ATInt ITBig)) x
958 ustr <- inst $ simpleCall "__gmpz_get_str"
959 [ ConstantOperand (C.Null (PointerType (IntegerType 8) (AddrSpace 0)))
960 , ConstantOperand (C.Int 32 10)
961 , x'
962 ]
963 box FString ustr
964cgOp (LIntStr ity) [x] = do
965 x' <- unbox (FArith (ATInt ity)) x
966 x'' <- if itWidth ity < 64
967 then inst $ SExt x' (IntegerType 64) []
968 else return x'
969 box FString =<< inst (idrCall "__idris_intStr" [x''])
970cgOp (LStrInt ITBig) [s] = do
971 ns <- unbox FString s
972 mpz <- alloc mpzTy
973 inst $ simpleCall "__gmpz_init_set_str" [mpz, ns, ConstantOperand $ C.Int 32 10]
974 box (FArith (ATInt ITBig)) mpz
975cgOp (LStrInt ity) [s] = do
976 ns <- unbox FString s
977 nx <- inst $ simpleCall "strtoll"
978 [ns
979 , ConstantOperand $ C.Null (PointerType (PointerType (IntegerType 8) (AddrSpace 0)) (AddrSpace 0))
980 , ConstantOperand $ C.Int 32 10
981 ]
982 nx' <- case ity of
983 (ITFixed IT64) -> return nx
984 _ -> inst $ Trunc nx (IntegerType (itWidth ity)) []
985 box (FArith (ATInt ity)) nx'
987cgOp LStrConcat [x,y] = cgStrCat x y
989cgOp LStrCons [c,s] = do
990 nc <- unbox (FArith (ATInt ITChar)) c
991 ns <- unbox FString s
992 nc' <- inst $ Trunc nc (IntegerType 8) []
993 r <- inst $ simpleCall "__idris_strCons" [nc', ns]
994 box FString r
996cgOp LStrHead [c] = do
997 s <- unbox FString c
998 c <- inst $ loadInv s
999 c' <- inst $ ZExt c (IntegerType 32) []
1000 box (FArith (ATInt ITChar)) c'
1002cgOp LStrIndex [s, i] = do
1003 ns <- unbox FString s
1004 ni <- unbox (FArith (ATInt (ITFixed IT32))) i
1005 p <- inst $ GetElementPtr True ns [ni] []
1006 c <- inst $ loadInv p
1007 c' <- inst $ ZExt c (IntegerType 32) []
1008 box (FArith (ATInt ITChar)) c'
1010cgOp LStrTail [c] = do
1011 s <- unbox FString c
1012 c <- inst $ GetElementPtr True s [ConstantOperand $ C.Int 32 1] []
1013 box FString c
1015cgOp LStrLen [s] = do
1016 ns <- unbox FString s
1017 len <- inst $ simpleCall "strlen" [ns]
1018 ws <- getWordSize
1019 len' <- case ws of
1020 32 -> return len
1021 x | x > 32 -> inst $ Trunc len (IntegerType 32) []
1022 | x < 32 -> inst $ ZExt len (IntegerType 32) []
1023 box (FArith (ATInt (ITFixed IT32))) len'
1025cgOp LReadStr [p] = do
1026 np <- unbox FPtr p
1027 s <- inst $ simpleCall "__idris_readStr" [np]
1028 box FString s
1030cgOp LStdIn [] = do
1031 stdin <- getStdIn
1032 ptr <- inst $ loadInv stdin
1033 box FPtr ptr
1034cgOp LStdOut [] = do
1035 stdout <- getStdOut
1036 ptr <- inst $ loadInv stdout
1037 box FPtr ptr
1038cgOp LStdErr [] = do
1039 stdErr <- getStdErr
1040 ptr <- inst $ loadInv stdErr
1041 box FPtr ptr
1043cgOp prim args = ierror $ "Unimplemented primitive: <" ++ show prim ++ ">("
1044 ++ intersperse ',' (take (length args) ['a'..]) ++ ")"
1046iCoerce :: (Operand -> Type -> InstructionMetadata -> Instruction) -> NativeTy -> NativeTy -> Operand -> Codegen Operand
1047iCoerce _ from to x | from == to = return x
1048iCoerce operator from to x = do
1049 x' <- unbox (FArith (ATInt (ITFixed from))) x
1050 x'' <- inst $ operator x' (ftyToTy (FArith (ATInt (ITFixed to)))) []
1051 box (FArith (ATInt (ITFixed to))) x''
1053cgStrCat :: Operand -> Operand -> Codegen Operand
1054cgStrCat x y = do
1055 x' <- unbox FString x
1056 y' <- unbox FString y
1057 xlen <- inst $ simpleCall "strlen" [x']
1058 ylen <- inst $ simpleCall "strlen" [y']
1059 zlen <- inst $ Add False True xlen ylen []
1060 ws <- getWordSize
1061 total <- inst $ Add False True zlen (ConstantOperand (C.Int ws 1)) []
1062 mem <- allocAtomic total
1063 inst $ simpleCall "memcpy" [mem, x', xlen]
1064 i <- inst $ PtrToInt mem (IntegerType ws) []
1065 offi <- inst $ Add False True i xlen []
1066 offp <- inst $ IntToPtr offi (PointerType (IntegerType 8) (AddrSpace 0)) []
1067 inst $ simpleCall "memcpy" [offp, y', ylen]
1068 j <- inst $ PtrToInt offp (IntegerType ws) []
1069 offj <- inst $ Add False True j ylen []
1070 end <- inst $ IntToPtr offj (PointerType (IntegerType 8) (AddrSpace 0)) []
1071 inst' $ Store False end (ConstantOperand (C.Int 8 0)) Nothing 0 []
1072 box FString mem
1074ibin :: IntTy -> Operand -> Operand
1075 -> (Operand -> Operand -> InstructionMetadata -> Instruction) -> Codegen Operand
1076ibin ity x y instCon = do
1077 nx <- unbox (FArith (ATInt ity)) x
1078 ny <- unbox (FArith (ATInt ity)) y
1079 nr <- inst $ instCon nx ny []
1080 box (FArith (ATInt ity)) nr
1082iun :: IntTy -> Operand -> (Operand -> InstructionMetadata -> Instruction) -> Codegen Operand
1083iun ity x instCon = do
1084 nx <- unbox (FArith (ATInt ity)) x
1085 nr <- inst $ instCon nx []
1086 box (FArith (ATInt ity)) nr
1088iCmp :: IntTy -> IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand
1089iCmp ity pred x y = do
1090 nx <- unbox (FArith (ATInt ity)) x
1091 ny <- unbox (FArith (ATInt ity)) y
1092 nr <- inst $ ICmp pred nx ny []
1093 nr' <- inst $ SExt nr (ftyToTy $ cmpResultTy ity) []
1094 box (cmpResultTy ity) nr'
1096cmpResultTy :: IntTy -> FType
1097cmpResultTy v@(ITVec _ _) = FArith (ATInt v)
1098cmpResultTy _ = FArith (ATInt (ITFixed IT32))
1100mpzBin :: String -> Operand -> Operand -> Codegen Operand
1101mpzBin name x y = do
1102 nx <- unbox (FArith (ATInt ITBig)) x
1103 ny <- unbox (FArith (ATInt ITBig)) y
1104 nz <- alloc mpzTy
1105 inst' $ simpleCall "__gmpz_init" [nz]
1106 inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx, ny]
1107 box (FArith (ATInt ITBig)) nz
1109mpzUn :: String -> Operand -> Codegen Operand
1110mpzUn name x = do
1111 nx <- unbox (FArith (ATInt ITBig)) x
1112 nz <- alloc mpzTy
1113 inst' $ simpleCall "__gmpz_init" [nz]
1114 inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx]
1115 box (FArith (ATInt ITBig)) nz
1117mpzCmp :: IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand
1118mpzCmp pred x y = do
1119 nx <- unbox (FArith (ATInt ITBig)) x
1120 ny <- unbox (FArith (ATInt ITBig)) y
1121 cmp <- inst $ simpleCall "__gmpz_cmp" [nx, ny]
1122 result <- inst $ ICmp pred cmp (ConstantOperand (C.Int 32 0)) []
1123 i <- inst $ ZExt result (IntegerType 32) []
1124 box (FArith (ATInt (ITFixed IT32))) i
1126simpleCall :: String -> [Operand] -> Instruction
1127simpleCall name args =
1128 Call { isTailCall = False
1129 , callingConvention = CC.C
1130 , returnAttributes = []
1131 , function = Right . ConstantOperand . C.GlobalReference . Name $ name
1132 , arguments = map (\x -> (x, [])) args
1133 , functionAttributes = []
1134 , metadata = []
1137idrCall :: String -> [Operand] -> Instruction
1138idrCall name args =
1139 Call { isTailCall = False
1140 , callingConvention = CC.Fast
1141 , returnAttributes = []
1142 , function = Right . ConstantOperand . C.GlobalReference . Name $ name
1143 , arguments = map (\x -> (x, [])) args
1144 , functionAttributes = []
1145 , metadata = []
1148assert :: Operand -> String -> Codegen ()
1149assert condition message = do
1150 passed <- getName "assertPassed"
1151 failed <- getName "assertFailed"
1152 terminate $ CondBr condition passed failed []
1153 newBlock failed
1154 cgExpr (SError message)
1155 terminate $ Unreachable []
1156 newBlock passed