@@ -1,1320 +0,0 @@
1−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2−module IRTS.CodegenLLVM (codegenLLVM) where
3−
4−import IRTS.CodegenCommon
5−import IRTS.Lang
6−import IRTS.Simplified
7−import IRTS.System
8−import qualified Idris.Core.TT as TT
9−import Idris.Core.TT (ArithTy(..), IntTy(..), NativeTy(..), nativeTyWidth)
10−
11−import Util.System
12−
13−import LLVM.General.Context
14−import LLVM.General.Diagnostic
15−import LLVM.General.AST
16−import LLVM.General.AST.AddrSpace
17−import LLVM.General.Target ( TargetMachine
18− , withTargetOptions, withTargetMachine, getTargetMachineDataLayout
19− , initializeAllTargets, lookupTarget
20− )
21−import LLVM.General.AST.DataLayout
22−import qualified LLVM.General.PassManager as PM
23−import qualified LLVM.General.Module as MO
24−import qualified LLVM.General.AST.IntegerPredicate as IPred
25−import qualified LLVM.General.AST.FloatingPointPredicate as FPred
26−import qualified LLVM.General.AST.Linkage as L
27−import qualified LLVM.General.AST.Visibility as V
28−import qualified LLVM.General.AST.CallingConvention as CC
29−import qualified LLVM.General.AST.Attribute as A
30−import qualified LLVM.General.AST.Global as G
31−import qualified LLVM.General.AST.Constant as C
32−import qualified LLVM.General.AST.Float as F
33−import qualified LLVM.General.Relocation as R
34−import qualified LLVM.General.CodeModel as CM
35−import qualified LLVM.General.CodeGenOpt as CGO
36−
37−import Data.List
38−import Data.Maybe
39−import Data.Word
40−import Data.Map (Map)
41−import qualified Data.Map as M
42−import qualified Data.Set as S
43−import qualified Data.Vector.Unboxed as V
44−import Control.Applicative
45−import Control.Monad.RWS
46−import Control.Monad.Writer
47−import Control.Monad.State
48−import Control.Monad.Error
49−
50−import qualified System.Info as SI (arch, os)
51−import System.IO
52−import System.Directory (removeFile)
53−import System.FilePath ((</>))
54−import System.Process (rawSystem)
55−import System.Exit (ExitCode(..))
56−import Debug.Trace
57−
58−data Target = Target { triple :: String, dataLayout :: DataLayout }
59−
60−codegenLLVM :: CodeGenerator
61−codegenLLVM ci = codegenLLVM' (simpleDecls ci) (targetTriple ci)
62− (targetCPU ci) (optimisation ci)
63− (outputFile ci) (outputType ci)
64−
65−codegenLLVM' :: [(TT.Name, SDecl)] ->
66− String -> -- target triple
67− String -> -- target CPU
68− Word -> -- Optimization degree
69− FilePath -> -- output file name
70− OutputType ->
71− IO ()
72−codegenLLVM' 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
90−
91−failInIO :: ErrorT String IO a -> IO a
92−failInIO = either fail return <=< runErrorT
93−
94−outputModule :: TargetMachine -> FilePath -> OutputType -> MO.Module -> IO ()
95−outputModule _ file Raw m = failInIO $ MO.writeBitcodeToFile file m
96−outputModule tm file Object m = failInIO $ MO.writeObjectToFile tm file m
97−outputModule 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"
103−outputModule _ _ MavenProject _ = ierror "FAILURE: unsupported output type"
104−
105−withTmpFile :: (FilePath -> IO a) -> IO a
106−withTmpFile f = do
107− (path, handle) <- tempfile
108− hClose handle
109− result <- f path
110− removeFile path
111− return result
112−
113−ierror :: String -> a
114−ierror msg = error $ "INTERNAL ERROR: IRTS.CodegenLLVM: " ++ msg
115−
116−mainDef :: Global
117−mainDef =
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− ]}
140−
141−initDefs :: Target -> [Definition]
142−initDefs 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)
253−
254− mpzBinFun n = exfun ("__gmpz_" ++ n) VoidType [pmpz, pmpz, pmpz] False
255−
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− }
265−
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 }
275−
276−isApple :: Target -> Bool
277−isApple (Target { triple = t }) = isJust . stripPrefix "-apple" $ dropWhile (/= '-') t
278−
279−stdinName, stdoutName, stderrName :: Target -> String
280−stdinName t | isApple t = "__stdinp"
281−stdinName _ = "stdin"
282−stdoutName t | isApple t = "__stdoutp"
283−stdoutName _ = "stdout"
284−stderrName t | isApple t = "__stderrp"
285−stderrName _ = "stderr"
286−
287−getStdIn, getStdOut, getStdErr :: Codegen Operand
288−getStdIn = ConstantOperand . C.GlobalReference . Name . stdinName <$> asks target
289−getStdOut = ConstantOperand . C.GlobalReference . Name . stdoutName <$> asks target
290−getStdErr = ConstantOperand . C.GlobalReference . Name . stderrName <$> asks target
291−
292−codegen :: Target -> [SDecl] -> Module
293−codegen 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
296−
297−valueType :: Type
298−valueType = NamedTypeReference (Name "valTy")
299−
300−nullValue :: C.Constant
301−nullValue = C.Null (PointerType valueType (AddrSpace 0))
302−
303−primTy :: Type -> Type
304−primTy inner = StructureType False [IntegerType 32, inner]
305−
306−mpzTy :: Type
307−mpzTy = NamedTypeReference (Name "mpz")
308−
309−conType :: Word64 -> Type
310−conType nargs = StructureType False
311− [ IntegerType 32
312− , ArrayType nargs (PointerType valueType (AddrSpace 0))
313− ]
314−
315−data MGS = MGS { mgsNextGlobalName :: Word
316− , mgsForeignSyms :: Map String (FType, [FType])
317− }
318−
319−type Modgen = RWS Target [Definition] MGS
320−
321−initialMGS :: MGS
322−initialMGS = MGS { mgsNextGlobalName = 0
323− , mgsForeignSyms = M.empty
324− }
325−
326−cgDef :: SDecl -> Modgen Definition
327−cgDef (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− }
357−
358−type CGW = ([(Name, Type)], [BasicBlock], [Definition])
359−
360−type Env = [Maybe Operand]
361−
362−data CGS = CGS { nextName :: Word
363− , nextGlobalName :: Word
364− , currentBlockName :: Name
365− , instAccum :: [Named Instruction]
366− , lexenv :: Env
367− , foreignSyms :: Map String (FType, [FType])
368− }
369−
370−data CGR = CGR { target :: Target
371− , funcName :: String }
372−
373−type Codegen = RWS CGR CGW CGS
374−
375−getFuncName :: Codegen String
376−getFuncName = asks funcName
377−
378−getGlobalUnName :: Codegen Name
379−getGlobalUnName = do
380− i <- gets nextGlobalName
381− modify $ \s -> s { nextGlobalName = 1 + i }
382− return (UnName i)
383−
384−getUnName :: Codegen Name
385−getUnName = do
386− i <- gets nextName
387− modify $ \s -> s { nextName = 1 + i }
388− return (UnName i)
389−
390−getName :: String -> Codegen Name
391−getName n = do
392− i <- gets nextName
393− modify $ \s -> s { nextName = 1 + i }
394− return (Name $ n ++ show i)
395−
396−alloca :: Name -> Type -> Codegen ()
397−alloca n t = tell ([(n, t)], [], [])
398−
399−terminate :: Terminator -> Codegen ()
400−terminate 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)], [])
406−
407−newBlock :: Name -> Codegen ()
408−newBlock name = modify $ \s -> s { instAccum = []
409− , currentBlockName = name
410− }
411−
412−inst :: Instruction -> Codegen Operand
413−inst i = do
414− n <- getUnName
415− modify $ \s -> s { instAccum = instAccum s ++ [n := i] }
416− return $ LocalReference n
417−
418−ninst :: String -> Instruction -> Codegen Operand
419−ninst name i = do
420− n <- getName name
421− modify $ \s -> s { instAccum = instAccum s ++ [n := i] }
422− return $ LocalReference n
423−
424−inst' :: Instruction -> Codegen ()
425−inst' i = modify $ \s -> s { instAccum = instAccum s ++ [Do i] }
426−
427−insts :: [Named Instruction] -> Codegen ()
428−insts is = modify $ \s -> s { instAccum = instAccum s ++ is }
429−
430−var :: LVar -> Codegen (Maybe Operand)
431−var (Loc level) = (!! level) <$> gets lexenv
432−var (Glob n) = return . Just . ConstantOperand . C.GlobalReference . Name $ show n
433−
434−binds :: Env -> Codegen (Maybe Operand) -> Codegen (Maybe Operand)
435−binds 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
441−
442−replaceElt :: Int -> a -> [a] -> [a]
443−replaceElt _ val [] = error "replaceElt: Ran out of list"
444−replaceElt 0 val (x:xs) = val:xs
445−replaceElt n val (x:xs) = x : replaceElt (n-1) val xs
446−
447−alloc' :: Operand -> Codegen Operand
448−alloc' size = inst $ simpleCall "GC_malloc" [size]
449−
450−allocAtomic' :: Operand -> Codegen Operand
451−allocAtomic' size = inst $ simpleCall "GC_malloc_atomic" [size]
452−
453−alloc :: Type -> Codegen Operand
454−alloc ty = do
455− size <- sizeOf ty
456− mem <- alloc' size
457− inst $ BitCast mem (PointerType ty (AddrSpace 0)) []
458−
459−allocAtomic :: Type -> Codegen Operand
460−allocAtomic ty = do
461− size <- sizeOf ty
462− mem <- allocAtomic' size
463− inst $ BitCast mem (PointerType ty (AddrSpace 0)) []
464−
465−sizeOf :: Type -> Codegen Operand
466−sizeOf ty = ConstantOperand . C.PtrToInt
467− (C.GetElementPtr True (C.Null (PointerType ty (AddrSpace 0))) [C.Int 32 1])
468− . IntegerType <$> getWordSize
469−
470−loadInv :: Operand -> Instruction
471−loadInv ptr = Load False ptr Nothing 0 [("invariant.load", MetadataNode [])]
472−
473−tgtWordSize :: Target -> Word32
474−tgtWordSize (Target { dataLayout = DataLayout { pointerLayouts = l } }) =
475− fst . fromJust $ M.lookup (AddrSpace 0) l
476−
477−getWordSize :: Codegen Word32
478−getWordSize = tgtWordSize <$> asks target
479−
480−cgExpr :: SExp -> Codegen (Maybe Operand)
481−cgExpr (SV v) = var v
482−cgExpr (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 })
489−cgExpr (SLet _ varExpr bodyExpr) = do
490− val <- cgExpr varExpr
491− binds [val] $ cgExpr bodyExpr
492−cgExpr (SUpdate (Loc level) expr) = do
493− val <- cgExpr expr
494− modify $ \s -> s { lexenv = replaceElt level val (lexenv s) }
495− return val
496−cgExpr (SUpdate x expr) = cgExpr expr
497−cgExpr (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)) [])
514−cgExpr (SCase _ inspect alts) = do
515− val <- var inspect
516− case val of
517− Nothing -> return Nothing
518− Just v -> cgCase v alts
519−cgExpr (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)] [])
548−cgExpr (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 [])
559−cgExpr (SConst c) = Just <$> cgConst c
560−cgExpr (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
580−cgExpr (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
585−cgExpr SNothing = return . Just . ConstantOperand $ nullValue
586−cgExpr (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
600−
601−cgCase :: Operand -> [SAlt] -> Codegen (Maybe Operand)
602−cgCase 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
612−
613− isConstCase (SConstCase {}) = True
614− isConstCase _ = False
615−
616− isConCase (SConCase {}) = True
617− isConCase _ = False
618−
619− isDefCase (SDefaultCase _) = True
620− isDefCase _ = False
621−
622− getDefExp (SDefaultCase e) = Just e
623− getDefExp _ = Nothing
624−
625−cgPrimCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
626−cgPrimCase 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)
646−
647−cgConCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
648−cgConCase 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)
661−
662−cgChainCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
663−cgChainCase 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)
695−
696−finishCase :: Env -> Name -> [Maybe (Operand, Name, Env)] -> Codegen (Maybe Operand)
697−finishCase 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) [])
707−
708−
709−cgDefaultAlt :: Name -> Name -> Maybe SExp -> Codegen (Maybe (Operand, Name, Env))
710−cgDefaultAlt 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
723−
724−cgAlt :: Env -> Name -> Name -> Maybe (Operand, [String]) -> SExp
725− -> Codegen (Maybe (Operand, Name, Env))
726−cgAlt 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
747−
748−mergeEnvs :: [(Name, Env)] -> Codegen ()
749−mergeEnvs 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 }
763−
764−nameAlt :: Name -> SAlt -> Codegen Name
765−nameAlt d (SDefaultCase _) = return d
766−nameAlt _ (SConCase _ _ name _ _) = getName (show name)
767−nameAlt _ (SConstCase const _) = getName (show const)
768−
769−isHeapFTy :: FType -> Bool
770−isHeapFTy f = elem f [FString, FPtr, FAny, FArith (ATInt ITBig)]
771−
772−box :: FType -> Operand -> Codegen Operand
773−box FUnit _ = return $ ConstantOperand nullValue
774−box 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)) []
784−
785−unbox :: FType -> Operand -> Codegen Operand
786−unbox FUnit x = return x
787−unbox 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 []
791−
792−cgConst' :: TT.Const -> C.Constant
793−cgConst' (TT.I i) = C.Int 32 (fromIntegral i)
794−cgConst' (TT.B8 i) = C.Int 8 (fromIntegral i)
795−cgConst' (TT.B16 i) = C.Int 16 (fromIntegral i)
796−cgConst' (TT.B32 i) = C.Int 32 (fromIntegral i)
797−cgConst' (TT.B64 i) = C.Int 64 (fromIntegral i)
798−cgConst' (TT.B8V v) = C.Vector (map ((C.Int 8) . fromIntegral) . V.toList $ v)
799−cgConst' (TT.B16V v) = C.Vector (map ((C.Int 16) . fromIntegral) . V.toList $ v)
800−cgConst' (TT.B32V v) = C.Vector (map ((C.Int 32) . fromIntegral) . V.toList $ v)
801−cgConst' (TT.B64V v) = C.Vector (map ((C.Int 64) . fromIntegral) . V.toList $ v)
802−
803−cgConst' (TT.BI i) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) (show i) ++ [C.Int 8 0])
804−cgConst' (TT.Fl f) = C.Float (F.Double f)
805−cgConst' (TT.Ch c) = C.Int 32 . fromIntegral . fromEnum $ c
806−cgConst' (TT.Str s) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) s ++ [C.Int 8 0])
807−cgConst' x = ierror $ "Unsupported constant: " ++ show x
808−
809−cgConst :: TT.Const -> Codegen Operand
810−cgConst c@(TT.I _) = box (FArith (ATInt ITNative)) (ConstantOperand $ cgConst' c)
811−cgConst c@(TT.B8 _) = box (FArith (ATInt (ITFixed IT8))) (ConstantOperand $ cgConst' c)
812−cgConst c@(TT.B16 _) = box (FArith (ATInt (ITFixed IT16))) (ConstantOperand $ cgConst' c)
813−cgConst c@(TT.B32 _) = box (FArith (ATInt (ITFixed IT32))) (ConstantOperand $ cgConst' c)
814−cgConst c@(TT.B64 _) = box (FArith (ATInt (ITFixed IT64))) (ConstantOperand $ cgConst' c)
815−cgConst c@(TT.B8V v) = box (FArith (ATInt (ITVec IT8 (V.length v)))) (ConstantOperand $ cgConst' c)
816−cgConst c@(TT.B16V v) = box (FArith (ATInt (ITVec IT16 (V.length v)))) (ConstantOperand $ cgConst' c)
817−cgConst c@(TT.B32V v) = box (FArith (ATInt (ITVec IT32 (V.length v)))) (ConstantOperand $ cgConst' c)
818−cgConst c@(TT.B64V v) = box (FArith (ATInt (ITVec IT64 (V.length v)))) (ConstantOperand $ cgConst' c)
819−cgConst c@(TT.Fl _) = box (FArith ATFloat) (ConstantOperand $ cgConst' c)
820−cgConst c@(TT.Ch _) = box (FArith (ATInt ITChar)) (ConstantOperand $ cgConst' c)
821−cgConst 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])
824−cgConst 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
833−cgConst x = return $ ConstantOperand nullValue
834−
835−numDigits :: Integer -> Integer -> Integer
836−numDigits 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)
841−
842−addGlobal :: Global -> Codegen ()
843−addGlobal def = tell ([], [], [GlobalDefinition def])
844−
845−addGlobal' :: Type -> C.Constant -> Codegen C.Constant
846−addGlobal' 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
857−
858−
859−ensureCDecl :: String -> FType -> [FType] -> Codegen Operand
860−ensureCDecl 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))
868−
869−ffunDecl :: String -> FType -> [FType] -> Global
870−ffunDecl 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− }
878−
879−ftyToTy :: FType -> Type
880−ftyToTy (FArith (ATInt ITNative)) = IntegerType 32
881−ftyToTy (FArith (ATInt ITBig)) = PointerType mpzTy (AddrSpace 0)
882−ftyToTy (FArith (ATInt (ITFixed ty))) = IntegerType (fromIntegral $ nativeTyWidth ty)
883−ftyToTy (FArith (ATInt (ITVec e c)))
884− = VectorType (fromIntegral c) (IntegerType (fromIntegral $ nativeTyWidth e))
885−ftyToTy (FArith (ATInt ITChar)) = IntegerType 32
886−ftyToTy (FArith ATFloat) = FloatingPointType 64 IEEE
887−ftyToTy FString = PointerType (IntegerType 8) (AddrSpace 0)
888−ftyToTy FUnit = VoidType
889−ftyToTy FPtr = PointerType (IntegerType 8) (AddrSpace 0)
890−ftyToTy FAny = valueType
891−
892−-- Only use when known not to be ITBig
893−itWidth :: IntTy -> Word32
894−itWidth ITNative = 32
895−itWidth ITChar = 32
896−itWidth (ITFixed x) = fromIntegral $ nativeTyWidth x
897−itWidth x = ierror $ "itWidth: " ++ show x
898−
899−itConst :: IntTy -> Integer -> C.Constant
900−itConst (ITFixed n) x = C.Int (fromIntegral $ nativeTyWidth n) x
901−itConst ITNative x = itConst (ITFixed IT32) x
902−itConst ITChar x = itConst (ITFixed IT32) x
903−itConst (ITVec elts size) x = C.Vector (replicate size (itConst (ITFixed elts) x))
904−
905−cgOp :: PrimFn -> [Operand] -> Codegen Operand
906−cgOp (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
913−cgOp (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
921−cgOp (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
929−
930−-- ITChar, ITNative, and IT32 all share representation
931−cgOp (LChInt ITNative) [x] = return x
932−cgOp (LIntCh ITNative) [x] = return x
933−
934−cgOp (LSLt (ATInt ITBig)) [x,y] = mpzCmp IPred.SLT x y
935−cgOp (LSLe (ATInt ITBig)) [x,y] = mpzCmp IPred.SLE x y
936−cgOp (LEq (ATInt ITBig)) [x,y] = mpzCmp IPred.EQ x y
937−cgOp (LSGe (ATInt ITBig)) [x,y] = mpzCmp IPred.SGE x y
938−cgOp (LSGt (ATInt ITBig)) [x,y] = mpzCmp IPred.SGT x y
939−cgOp (LPlus (ATInt ITBig)) [x,y] = mpzBin "add" x y
940−cgOp (LMinus (ATInt ITBig)) [x,y] = mpzBin "sub" x y
941−cgOp (LTimes (ATInt ITBig)) [x,y] = mpzBin "mul" x y
942−cgOp (LSDiv (ATInt ITBig)) [x,y] = mpzBin "fdiv_q" x y
943−cgOp (LSRem (ATInt ITBig)) [x,y] = mpzBin "fdiv_r" x y
944−cgOp (LAnd ITBig) [x,y] = mpzBin "and" x y
945−cgOp (LOr ITBig) [x,y] = mpzBin "ior" x y
946−cgOp (LXOr ITBig) [x,y] = mpzBin "xor" x y
947−cgOp (LCompl ITBig) [x] = mpzUn "com" x
948−cgOp (LSHL ITBig) [x,y] = mpzBit "mul_2exp" x y
949−cgOp (LASHR ITBig) [x,y] = mpzBit "fdiv_q_2exp" x y
950−
951−cgOp (LTrunc ITNative (ITFixed to)) [x]
952− | 32 >= nativeTyWidth to = iCoerce Trunc IT32 to x
953−cgOp (LZExt ITNative (ITFixed to)) [x]
954− | 32 <= nativeTyWidth to = iCoerce ZExt IT32 to x
955−cgOp (LSExt ITNative (ITFixed to)) [x]
956− | 32 <= nativeTyWidth to = iCoerce SExt IT32 to x
957−
958−cgOp (LTrunc (ITFixed from) ITNative) [x]
959− | nativeTyWidth from >= 32 = iCoerce Trunc from IT32 x
960−cgOp (LZExt (ITFixed from) ITNative) [x]
961− | nativeTyWidth from <= 32 = iCoerce ZExt from IT32 x
962−cgOp (LSExt (ITFixed from) ITNative) [x]
963− | nativeTyWidth from <= 32 = iCoerce SExt from IT32 x
964−
965−cgOp (LTrunc (ITFixed from) (ITFixed to)) [x]
966− | nativeTyWidth from > nativeTyWidth to = iCoerce Trunc from to x
967−cgOp (LZExt (ITFixed from) (ITFixed to)) [x]
968− | nativeTyWidth from < nativeTyWidth to = iCoerce ZExt from to x
969−cgOp (LSExt (ITFixed from) (ITFixed to)) [x]
970− | nativeTyWidth from < nativeTyWidth to = iCoerce SExt from to x
971−
972−cgOp (LSLt (ATInt ity)) [x,y] = iCmp ity IPred.SLT x y
973−cgOp (LSLe (ATInt ity)) [x,y] = iCmp ity IPred.SLE x y
974−cgOp (LLt ity) [x,y] = iCmp ity IPred.ULT x y
975−cgOp (LLe ity) [x,y] = iCmp ity IPred.ULE x y
976−cgOp (LEq (ATInt ity)) [x,y] = iCmp ity IPred.EQ x y
977−cgOp (LSGe (ATInt ity)) [x,y] = iCmp ity IPred.SGE x y
978−cgOp (LSGt (ATInt ity)) [x,y] = iCmp ity IPred.SGT x y
979−cgOp (LGe ity) [x,y] = iCmp ity IPred.UGE x y
980−cgOp (LGt ity) [x,y] = iCmp ity IPred.UGT x y
981−cgOp (LPlus ty@(ATInt _)) [x,y] = binary ty x y (Add False False)
982−cgOp (LMinus ty@(ATInt _)) [x,y] = binary ty x y (Sub False False)
983−cgOp (LTimes ty@(ATInt _)) [x,y] = binary ty x y (Mul False False)
984−cgOp (LSDiv ty@(ATInt _)) [x,y] = binary ty x y (SDiv False)
985−cgOp (LSRem ty@(ATInt _)) [x,y] = binary ty x y SRem
986−cgOp (LUDiv ity) [x,y] = binary (ATInt ity) x y (UDiv False)
987−cgOp (LURem ity) [x,y] = binary (ATInt ity) x y URem
988−cgOp (LAnd ity) [x,y] = binary (ATInt ity) x y And
989−cgOp (LOr ity) [x,y] = binary (ATInt ity) x y Or
990−cgOp (LXOr ity) [x,y] = binary (ATInt ity) x y Xor
991−cgOp (LCompl ity) [x] = unary (ATInt ity) x (Xor . ConstantOperand $ itConst ity (-1))
992−cgOp (LSHL ity) [x,y] = binary (ATInt ity) x y (Shl False False)
993−cgOp (LLSHR ity) [x,y] = binary (ATInt ity) x y (LShr False)
994−cgOp (LASHR ity) [x,y] = binary (ATInt ity) x y (AShr False)
995−
996−cgOp (LSLt ATFloat) [x,y] = fCmp FPred.OLT x y
997−cgOp (LSLe ATFloat) [x,y] = fCmp FPred.OLE x y
998−cgOp (LEq ATFloat) [x,y] = fCmp FPred.OEQ x y
999−cgOp (LSGe ATFloat) [x,y] = fCmp FPred.OGE x y
1000−cgOp (LSGt ATFloat) [x,y] = fCmp FPred.OGT x y
1001−cgOp (LPlus ATFloat) [x,y] = binary ATFloat x y FAdd
1002−cgOp (LMinus ATFloat) [x,y] = binary ATFloat x y FSub
1003−cgOp (LTimes ATFloat) [x,y] = binary ATFloat x y FMul
1004−cgOp (LSDiv ATFloat) [x,y] = binary ATFloat x y FDiv
1005−
1006−cgOp LFExp [x] = nunary ATFloat "llvm.exp.f64" x
1007−cgOp LFLog [x] = nunary ATFloat "llvm.log.f64" x
1008−cgOp LFSin [x] = nunary ATFloat "llvm.sin.f64" x
1009−cgOp LFCos [x] = nunary ATFloat "llvm.cos.f64" x
1010−cgOp LFTan [x] = nunary ATFloat "tan" x
1011−cgOp LFASin [x] = nunary ATFloat "asin" x
1012−cgOp LFACos [x] = nunary ATFloat "acos" x
1013−cgOp LFATan [x] = nunary ATFloat "atan" x
1014−cgOp LFSqrt [x] = nunary ATFloat "llvm.sqrt.f64" x
1015−cgOp LFFloor [x] = nunary ATFloat "llvm.floor.f64" x
1016−cgOp LFCeil [x] = nunary ATFloat "llvm.ceil.f64" x
1017−
1018−cgOp (LIntFloat ITBig) [x] = do
1019− x' <- unbox (FArith (ATInt ITBig)) x
1020− uflt <- inst $ simpleCall "__gmpz_get_d" [ x' ]
1021− box (FArith ATFloat) uflt
1022−
1023−cgOp (LIntFloat ity) [x] = do
1024− x' <- unbox (FArith (ATInt ity)) x
1025− x'' <- inst $ SIToFP x' (FloatingPointType 64 IEEE) []
1026− box (FArith ATFloat) x''
1027−
1028−cgOp (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
1034−
1035−cgOp (LFloatInt ity) [x] = do
1036− x' <- unbox (FArith ATFloat) x
1037− x'' <- inst $ FPToSI x' (ftyToTy $ cmpResultTy ity) []
1038− box (FArith (ATInt ity)) x''
1039−
1040−cgOp LFloatStr [x] = do
1041− x' <- unbox (FArith ATFloat) x
1042− ustr <- inst (idrCall "__idris_floatStr" [x'])
1043− box FString ustr
1044−
1045−cgOp LNoOp xs = return $ last xs
1046−
1047−cgOp (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
1053−
1054−cgOp (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
1059−
1060−cgOp (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'
1067−
1068−cgOp (LBitCast from to) [x] = do
1069− nx <- unbox (FArith from) x
1070− nx' <- inst $ BitCast nx (ftyToTy (FArith to)) []
1071− box (FArith to) nx'
1072−
1073−cgOp 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
1080−
1081−cgOp 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
1088−
1089−cgOp (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'
1095− ]
1096− box FString ustr
1097−cgOp (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''])
1103−cgOp (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
1108−cgOp (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
1114− ]
1115− nx' <- case ity of
1116− (ITFixed IT64) -> return nx
1117− _ -> inst $ Trunc nx (IntegerType (itWidth ity)) []
1118− box (FArith (ATInt ity)) nx'
1119−
1120−cgOp LStrConcat [x,y] = cgStrCat x y
1121−
1122−cgOp 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
1128−
1129−cgOp 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'
1134−
1135−cgOp 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'
1142−
1143−cgOp LStrTail [c] = do
1144− s <- unbox FString c
1145− c <- inst $ GetElementPtr True s [ConstantOperand $ C.Int 32 1] []
1146− box FString c
1147−
1148−cgOp 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'
1157−
1158−cgOp LStrRev [s] = do
1159− ns <- unbox FString s
1160− box FString =<< inst (simpleCall "__idris_strRev" [ns])
1161−
1162−cgOp LReadStr [p] = do
1163− np <- unbox FPtr p
1164− s <- inst $ simpleCall "__idris_readStr" [np]
1165− box FString s
1166−
1167−cgOp LStdIn [] = do
1168− stdin <- getStdIn
1169− ptr <- inst $ loadInv stdin
1170− box FPtr ptr
1171−cgOp LStdOut [] = do
1172− stdout <- getStdOut
1173− ptr <- inst $ loadInv stdout
1174− box FPtr ptr
1175−cgOp LStdErr [] = do
1176− stdErr <- getStdErr
1177− ptr <- inst $ loadInv stdErr
1178− box FPtr ptr
1179−
1180−cgOp LNullPtr [] = box FPtr (ConstantOperand $ C.Null (PointerType (IntegerType 8) (AddrSpace 0)))
1181−
1182−cgOp prim args = ierror $ "Unimplemented primitive: <" ++ show prim ++ ">("
1183− ++ intersperse ',' (take (length args) ['a'..]) ++ ")"
1184−
1185−iCoerce :: (Operand -> Type -> InstructionMetadata -> Instruction) -> NativeTy -> NativeTy -> Operand -> Codegen Operand
1186−iCoerce _ from to x | from == to = return x
1187−iCoerce 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''
1191−
1192−cgStrCat :: Operand -> Operand -> Codegen Operand
1193−cgStrCat 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
1212−
1213−binary :: ArithTy -> Operand -> Operand
1214− -> (Operand -> Operand -> InstructionMetadata -> Instruction) -> Codegen Operand
1215−binary 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
1220−
1221−unary :: ArithTy -> Operand
1222− -> (Operand -> InstructionMetadata -> Instruction) -> Codegen Operand
1223−unary ty x instCon = do
1224− nx <- unbox (FArith ty) x
1225− nr <- inst $ instCon nx []
1226− box (FArith ty) nr
1227−
1228−nunary :: ArithTy -> String
1229− -> Operand -> Codegen Operand
1230−nunary ty name x = do
1231− nx <- unbox (FArith ty) x
1232− nr <- inst $ simpleCall name [nx]
1233− box (FArith ty) nr
1234−
1235−iCmp :: IntTy -> IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand
1236−iCmp 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'
1242−
1243−fCmp :: FPred.FloatingPointPredicate -> Operand -> Operand -> Codegen Operand
1244−fCmp 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
1249−
1250−cmpResultTy :: IntTy -> FType
1251−cmpResultTy v@(ITVec _ _) = FArith (ATInt v)
1252−cmpResultTy _ = FArith (ATInt (ITFixed IT32))
1253−
1254−mpzBin :: String -> Operand -> Operand -> Codegen Operand
1255−mpzBin 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
1262−
1263−mpzBit :: String -> Operand -> Operand -> Codegen Operand
1264−mpzBit 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
1272−
1273−mpzUn :: String -> Operand -> Codegen Operand
1274−mpzUn 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
1280−
1281−mpzCmp :: IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand
1282−mpzCmp 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
1289−
1290−simpleCall :: String -> [Operand] -> Instruction
1291−simpleCall 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 = []
1299− }
1300−
1301−idrCall :: String -> [Operand] -> Instruction
1302−idrCall 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 = []
1310− }
1311−
1312−assert :: Operand -> String -> Codegen ()
1313−assert 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