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