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