idris-0.9.14: src/IRTS/CodegenLLVM.hs
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module IRTS.CodegenLLVM (codegenLLVM) where
import IRTS.CodegenCommon
import IRTS.Lang
import IRTS.Simplified
import IRTS.System
import qualified Idris.Core.TT as TT
import Idris.Core.TT (ArithTy(..), IntTy(..), NativeTy(..), nativeTyWidth)
import Util.System
import LLVM.General.Context
import LLVM.General.Diagnostic
import LLVM.General.AST
import LLVM.General.AST.AddrSpace
import LLVM.General.Target ( TargetMachine
, withTargetOptions, withTargetMachine, getTargetMachineDataLayout
, initializeAllTargets, lookupTarget
)
import LLVM.General.AST.DataLayout
import qualified LLVM.General.PassManager as PM
import qualified LLVM.General.Module as MO
import qualified LLVM.General.AST.IntegerPredicate as IPred
import qualified LLVM.General.AST.FloatingPointPredicate as FPred
import qualified LLVM.General.AST.Linkage as L
import qualified LLVM.General.AST.Visibility as V
import qualified LLVM.General.AST.CallingConvention as CC
import qualified LLVM.General.AST.Attribute as A
import qualified LLVM.General.AST.Global as G
import qualified LLVM.General.AST.Constant as C
import qualified LLVM.General.AST.Float as F
import qualified LLVM.General.Relocation as R
import qualified LLVM.General.CodeModel as CM
import qualified LLVM.General.CodeGenOpt as CGO
import Data.List
import Data.Maybe
import Data.Word
import Data.Map (Map)
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Vector.Unboxed as V
import Control.Applicative
import Control.Monad.RWS
import Control.Monad.Writer
import Control.Monad.State
import Control.Monad.Error
import qualified System.Info as SI (arch, os)
import System.IO
import System.Directory (removeFile)
import System.FilePath ((</>))
import System.Process (rawSystem)
import System.Exit (ExitCode(..))
import Debug.Trace
data Target = Target { triple :: String, dataLayout :: DataLayout }
codegenLLVM :: CodeGenerator
codegenLLVM ci = codegenLLVM' (simpleDecls ci) (targetTriple ci)
(targetCPU ci) (optimisation ci)
(outputFile ci) (outputType ci)
codegenLLVM' :: [(TT.Name, SDecl)] ->
String -> -- target triple
String -> -- target CPU
Word -> -- Optimization degree
FilePath -> -- output file name
OutputType ->
IO ()
codegenLLVM' defs triple cpu optimize file outty = withContext $ \context -> do
initializeAllTargets
(target, _) <- failInIO $ lookupTarget Nothing triple
withTargetOptions $ \options ->
withTargetMachine target triple cpu S.empty options R.Default CM.Default CGO.Default $ \tm ->
do layout <- getTargetMachineDataLayout tm
let ast = codegen (Target triple layout) (map snd defs)
result <- runErrorT . MO.withModuleFromAST context ast $ \m ->
do let opts = PM.defaultCuratedPassSetSpec
{ PM.optLevel = Just optimize
, PM.simplifyLibCalls = Just True
, PM.useInlinerWithThreshold = Just 225
}
when (optimize /= 0) $ PM.withPassManager opts $ void . flip PM.runPassManager m
outputModule tm file outty m
case result of
Right _ -> return ()
Left msg -> ierror msg
failInIO :: ErrorT String IO a -> IO a
failInIO = either fail return <=< runErrorT
outputModule :: TargetMachine -> FilePath -> OutputType -> MO.Module -> IO ()
outputModule _ file Raw m = failInIO $ MO.writeBitcodeToFile file m
outputModule tm file Object m = failInIO $ MO.writeObjectToFile tm file m
outputModule tm file Executable m = withTmpFile $ \obj -> do
outputModule tm obj Object m
cc <- getCC
defs <- (</> "llvm" </> "libidris_rts.a") <$> getDataDir
exit <- rawSystem cc [obj, defs, "-lm", "-lgmp", "-lgc", "-o", file]
when (exit /= ExitSuccess) $ ierror "FAILURE: Linking"
outputModule _ _ MavenProject _ = ierror "FAILURE: unsupported output type"
withTmpFile :: (FilePath -> IO a) -> IO a
withTmpFile f = do
(path, handle) <- tempfile
hClose handle
result <- f path
removeFile path
return result
ierror :: String -> a
ierror msg = error $ "INTERNAL ERROR: IRTS.CodegenLLVM: " ++ msg
mainDef :: Global
mainDef =
functionDefaults
{ G.returnType = IntegerType 32
, G.parameters =
([ Parameter (IntegerType 32) (Name "argc") []
, Parameter (PointerType (PointerType (IntegerType 8) (AddrSpace 0)) (AddrSpace 0)) (Name "argv") []
], False)
, G.name = Name "main"
, G.basicBlocks =
[ BasicBlock (UnName 0)
[ Do $ simpleCall "GC_init" [] -- Initialize Boehm GC
, Do $ simpleCall "__gmp_set_memory_functions"
[ ConstantOperand . C.GlobalReference . Name $ "__idris_gmpMalloc"
, ConstantOperand . C.GlobalReference . Name $ "__idris_gmpRealloc"
, ConstantOperand . C.GlobalReference . Name $ "__idris_gmpFree"
]
, Do $ Store False (ConstantOperand . C.GlobalReference . Name $ "__idris_argc")
(LocalReference (Name "argc")) Nothing 0 []
, Do $ Store False (ConstantOperand . C.GlobalReference . Name $ "__idris_argv")
(LocalReference (Name "argv")) Nothing 0 []
, UnName 1 := idrCall "{runMain0}" [] ]
(Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [])
]}
initDefs :: Target -> [Definition]
initDefs tgt =
[ TypeDefinition (Name "valTy")
(Just $ StructureType False
[ IntegerType 32
, ArrayType 0 (PointerType valueType (AddrSpace 0))
])
, TypeDefinition (Name "mpz")
(Just $ StructureType False
[ IntegerType 32
, IntegerType 32
, PointerType intPtr (AddrSpace 0)
])
, GlobalDefinition $ globalVariableDefaults
{ G.name = Name "__idris_intFmtStr"
, G.linkage = L.Internal
, G.isConstant = True
, G.hasUnnamedAddr = True
, G.type' = ArrayType 5 (IntegerType 8)
, G.initializer = Just $ C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) "%lld" ++ [C.Int 8 0])
}
, rtsFun "intStr" ptrI8 [IntegerType 64]
[ BasicBlock (UnName 0)
[ UnName 1 := simpleCall "GC_malloc_atomic" [ConstantOperand (C.Int (tgtWordSize tgt) 21)]
, UnName 2 := simpleCall "snprintf"
[ LocalReference (UnName 1)
, ConstantOperand (C.Int (tgtWordSize tgt) 21)
, ConstantOperand $ C.GetElementPtr True (C.GlobalReference . Name $ "__idris_intFmtStr") [C.Int 32 0, C.Int 32 0]
, LocalReference (UnName 0)
]
]
(Do $ Ret (Just (LocalReference (UnName 1))) [])
]
, GlobalDefinition $ globalVariableDefaults
{ G.name = Name "__idris_floatFmtStr"
, G.linkage = L.Internal
, G.isConstant = True
, G.hasUnnamedAddr = True
, G.type' = ArrayType 5 (IntegerType 8)
, G.initializer = Just $ C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) "%g" ++ [C.Int 8 0])
}
, rtsFun "floatStr" ptrI8 [FloatingPointType 64 IEEE]
[ BasicBlock (UnName 0)
[ UnName 1 := simpleCall "GC_malloc_atomic" [ConstantOperand (C.Int (tgtWordSize tgt) 21)]
, UnName 2 := simpleCall "snprintf"
[ LocalReference (UnName 1)
, ConstantOperand (C.Int (tgtWordSize tgt) 21)
, ConstantOperand $ C.GetElementPtr True (C.GlobalReference . Name $ "__idris_floatFmtStr") [C.Int 32 0, C.Int 32 0]
, LocalReference (UnName 0)
]
]
(Do $ Ret (Just (LocalReference (UnName 1))) [])
]
, exfun "llvm.sin.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False
, exfun "llvm.cos.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False
, exfun "llvm.pow.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False
, exfun "llvm.ceil.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False
, exfun "llvm.floor.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False
, exfun "llvm.exp.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False
, exfun "llvm.log.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False
, exfun "llvm.sqrt.f64" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False
, exfun "tan" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False
, exfun "asin" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False
, exfun "acos" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False
, exfun "atan" (FloatingPointType 64 IEEE) [ FloatingPointType 64 IEEE ] False
, exfun "llvm.trap" VoidType [] False
-- , exfun "llvm.llvm.memcpy.p0i8.p0i8.i32" VoidType [ptrI8, ptrI8, IntegerType 32, IntegerType 32, IntegerType 1] False
-- , exfun "llvm.llvm.memcpy.p0i8.p0i8.i64" VoidType [ptrI8, ptrI8, IntegerType 64, IntegerType 32, IntegerType 1] False
, exfun "memcpy" ptrI8 [ptrI8, ptrI8, intPtr] False
, exfun "llvm.invariant.start" (PointerType (StructureType False []) (AddrSpace 0)) [IntegerType 64, ptrI8] False
, exfun "snprintf" (IntegerType 32) [ptrI8, intPtr, ptrI8] True
, exfun "strcmp" (IntegerType 32) [ptrI8, ptrI8] False
, exfun "strlen" intPtr [ptrI8] False
, exfun "GC_init" VoidType [] False
, exfun "GC_malloc" ptrI8 [intPtr] False
, exfun "GC_malloc_atomic" ptrI8 [intPtr] False
, exfun "__gmp_set_memory_functions" VoidType
[ PointerType (FunctionType ptrI8 [intPtr] False) (AddrSpace 0)
, PointerType (FunctionType ptrI8 [ptrI8, intPtr, intPtr] False) (AddrSpace 0)
, PointerType (FunctionType VoidType [ptrI8, intPtr] False) (AddrSpace 0)
] False
, exfun "__gmpz_init" VoidType [pmpz] False
, exfun "__gmpz_init_set_str" (IntegerType 32) [pmpz, ptrI8, IntegerType 32] False
, exfun "__gmpz_get_str" ptrI8 [ptrI8, IntegerType 32, pmpz] False
, exfun "__gmpz_get_ui" intPtr [pmpz] False
, exfun "__gmpz_cmp" (IntegerType 32) [pmpz, pmpz] False
, exfun "__gmpz_fdiv_q_2exp" VoidType [pmpz, pmpz, intPtr] False
, exfun "__gmpz_mul_2exp" VoidType [pmpz, pmpz, intPtr] False
, exfun "__gmpz_get_d" (FloatingPointType 64 IEEE) [pmpz] False
, exfun "__gmpz_set_d" VoidType [pmpz, FloatingPointType 64 IEEE] False
, exfun "mpz_get_ull" (IntegerType 64) [pmpz] False
, exfun "mpz_init_set_ull" VoidType [pmpz, IntegerType 64] False
, exfun "mpz_init_set_sll" VoidType [pmpz, IntegerType 64] False
, exfun "__idris_strCons" ptrI8 [IntegerType 8, ptrI8] False
, exfun "__idris_readStr" ptrI8 [ptrI8] False -- Actually pointer to FILE, but it's opaque anyway
, exfun "__idris_gmpMalloc" ptrI8 [intPtr] False
, exfun "__idris_gmpRealloc" ptrI8 [ptrI8, intPtr, intPtr] False
, exfun "__idris_gmpFree" VoidType [ptrI8, intPtr] False
, exfun "__idris_strRev" ptrI8 [ptrI8] False
, exfun "strtoll" (IntegerType 64) [ptrI8, PointerType ptrI8 (AddrSpace 0), IntegerType 32] False
, exfun "putErr" VoidType [ptrI8] False
, exVar (stdinName tgt) ptrI8
, exVar (stdoutName tgt) ptrI8
, exVar (stderrName tgt) ptrI8
, exVar "__idris_argc" (IntegerType 32)
, exVar "__idris_argv" (PointerType ptrI8 (AddrSpace 0))
, GlobalDefinition mainDef
] ++ map mpzBinFun ["add", "sub", "mul", "fdiv_q", "fdiv_r", "and", "ior", "xor"]
where
intPtr = IntegerType (tgtWordSize tgt)
ptrI8 = PointerType (IntegerType 8) (AddrSpace 0)
pmpz = PointerType mpzTy (AddrSpace 0)
mpzBinFun n = exfun ("__gmpz_" ++ n) VoidType [pmpz, pmpz, pmpz] False
rtsFun :: String -> Type -> [Type] -> [BasicBlock] -> Definition
rtsFun name rty argtys def =
GlobalDefinition $ functionDefaults
{ G.linkage = L.Internal
, G.returnType = rty
, G.parameters = (flip map argtys $ \ty -> Parameter ty (UnName 0) [], False)
, G.name = Name $ "__idris_" ++ name
, G.basicBlocks = def
}
exfun :: String -> Type -> [Type] -> Bool -> Definition
exfun name rty argtys vari =
GlobalDefinition $ functionDefaults
{ G.returnType = rty
, G.name = Name name
, G.parameters = (flip map argtys $ \ty -> Parameter ty (UnName 0) [], vari)
}
exVar :: String -> Type -> Definition
exVar name ty = GlobalDefinition $ globalVariableDefaults { G.name = Name name, G.type' = ty }
isApple :: Target -> Bool
isApple (Target { triple = t }) = isJust . stripPrefix "-apple" $ dropWhile (/= '-') t
stdinName, stdoutName, stderrName :: Target -> String
stdinName t | isApple t = "__stdinp"
stdinName _ = "stdin"
stdoutName t | isApple t = "__stdoutp"
stdoutName _ = "stdout"
stderrName t | isApple t = "__stderrp"
stderrName _ = "stderr"
getStdIn, getStdOut, getStdErr :: Codegen Operand
getStdIn = ConstantOperand . C.GlobalReference . Name . stdinName <$> asks target
getStdOut = ConstantOperand . C.GlobalReference . Name . stdoutName <$> asks target
getStdErr = ConstantOperand . C.GlobalReference . Name . stderrName <$> asks target
codegen :: Target -> [SDecl] -> Module
codegen tgt defs = Module "idris" (Just . dataLayout $ tgt) (Just . triple $ tgt) (initDefs tgt ++ globals ++ gendefs)
where
(gendefs, _, globals) = runRWS (mapM cgDef defs) tgt initialMGS
valueType :: Type
valueType = NamedTypeReference (Name "valTy")
nullValue :: C.Constant
nullValue = C.Null (PointerType valueType (AddrSpace 0))
primTy :: Type -> Type
primTy inner = StructureType False [IntegerType 32, inner]
mpzTy :: Type
mpzTy = NamedTypeReference (Name "mpz")
conType :: Word64 -> Type
conType nargs = StructureType False
[ IntegerType 32
, ArrayType nargs (PointerType valueType (AddrSpace 0))
]
data MGS = MGS { mgsNextGlobalName :: Word
, mgsForeignSyms :: Map String (FType, [FType])
}
type Modgen = RWS Target [Definition] MGS
initialMGS :: MGS
initialMGS = MGS { mgsNextGlobalName = 0
, mgsForeignSyms = M.empty
}
cgDef :: SDecl -> Modgen Definition
cgDef (SFun name argNames _ expr) = do
nextGlobal <- gets mgsNextGlobalName
existingForeignSyms <- gets mgsForeignSyms
tgt <- ask
let (_, CGS { nextGlobalName = nextGlobal', foreignSyms = foreignSyms' }, (allocas, bbs, globals)) =
runRWS (do r <- cgExpr expr
case r of
Nothing -> terminate $ Unreachable []
Just r' -> terminate $ Ret (Just r') [])
(CGR tgt (show name))
(CGS 0 nextGlobal (Name "begin") [] (map (Just . LocalReference . Name . show) argNames) existingForeignSyms)
entryTerm = case bbs of
[] -> Do $ Ret Nothing []
BasicBlock n _ _:_ -> Do $ Br n []
tell globals
put (MGS { mgsNextGlobalName = nextGlobal', mgsForeignSyms = foreignSyms' })
return . GlobalDefinition $ functionDefaults
{ G.linkage = L.Internal
, G.callingConvention = CC.Fast
, G.name = Name (show name)
, G.returnType = PointerType valueType (AddrSpace 0)
, G.parameters = (flip map argNames $ \argName ->
Parameter (PointerType valueType (AddrSpace 0)) (Name (show argName)) []
, False)
, G.basicBlocks =
BasicBlock (Name "entry")
(map (\(n, t) -> n := Alloca t Nothing 0 []) allocas)
entryTerm
: bbs
}
type CGW = ([(Name, Type)], [BasicBlock], [Definition])
type Env = [Maybe Operand]
data CGS = CGS { nextName :: Word
, nextGlobalName :: Word
, currentBlockName :: Name
, instAccum :: [Named Instruction]
, lexenv :: Env
, foreignSyms :: Map String (FType, [FType])
}
data CGR = CGR { target :: Target
, funcName :: String }
type Codegen = RWS CGR CGW CGS
getFuncName :: Codegen String
getFuncName = asks funcName
getGlobalUnName :: Codegen Name
getGlobalUnName = do
i <- gets nextGlobalName
modify $ \s -> s { nextGlobalName = 1 + i }
return (UnName i)
getUnName :: Codegen Name
getUnName = do
i <- gets nextName
modify $ \s -> s { nextName = 1 + i }
return (UnName i)
getName :: String -> Codegen Name
getName n = do
i <- gets nextName
modify $ \s -> s { nextName = 1 + i }
return (Name $ n ++ show i)
alloca :: Name -> Type -> Codegen ()
alloca n t = tell ([(n, t)], [], [])
terminate :: Terminator -> Codegen ()
terminate term = do
name <- gets currentBlockName
insts <- gets instAccum
modify $ \s -> s { instAccum = ierror "Not in a block"
, currentBlockName = ierror "Not in a block" }
tell ([], [BasicBlock name insts (Do term)], [])
newBlock :: Name -> Codegen ()
newBlock name = modify $ \s -> s { instAccum = []
, currentBlockName = name
}
inst :: Instruction -> Codegen Operand
inst i = do
n <- getUnName
modify $ \s -> s { instAccum = instAccum s ++ [n := i] }
return $ LocalReference n
ninst :: String -> Instruction -> Codegen Operand
ninst name i = do
n <- getName name
modify $ \s -> s { instAccum = instAccum s ++ [n := i] }
return $ LocalReference n
inst' :: Instruction -> Codegen ()
inst' i = modify $ \s -> s { instAccum = instAccum s ++ [Do i] }
insts :: [Named Instruction] -> Codegen ()
insts is = modify $ \s -> s { instAccum = instAccum s ++ is }
var :: LVar -> Codegen (Maybe Operand)
var (Loc level) = (!! level) <$> gets lexenv
var (Glob n) = return . Just . ConstantOperand . C.GlobalReference . Name $ show n
binds :: Env -> Codegen (Maybe Operand) -> Codegen (Maybe Operand)
binds vals cg = do
envLen <- length <$> gets lexenv
modify $ \s -> s { lexenv = lexenv s ++ vals }
value <- cg
modify $ \s -> s { lexenv = take envLen $ lexenv s }
return value
replaceElt :: Int -> a -> [a] -> [a]
replaceElt _ val [] = error "replaceElt: Ran out of list"
replaceElt 0 val (x:xs) = val:xs
replaceElt n val (x:xs) = x : replaceElt (n-1) val xs
alloc' :: Operand -> Codegen Operand
alloc' size = inst $ simpleCall "GC_malloc" [size]
allocAtomic' :: Operand -> Codegen Operand
allocAtomic' size = inst $ simpleCall "GC_malloc_atomic" [size]
alloc :: Type -> Codegen Operand
alloc ty = do
size <- sizeOf ty
mem <- alloc' size
inst $ BitCast mem (PointerType ty (AddrSpace 0)) []
allocAtomic :: Type -> Codegen Operand
allocAtomic ty = do
size <- sizeOf ty
mem <- allocAtomic' size
inst $ BitCast mem (PointerType ty (AddrSpace 0)) []
sizeOf :: Type -> Codegen Operand
sizeOf ty = ConstantOperand . C.PtrToInt
(C.GetElementPtr True (C.Null (PointerType ty (AddrSpace 0))) [C.Int 32 1])
. IntegerType <$> getWordSize
loadInv :: Operand -> Instruction
loadInv ptr = Load False ptr Nothing 0 [("invariant.load", MetadataNode [])]
tgtWordSize :: Target -> Word32
tgtWordSize (Target { dataLayout = DataLayout { pointerLayouts = l } }) =
fst . fromJust $ M.lookup (AddrSpace 0) l
getWordSize :: Codegen Word32
getWordSize = tgtWordSize <$> asks target
cgExpr :: SExp -> Codegen (Maybe Operand)
cgExpr (SV v) = var v
cgExpr (SApp tailcall fname args) = do
argSlots <- mapM var args
case sequence argSlots of
Nothing -> return Nothing
Just argVals -> do
fn <- var (Glob fname)
Just <$> inst ((idrCall (show fname) argVals) { isTailCall = tailcall })
cgExpr (SLet _ varExpr bodyExpr) = do
val <- cgExpr varExpr
binds [val] $ cgExpr bodyExpr
cgExpr (SUpdate (Loc level) expr) = do
val <- cgExpr expr
modify $ \s -> s { lexenv = replaceElt level val (lexenv s) }
return val
cgExpr (SUpdate x expr) = cgExpr expr
cgExpr (SCon tag name args) = do
argSlots <- mapM var args
case sequence argSlots of
Nothing -> return Nothing
Just argVals -> do
let ty = conType . fromIntegral . length $ argVals
con <- alloc ty
tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []
inst' $ Store False tagPtr (ConstantOperand (C.Int 32 (fromIntegral tag))) Nothing 0 []
forM_ (zip argVals [0..]) $ \(arg, i) -> do
ptr <- inst $ GetElementPtr True con [ ConstantOperand (C.Int 32 0)
, ConstantOperand (C.Int 32 1)
, ConstantOperand (C.Int 32 i)] []
inst' $ Store False ptr arg Nothing 0 []
ptrI8 <- inst $ BitCast con (PointerType (IntegerType 8) (AddrSpace 0)) []
inst' $ simpleCall "llvm.invariant.start" [ConstantOperand $ C.Int 64 (-1), ptrI8]
Just <$> inst (BitCast con (PointerType valueType (AddrSpace 0)) [])
cgExpr (SCase inspect alts) = do
val <- var inspect
case val of
Nothing -> return Nothing
Just v -> cgCase v alts
cgExpr (SChkCase inspect alts) = do
mval <- var inspect
case mval of
Nothing -> return Nothing
Just val ->
do endBBN <- getName "endChkCase"
notNullBBN <- getName "notNull"
originBlock <- gets currentBlockName
isNull <- inst $ ICmp IPred.EQ val (ConstantOperand nullValue) []
terminate $ CondBr isNull endBBN notNullBBN []
newBlock notNullBBN
ptr <- inst $ BitCast val (PointerType (IntegerType 32) (AddrSpace 0)) []
flag <- inst $ Load False ptr Nothing 0 []
isVal <- inst $ ICmp IPred.EQ flag (ConstantOperand (C.Int 32 (-1))) []
conBBN <- getName "constructor"
terminate $ CondBr isVal endBBN conBBN []
newBlock conBBN
result <- cgCase val alts
caseExitBlock <- gets currentBlockName
case result of
Nothing -> do
terminate $ Unreachable []
newBlock endBBN
return $ Just val
Just caseVal -> do
terminate $ Br endBBN []
newBlock endBBN
Just <$> inst (Phi (PointerType valueType (AddrSpace 0))
[(val, originBlock), (val, notNullBBN), (caseVal, caseExitBlock)] [])
cgExpr (SProj conVar idx) = do
val <- var conVar
case val of
Nothing -> return Nothing
Just v ->
do ptr <- inst $ GetElementPtr True v
[ ConstantOperand (C.Int 32 0)
, ConstantOperand (C.Int 32 1)
, ConstantOperand (C.Int 32 (fromIntegral idx))
] []
Just <$> inst (Load False ptr Nothing 0 [])
cgExpr (SConst c) = Just <$> cgConst c
cgExpr (SForeign LANG_C rty fname args) = do
func <- ensureCDecl fname rty (map fst args)
argVals <- forM args $ \(fty, v) -> do
v' <- var v
case v' of
Just val -> return $ Just (fty, val)
Nothing -> return Nothing
case sequence argVals of
Nothing -> return Nothing
Just argVals' -> do
argUVals <- mapM (uncurry unbox) argVals'
result <- inst Call { isTailCall = False
, callingConvention = CC.C
, returnAttributes = []
, function = Right func
, arguments = map (\v -> (v, [])) argUVals
, functionAttributes = []
, metadata = []
}
Just <$> box rty result
cgExpr (SOp fn args) = do
argVals <- mapM var args
case sequence argVals of
Just ops -> Just <$> cgOp fn ops
Nothing -> return Nothing
cgExpr SNothing = return . Just . ConstantOperand $ nullValue
cgExpr (SError msg) = do
str <- addGlobal' (ArrayType (2 + fromIntegral (length msg)) (IntegerType 8))
(cgConst' (TT.Str (msg ++ "\n")))
inst' $ simpleCall "putErr" [ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0
, C.Int 32 0]]
inst' Call { isTailCall = True
, callingConvention = CC.C
, returnAttributes = []
, function = Right . ConstantOperand . C.GlobalReference . Name $ "llvm.trap"
, arguments = []
, functionAttributes = [A.NoReturn]
, metadata = []
}
return Nothing
cgCase :: Operand -> [SAlt] -> Codegen (Maybe Operand)
cgCase val alts =
case find isConstCase alts of
Just (SConstCase (TT.BI _) _) -> cgChainCase val defExp constAlts
Just (SConstCase (TT.Str _) _) -> cgChainCase val defExp constAlts
Just (SConstCase _ _) -> cgPrimCase val defExp constAlts
Nothing -> cgConCase val defExp conAlts
where
defExp = getDefExp =<< find isDefCase alts
constAlts = filter isConstCase alts
conAlts = filter isConCase alts
isConstCase (SConstCase {}) = True
isConstCase _ = False
isConCase (SConCase {}) = True
isConCase _ = False
isDefCase (SDefaultCase _) = True
isDefCase _ = False
getDefExp (SDefaultCase e) = Just e
getDefExp _ = Nothing
cgPrimCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
cgPrimCase caseValPtr defExp alts = do
let caseTy = case head alts of
SConstCase (TT.I _) _ -> IntegerType 32
SConstCase (TT.B8 _) _ -> IntegerType 8
SConstCase (TT.B16 _) _ -> IntegerType 16
SConstCase (TT.B32 _) _ -> IntegerType 32
SConstCase (TT.B64 _) _ -> IntegerType 64
SConstCase (TT.Fl _) _ -> FloatingPointType 64 IEEE
SConstCase (TT.Ch _) _ -> IntegerType 32
realPtr <- inst $ BitCast caseValPtr (PointerType (primTy caseTy) (AddrSpace 0)) []
valPtr <- inst $ GetElementPtr True realPtr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
caseVal <- inst $ Load False valPtr Nothing 0 []
defBlockName <- getName "default"
exitBlockName <- getName "caseExit"
namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
terminate $ Switch caseVal defBlockName (map (\(n, SConstCase c _) -> (cgConst' c, n)) namedAlts) []
initEnv <- gets lexenv
defResult <- cgDefaultAlt exitBlockName defBlockName defExp
results <- forM namedAlts $ \(name, SConstCase _ exp) -> cgAlt initEnv exitBlockName name Nothing exp
finishCase initEnv exitBlockName (defResult:results)
cgConCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
cgConCase con defExp alts = do
tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []
tag <- inst $ Load False tagPtr Nothing 0 []
defBlockName <- getName "default"
exitBlockName <- getName "caseExit"
namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
terminate $ Switch tag defBlockName (map (\(n, SConCase _ tag _ _ _) ->
(C.Int 32 (fromIntegral tag), n)) namedAlts) []
initEnv <- gets lexenv
defResult <- cgDefaultAlt exitBlockName defBlockName defExp
results <- forM namedAlts $ \(name, SConCase _ _ _ argns exp) ->
cgAlt initEnv exitBlockName name (Just (con, map show argns)) exp
finishCase initEnv exitBlockName (defResult:results)
cgChainCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
cgChainCase caseValPtr defExp alts = do
let (caseTy, comparator) =
case head alts of
SConstCase (TT.BI _) _ -> (FArith (ATInt ITBig), "__gmpz_cmp")
SConstCase (TT.Str _) _ -> (FString, "strcmp")
caseVal <- unbox caseTy caseValPtr
defBlockName <- getName "default"
exitBlockName <- getName "caseExit"
namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts
initEnv <- gets lexenv
results <- forM namedAlts $ \(name, SConstCase c e) ->
do const <- unbox caseTy =<< cgConst c
cmp <- inst $ simpleCall comparator [const, caseVal]
cmpResult <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) []
elseName <- getName "else"
terminate $ CondBr cmpResult name elseName []
result <- cgAlt initEnv exitBlockName name Nothing e
newBlock elseName
return result
modify $ \s -> s { lexenv = initEnv }
fname <- getFuncName
defaultVal <- cgExpr (fromMaybe (SError $ "Inexhaustive case failure in " ++ fname) defExp)
defaultBlock <- gets currentBlockName
defaultEnv <- gets lexenv
defResult <- case defaultVal of
Just v -> do
terminate $ Br exitBlockName []
return $ Just (v, defaultBlock, defaultEnv)
Nothing -> do
terminate $ Unreachable []
return Nothing
finishCase initEnv exitBlockName (defResult:results)
finishCase :: Env -> Name -> [Maybe (Operand, Name, Env)] -> Codegen (Maybe Operand)
finishCase initEnv exitBlockName results = do
let definedResults = mapMaybe id results
case definedResults of
[] -> do modify $ \s -> s { lexenv = initEnv }
return Nothing
xs -> do
newBlock exitBlockName
mergeEnvs $ map (\(_, altBlock, altEnv) -> (altBlock, altEnv)) xs
Just <$> inst (Phi (PointerType valueType (AddrSpace 0))
(map (\(altVal, altBlock, _) -> (altVal, altBlock)) xs) [])
cgDefaultAlt :: Name -> Name -> Maybe SExp -> Codegen (Maybe (Operand, Name, Env))
cgDefaultAlt exitName name exp = do
newBlock name
fname <- getFuncName
val <- cgExpr (fromMaybe (SError $ "Inexhaustive case failure in " ++ fname) exp)
env <- gets lexenv
block <- gets currentBlockName
case val of
Just v ->
do terminate $ Br exitName []
return $ Just (v, block, env)
Nothing ->
do terminate $ Unreachable []
return Nothing
cgAlt :: Env -> Name -> Name -> Maybe (Operand, [String]) -> SExp
-> Codegen (Maybe (Operand, Name, Env))
cgAlt initEnv exitBlockName name destr exp = do
modify $ \s -> s { lexenv = initEnv }
newBlock name
locals <- case destr of
Nothing -> return []
Just (con, argns) ->
forM (zip argns [0..]) $ \(argName, i) ->
do ptr <- inst $ GetElementPtr True con [ ConstantOperand (C.Int 32 0)
, ConstantOperand (C.Int 32 1)
, ConstantOperand (C.Int 32 i)] []
Just <$> ninst argName (Load False ptr Nothing 0 [])
altVal <- binds locals $ cgExpr exp
altEnv <- gets lexenv
altBlock <- gets currentBlockName
case altVal of
Just v -> do
terminate $ Br exitBlockName []
return $ Just (v, altBlock, altEnv)
Nothing -> do
terminate $ Unreachable []
return Nothing
mergeEnvs :: [(Name, Env)] -> Codegen ()
mergeEnvs es = do
let vars = transpose
. map (\(block, env) -> map (\x -> (x, block)) env)
$ es
env <- forM vars $ \var ->
case var of
[] -> ierror "mergeEnvs: impossible"
[(v, _)] -> return v
vs@((v, _):_)
| all (== v) (map fst vs) -> return v
| otherwise ->
let valid = map (\(a, b) -> (fromJust a, b)) . filter (isJust . fst) $ vs in
Just <$> inst (Phi (PointerType valueType (AddrSpace 0)) valid [])
modify $ \s -> s { lexenv = env }
nameAlt :: Name -> SAlt -> Codegen Name
nameAlt d (SDefaultCase _) = return d
nameAlt _ (SConCase _ _ name _ _) = getName (show name)
nameAlt _ (SConstCase const _) = getName (show const)
isHeapFTy :: FType -> Bool
isHeapFTy f = elem f [FString, FPtr, FAny, FArith (ATInt ITBig)]
box :: FType -> Operand -> Codegen Operand
box FUnit _ = return $ ConstantOperand nullValue
box fty fval = do
let ty = primTy (ftyToTy fty)
val <- if isHeapFTy fty then alloc ty else allocAtomic ty
tagptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []
valptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
inst' $ Store False tagptr (ConstantOperand (C.Int 32 (-1))) Nothing 0 []
inst' $ Store False valptr fval Nothing 0 []
ptrI8 <- inst $ BitCast val (PointerType (IntegerType 8) (AddrSpace 0)) []
inst' $ simpleCall "llvm.invariant.start" [ConstantOperand $ C.Int 64 (-1), ptrI8]
inst $ BitCast val (PointerType valueType (AddrSpace 0)) []
unbox :: FType -> Operand -> Codegen Operand
unbox FUnit x = return x
unbox fty bval = do
val <- inst $ BitCast bval (PointerType (primTy (ftyToTy fty)) (AddrSpace 0)) []
fvalptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []
inst $ Load False fvalptr Nothing 0 []
cgConst' :: TT.Const -> C.Constant
cgConst' (TT.I i) = C.Int 32 (fromIntegral i)
cgConst' (TT.B8 i) = C.Int 8 (fromIntegral i)
cgConst' (TT.B16 i) = C.Int 16 (fromIntegral i)
cgConst' (TT.B32 i) = C.Int 32 (fromIntegral i)
cgConst' (TT.B64 i) = C.Int 64 (fromIntegral i)
cgConst' (TT.B8V v) = C.Vector (map ((C.Int 8) . fromIntegral) . V.toList $ v)
cgConst' (TT.B16V v) = C.Vector (map ((C.Int 16) . fromIntegral) . V.toList $ v)
cgConst' (TT.B32V v) = C.Vector (map ((C.Int 32) . fromIntegral) . V.toList $ v)
cgConst' (TT.B64V v) = C.Vector (map ((C.Int 64) . fromIntegral) . V.toList $ v)
cgConst' (TT.BI i) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) (show i) ++ [C.Int 8 0])
cgConst' (TT.Fl f) = C.Float (F.Double f)
cgConst' (TT.Ch c) = C.Int 32 . fromIntegral . fromEnum $ c
cgConst' (TT.Str s) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) s ++ [C.Int 8 0])
cgConst' x = ierror $ "Unsupported constant: " ++ show x
cgConst :: TT.Const -> Codegen Operand
cgConst c@(TT.I _) = box (FArith (ATInt ITNative)) (ConstantOperand $ cgConst' c)
cgConst c@(TT.B8 _) = box (FArith (ATInt (ITFixed IT8))) (ConstantOperand $ cgConst' c)
cgConst c@(TT.B16 _) = box (FArith (ATInt (ITFixed IT16))) (ConstantOperand $ cgConst' c)
cgConst c@(TT.B32 _) = box (FArith (ATInt (ITFixed IT32))) (ConstantOperand $ cgConst' c)
cgConst c@(TT.B64 _) = box (FArith (ATInt (ITFixed IT64))) (ConstantOperand $ cgConst' c)
cgConst c@(TT.B8V v) = box (FArith (ATInt (ITVec IT8 (V.length v)))) (ConstantOperand $ cgConst' c)
cgConst c@(TT.B16V v) = box (FArith (ATInt (ITVec IT16 (V.length v)))) (ConstantOperand $ cgConst' c)
cgConst c@(TT.B32V v) = box (FArith (ATInt (ITVec IT32 (V.length v)))) (ConstantOperand $ cgConst' c)
cgConst c@(TT.B64V v) = box (FArith (ATInt (ITVec IT64 (V.length v)))) (ConstantOperand $ cgConst' c)
cgConst c@(TT.Fl _) = box (FArith ATFloat) (ConstantOperand $ cgConst' c)
cgConst c@(TT.Ch _) = box (FArith (ATInt ITChar)) (ConstantOperand $ cgConst' c)
cgConst c@(TT.Str s) = do
str <- addGlobal' (ArrayType (1 + fromIntegral (length s)) (IntegerType 8)) (cgConst' c)
box FString (ConstantOperand $ C.GetElementPtr True str [C.Int 32 0, C.Int 32 0])
cgConst c@(TT.BI i) = do
let stringRepLen = (if i < 0 then 2 else 1) + fromInteger (numDigits 10 i)
str <- addGlobal' (ArrayType stringRepLen (IntegerType 8)) (cgConst' c)
mpz <- alloc mpzTy
inst $ simpleCall "__gmpz_init_set_str" [mpz
, ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0, C.Int 32 0]
, ConstantOperand $ C.Int 32 10
]
box (FArith (ATInt ITBig)) mpz
cgConst x = return $ ConstantOperand nullValue
numDigits :: Integer -> Integer -> Integer
numDigits b n = 1 + fst (ilog b n) where
ilog b n
| n < b = (0, n)
| otherwise = let (e, r) = ilog (b*b) n
in if r < b then (2*e, r) else (2*e+1, r `div` b)
addGlobal :: Global -> Codegen ()
addGlobal def = tell ([], [], [GlobalDefinition def])
addGlobal' :: Type -> C.Constant -> Codegen C.Constant
addGlobal' ty val = do
name <- getGlobalUnName
addGlobal $ globalVariableDefaults
{ G.name = name
, G.linkage = L.Internal
, G.hasUnnamedAddr = True
, G.isConstant = True
, G.type' = ty
, G.initializer = Just val
}
return . C.GlobalReference $ name
ensureCDecl :: String -> FType -> [FType] -> Codegen Operand
ensureCDecl name rty argtys = do
syms <- gets foreignSyms
case M.lookup name syms of
Nothing -> do addGlobal (ffunDecl name rty argtys)
modify $ \s -> s { foreignSyms = M.insert name (rty, argtys) (foreignSyms s) }
Just (rty', argtys') -> unless (rty == rty' && argtys == argtys') . fail $
"Mismatched type declarations for foreign symbol \"" ++ name ++ "\": " ++ show (rty, argtys) ++ " vs " ++ show (rty', argtys')
return $ ConstantOperand (C.GlobalReference (Name name))
ffunDecl :: String -> FType -> [FType] -> Global
ffunDecl name rty argtys =
functionDefaults
{ G.returnType = ftyToTy rty
, G.name = Name name
, G.parameters = (flip map argtys $ \fty ->
Parameter (ftyToTy fty) (UnName 0) []
, False)
}
ftyToTy :: FType -> Type
ftyToTy (FArith (ATInt ITNative)) = IntegerType 32
ftyToTy (FArith (ATInt ITBig)) = PointerType mpzTy (AddrSpace 0)
ftyToTy (FArith (ATInt (ITFixed ty))) = IntegerType (fromIntegral $ nativeTyWidth ty)
ftyToTy (FArith (ATInt (ITVec e c)))
= VectorType (fromIntegral c) (IntegerType (fromIntegral $ nativeTyWidth e))
ftyToTy (FArith (ATInt ITChar)) = IntegerType 32
ftyToTy (FArith ATFloat) = FloatingPointType 64 IEEE
ftyToTy FString = PointerType (IntegerType 8) (AddrSpace 0)
ftyToTy FUnit = VoidType
ftyToTy FPtr = PointerType (IntegerType 8) (AddrSpace 0)
ftyToTy FAny = valueType
-- Only use when known not to be ITBig
itWidth :: IntTy -> Word32
itWidth ITNative = 32
itWidth ITChar = 32
itWidth (ITFixed x) = fromIntegral $ nativeTyWidth x
itWidth x = ierror $ "itWidth: " ++ show x
itConst :: IntTy -> Integer -> C.Constant
itConst (ITFixed n) x = C.Int (fromIntegral $ nativeTyWidth n) x
itConst ITNative x = itConst (ITFixed IT32) x
itConst ITChar x = itConst (ITFixed IT32) x
itConst (ITVec elts size) x = C.Vector (replicate size (itConst (ITFixed elts) x))
cgOp :: PrimFn -> [Operand] -> Codegen Operand
cgOp (LTrunc ITBig ity) [x] = do
nx <- unbox (FArith (ATInt ITBig)) x
val <- inst $ simpleCall "mpz_get_ull" [nx]
v <- case ity of
(ITFixed IT64) -> return val
_ -> inst $ Trunc val (ftyToTy (FArith (ATInt ity))) []
box (FArith (ATInt ity)) v
cgOp (LZExt from ITBig) [x] = do
nx <- unbox (FArith (ATInt from)) x
nx' <- case from of
(ITFixed IT64) -> return nx
_ -> inst $ ZExt nx (IntegerType 64) []
mpz <- alloc mpzTy
inst' $ simpleCall "mpz_init_set_ull" [mpz, nx']
box (FArith (ATInt ITBig)) mpz
cgOp (LSExt from ITBig) [x] = do
nx <- unbox (FArith (ATInt from)) x
nx' <- case from of
(ITFixed IT64) -> return nx
_ -> inst $ SExt nx (IntegerType 64) []
mpz <- alloc mpzTy
inst' $ simpleCall "mpz_init_set_sll" [mpz, nx']
box (FArith (ATInt ITBig)) mpz
-- ITChar, ITNative, and IT32 all share representation
cgOp (LChInt ITNative) [x] = return x
cgOp (LIntCh ITNative) [x] = return x
cgOp (LSLt (ATInt ITBig)) [x,y] = mpzCmp IPred.SLT x y
cgOp (LSLe (ATInt ITBig)) [x,y] = mpzCmp IPred.SLE x y
cgOp (LEq (ATInt ITBig)) [x,y] = mpzCmp IPred.EQ x y
cgOp (LSGe (ATInt ITBig)) [x,y] = mpzCmp IPred.SGE x y
cgOp (LSGt (ATInt ITBig)) [x,y] = mpzCmp IPred.SGT x y
cgOp (LPlus (ATInt ITBig)) [x,y] = mpzBin "add" x y
cgOp (LMinus (ATInt ITBig)) [x,y] = mpzBin "sub" x y
cgOp (LTimes (ATInt ITBig)) [x,y] = mpzBin "mul" x y
cgOp (LSDiv (ATInt ITBig)) [x,y] = mpzBin "fdiv_q" x y
cgOp (LSRem (ATInt ITBig)) [x,y] = mpzBin "fdiv_r" x y
cgOp (LAnd ITBig) [x,y] = mpzBin "and" x y
cgOp (LOr ITBig) [x,y] = mpzBin "ior" x y
cgOp (LXOr ITBig) [x,y] = mpzBin "xor" x y
cgOp (LCompl ITBig) [x] = mpzUn "com" x
cgOp (LSHL ITBig) [x,y] = mpzBit "mul_2exp" x y
cgOp (LASHR ITBig) [x,y] = mpzBit "fdiv_q_2exp" x y
cgOp (LTrunc ITNative (ITFixed to)) [x]
| 32 >= nativeTyWidth to = iCoerce Trunc IT32 to x
cgOp (LZExt ITNative (ITFixed to)) [x]
| 32 <= nativeTyWidth to = iCoerce ZExt IT32 to x
cgOp (LSExt ITNative (ITFixed to)) [x]
| 32 <= nativeTyWidth to = iCoerce SExt IT32 to x
cgOp (LTrunc (ITFixed from) ITNative) [x]
| nativeTyWidth from >= 32 = iCoerce Trunc from IT32 x
cgOp (LZExt (ITFixed from) ITNative) [x]
| nativeTyWidth from <= 32 = iCoerce ZExt from IT32 x
cgOp (LSExt (ITFixed from) ITNative) [x]
| nativeTyWidth from <= 32 = iCoerce SExt from IT32 x
cgOp (LTrunc (ITFixed from) (ITFixed to)) [x]
| nativeTyWidth from > nativeTyWidth to = iCoerce Trunc from to x
cgOp (LZExt (ITFixed from) (ITFixed to)) [x]
| nativeTyWidth from < nativeTyWidth to = iCoerce ZExt from to x
cgOp (LSExt (ITFixed from) (ITFixed to)) [x]
| nativeTyWidth from < nativeTyWidth to = iCoerce SExt from to x
cgOp (LSLt (ATInt ity)) [x,y] = iCmp ity IPred.SLT x y
cgOp (LSLe (ATInt ity)) [x,y] = iCmp ity IPred.SLE x y
cgOp (LLt ity) [x,y] = iCmp ity IPred.ULT x y
cgOp (LLe ity) [x,y] = iCmp ity IPred.ULE x y
cgOp (LEq (ATInt ity)) [x,y] = iCmp ity IPred.EQ x y
cgOp (LSGe (ATInt ity)) [x,y] = iCmp ity IPred.SGE x y
cgOp (LSGt (ATInt ity)) [x,y] = iCmp ity IPred.SGT x y
cgOp (LGe ity) [x,y] = iCmp ity IPred.UGE x y
cgOp (LGt ity) [x,y] = iCmp ity IPred.UGT x y
cgOp (LPlus ty@(ATInt _)) [x,y] = binary ty x y (Add False False)
cgOp (LMinus ty@(ATInt _)) [x,y] = binary ty x y (Sub False False)
cgOp (LTimes ty@(ATInt _)) [x,y] = binary ty x y (Mul False False)
cgOp (LSDiv ty@(ATInt _)) [x,y] = binary ty x y (SDiv False)
cgOp (LSRem ty@(ATInt _)) [x,y] = binary ty x y SRem
cgOp (LUDiv ity) [x,y] = binary (ATInt ity) x y (UDiv False)
cgOp (LURem ity) [x,y] = binary (ATInt ity) x y URem
cgOp (LAnd ity) [x,y] = binary (ATInt ity) x y And
cgOp (LOr ity) [x,y] = binary (ATInt ity) x y Or
cgOp (LXOr ity) [x,y] = binary (ATInt ity) x y Xor
cgOp (LCompl ity) [x] = unary (ATInt ity) x (Xor . ConstantOperand $ itConst ity (-1))
cgOp (LSHL ity) [x,y] = binary (ATInt ity) x y (Shl False False)
cgOp (LLSHR ity) [x,y] = binary (ATInt ity) x y (LShr False)
cgOp (LASHR ity) [x,y] = binary (ATInt ity) x y (AShr False)
cgOp (LSLt ATFloat) [x,y] = fCmp FPred.OLT x y
cgOp (LSLe ATFloat) [x,y] = fCmp FPred.OLE x y
cgOp (LEq ATFloat) [x,y] = fCmp FPred.OEQ x y
cgOp (LSGe ATFloat) [x,y] = fCmp FPred.OGE x y
cgOp (LSGt ATFloat) [x,y] = fCmp FPred.OGT x y
cgOp (LPlus ATFloat) [x,y] = binary ATFloat x y FAdd
cgOp (LMinus ATFloat) [x,y] = binary ATFloat x y FSub
cgOp (LTimes ATFloat) [x,y] = binary ATFloat x y FMul
cgOp (LSDiv ATFloat) [x,y] = binary ATFloat x y FDiv
cgOp LFExp [x] = nunary ATFloat "llvm.exp.f64" x
cgOp LFLog [x] = nunary ATFloat "llvm.log.f64" x
cgOp LFSin [x] = nunary ATFloat "llvm.sin.f64" x
cgOp LFCos [x] = nunary ATFloat "llvm.cos.f64" x
cgOp LFTan [x] = nunary ATFloat "tan" x
cgOp LFASin [x] = nunary ATFloat "asin" x
cgOp LFACos [x] = nunary ATFloat "acos" x
cgOp LFATan [x] = nunary ATFloat "atan" x
cgOp LFSqrt [x] = nunary ATFloat "llvm.sqrt.f64" x
cgOp LFFloor [x] = nunary ATFloat "llvm.floor.f64" x
cgOp LFCeil [x] = nunary ATFloat "llvm.ceil.f64" x
cgOp (LIntFloat ITBig) [x] = do
x' <- unbox (FArith (ATInt ITBig)) x
uflt <- inst $ simpleCall "__gmpz_get_d" [ x' ]
box (FArith ATFloat) uflt
cgOp (LIntFloat ity) [x] = do
x' <- unbox (FArith (ATInt ity)) x
x'' <- inst $ SIToFP x' (FloatingPointType 64 IEEE) []
box (FArith ATFloat) x''
cgOp (LFloatInt ITBig) [x] = do
x' <- unbox (FArith ATFloat) x
z <- alloc mpzTy
inst' $ simpleCall "__gmpz_init" [z]
inst' $ simpleCall "__gmpz_set_d" [ z, x' ]
box (FArith (ATInt ITBig)) z
cgOp (LFloatInt ity) [x] = do
x' <- unbox (FArith ATFloat) x
x'' <- inst $ FPToSI x' (ftyToTy $ cmpResultTy ity) []
box (FArith (ATInt ity)) x''
cgOp LFloatStr [x] = do
x' <- unbox (FArith ATFloat) x
ustr <- inst (idrCall "__idris_floatStr" [x'])
box FString ustr
cgOp LNoOp xs = return $ last xs
cgOp (LMkVec ety c) xs | c == length xs = do
nxs <- mapM (unbox (FArith (ATInt (ITFixed ety)))) xs
vec <- foldM (\v (e, i) -> inst $ InsertElement v e (ConstantOperand (C.Int 32 i)) [])
(ConstantOperand $ C.Vector (replicate c (C.Undef (IntegerType . fromIntegral $ nativeTyWidth ety))))
(zip nxs [0..])
box (FArith (ATInt (ITVec ety c))) vec
cgOp (LIdxVec ety c) [v,i] = do
nv <- unbox (FArith (ATInt (ITVec ety c))) v
ni <- unbox (FArith (ATInt (ITFixed IT32))) i
elt <- inst $ ExtractElement nv ni []
box (FArith (ATInt (ITFixed ety))) elt
cgOp (LUpdateVec ety c) [v,i,e] = do
let fty = FArith (ATInt (ITVec ety c))
nv <- unbox fty v
ni <- unbox (FArith (ATInt (ITFixed IT32))) i
ne <- unbox (FArith (ATInt (ITFixed ety))) e
nv' <- inst $ InsertElement nv ne ni []
box fty nv'
cgOp (LBitCast from to) [x] = do
nx <- unbox (FArith from) x
nx' <- inst $ BitCast nx (ftyToTy (FArith to)) []
box (FArith to) nx'
cgOp LStrEq [x,y] = do
x' <- unbox FString x
y' <- unbox FString y
cmp <- inst $ simpleCall "strcmp" [x', y']
flag <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) []
val <- inst $ ZExt flag (IntegerType 32) []
box (FArith (ATInt (ITFixed IT32))) val
cgOp LStrLt [x,y] = do
nx <- unbox FString x
ny <- unbox FString y
cmp <- inst $ simpleCall "strcmp" [nx, ny]
flag <- inst $ ICmp IPred.ULT cmp (ConstantOperand (C.Int 32 0)) []
val <- inst $ ZExt flag (IntegerType 32) []
box (FArith (ATInt (ITFixed IT32))) val
cgOp (LIntStr ITBig) [x] = do
x' <- unbox (FArith (ATInt ITBig)) x
ustr <- inst $ simpleCall "__gmpz_get_str"
[ ConstantOperand (C.Null (PointerType (IntegerType 8) (AddrSpace 0)))
, ConstantOperand (C.Int 32 10)
, x'
]
box FString ustr
cgOp (LIntStr ity) [x] = do
x' <- unbox (FArith (ATInt ity)) x
x'' <- if itWidth ity < 64
then inst $ SExt x' (IntegerType 64) []
else return x'
box FString =<< inst (idrCall "__idris_intStr" [x''])
cgOp (LStrInt ITBig) [s] = do
ns <- unbox FString s
mpz <- alloc mpzTy
inst $ simpleCall "__gmpz_init_set_str" [mpz, ns, ConstantOperand $ C.Int 32 10]
box (FArith (ATInt ITBig)) mpz
cgOp (LStrInt ity) [s] = do
ns <- unbox FString s
nx <- inst $ simpleCall "strtoll"
[ns
, ConstantOperand $ C.Null (PointerType (PointerType (IntegerType 8) (AddrSpace 0)) (AddrSpace 0))
, ConstantOperand $ C.Int 32 10
]
nx' <- case ity of
(ITFixed IT64) -> return nx
_ -> inst $ Trunc nx (IntegerType (itWidth ity)) []
box (FArith (ATInt ity)) nx'
cgOp LStrConcat [x,y] = cgStrCat x y
cgOp LStrCons [c,s] = do
nc <- unbox (FArith (ATInt ITChar)) c
ns <- unbox FString s
nc' <- inst $ Trunc nc (IntegerType 8) []
r <- inst $ simpleCall "__idris_strCons" [nc', ns]
box FString r
cgOp LStrHead [c] = do
s <- unbox FString c
c <- inst $ Load False s Nothing 0 []
c' <- inst $ ZExt c (IntegerType 32) []
box (FArith (ATInt ITChar)) c'
cgOp LStrIndex [s, i] = do
ns <- unbox FString s
ni <- unbox (FArith (ATInt (ITFixed IT32))) i
p <- inst $ GetElementPtr True ns [ni] []
c <- inst $ Load False p Nothing 0 []
c' <- inst $ ZExt c (IntegerType 32) []
box (FArith (ATInt ITChar)) c'
cgOp LStrTail [c] = do
s <- unbox FString c
c <- inst $ GetElementPtr True s [ConstantOperand $ C.Int 32 1] []
box FString c
cgOp LStrLen [s] = do
ns <- unbox FString s
len <- inst $ simpleCall "strlen" [ns]
ws <- getWordSize
len' <- case ws of
32 -> return len
x | x > 32 -> inst $ Trunc len (IntegerType 32) []
| x < 32 -> inst $ ZExt len (IntegerType 32) []
box (FArith (ATInt (ITFixed IT32))) len'
cgOp LStrRev [s] = do
ns <- unbox FString s
box FString =<< inst (simpleCall "__idris_strRev" [ns])
cgOp LReadStr [p] = do
np <- unbox FPtr p
s <- inst $ simpleCall "__idris_readStr" [np]
box FString s
cgOp LStdIn [] = do
stdin <- getStdIn
ptr <- inst $ loadInv stdin
box FPtr ptr
cgOp LStdOut [] = do
stdout <- getStdOut
ptr <- inst $ loadInv stdout
box FPtr ptr
cgOp LStdErr [] = do
stdErr <- getStdErr
ptr <- inst $ loadInv stdErr
box FPtr ptr
cgOp LNullPtr [] = box FPtr (ConstantOperand $ C.Null (PointerType (IntegerType 8) (AddrSpace 0)))
cgOp prim args = ierror $ "Unimplemented primitive: <" ++ show prim ++ ">("
++ intersperse ',' (take (length args) ['a'..]) ++ ")"
iCoerce :: (Operand -> Type -> InstructionMetadata -> Instruction) -> NativeTy -> NativeTy -> Operand -> Codegen Operand
iCoerce _ from to x | from == to = return x
iCoerce operator from to x = do
x' <- unbox (FArith (ATInt (ITFixed from))) x
x'' <- inst $ operator x' (ftyToTy (FArith (ATInt (ITFixed to)))) []
box (FArith (ATInt (ITFixed to))) x''
cgStrCat :: Operand -> Operand -> Codegen Operand
cgStrCat x y = do
x' <- unbox FString x
y' <- unbox FString y
xlen <- inst $ simpleCall "strlen" [x']
ylen <- inst $ simpleCall "strlen" [y']
zlen <- inst $ Add False True xlen ylen []
ws <- getWordSize
total <- inst $ Add False True zlen (ConstantOperand (C.Int ws 1)) []
mem <- allocAtomic' total
inst $ simpleCall "memcpy" [mem, x', xlen]
i <- inst $ PtrToInt mem (IntegerType ws) []
offi <- inst $ Add False True i xlen []
offp <- inst $ IntToPtr offi (PointerType (IntegerType 8) (AddrSpace 0)) []
inst $ simpleCall "memcpy" [offp, y', ylen]
j <- inst $ PtrToInt offp (IntegerType ws) []
offj <- inst $ Add False True j ylen []
end <- inst $ IntToPtr offj (PointerType (IntegerType 8) (AddrSpace 0)) []
inst' $ Store False end (ConstantOperand (C.Int 8 0)) Nothing 0 []
box FString mem
binary :: ArithTy -> Operand -> Operand
-> (Operand -> Operand -> InstructionMetadata -> Instruction) -> Codegen Operand
binary ty x y instCon = do
nx <- unbox (FArith ty) x
ny <- unbox (FArith ty) y
nr <- inst $ instCon nx ny []
box (FArith ty) nr
unary :: ArithTy -> Operand
-> (Operand -> InstructionMetadata -> Instruction) -> Codegen Operand
unary ty x instCon = do
nx <- unbox (FArith ty) x
nr <- inst $ instCon nx []
box (FArith ty) nr
nunary :: ArithTy -> String
-> Operand -> Codegen Operand
nunary ty name x = do
nx <- unbox (FArith ty) x
nr <- inst $ simpleCall name [nx]
box (FArith ty) nr
iCmp :: IntTy -> IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand
iCmp ity pred x y = do
nx <- unbox (FArith (ATInt ity)) x
ny <- unbox (FArith (ATInt ity)) y
nr <- inst $ ICmp pred nx ny []
nr' <- inst $ SExt nr (ftyToTy $ cmpResultTy ity) []
box (cmpResultTy ity) nr'
fCmp :: FPred.FloatingPointPredicate -> Operand -> Operand -> Codegen Operand
fCmp pred x y = do
nx <- unbox (FArith ATFloat) x
ny <- unbox (FArith ATFloat) y
nr <- inst $ FCmp pred nx ny []
box (FArith (ATInt (ITFixed IT32))) nr
cmpResultTy :: IntTy -> FType
cmpResultTy v@(ITVec _ _) = FArith (ATInt v)
cmpResultTy _ = FArith (ATInt (ITFixed IT32))
mpzBin :: String -> Operand -> Operand -> Codegen Operand
mpzBin name x y = do
nx <- unbox (FArith (ATInt ITBig)) x
ny <- unbox (FArith (ATInt ITBig)) y
nz <- alloc mpzTy
inst' $ simpleCall "__gmpz_init" [nz]
inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx, ny]
box (FArith (ATInt ITBig)) nz
mpzBit :: String -> Operand -> Operand -> Codegen Operand
mpzBit name x y = do
nx <- unbox (FArith (ATInt ITBig)) x
ny <- unbox (FArith (ATInt ITBig)) y
bitcnt <- inst $ simpleCall "__gmpz_get_ui" [ny]
nz <- alloc mpzTy
inst' $ simpleCall "__gmpz_init" [nz]
inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx, bitcnt]
box (FArith (ATInt ITBig)) nz
mpzUn :: String -> Operand -> Codegen Operand
mpzUn name x = do
nx <- unbox (FArith (ATInt ITBig)) x
nz <- alloc mpzTy
inst' $ simpleCall "__gmpz_init" [nz]
inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx]
box (FArith (ATInt ITBig)) nz
mpzCmp :: IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand
mpzCmp pred x y = do
nx <- unbox (FArith (ATInt ITBig)) x
ny <- unbox (FArith (ATInt ITBig)) y
cmp <- inst $ simpleCall "__gmpz_cmp" [nx, ny]
result <- inst $ ICmp pred cmp (ConstantOperand (C.Int 32 0)) []
i <- inst $ ZExt result (IntegerType 32) []
box (FArith (ATInt (ITFixed IT32))) i
simpleCall :: String -> [Operand] -> Instruction
simpleCall name args =
Call { isTailCall = False
, callingConvention = CC.C
, returnAttributes = []
, function = Right . ConstantOperand . C.GlobalReference . Name $ name
, arguments = map (\x -> (x, [])) args
, functionAttributes = []
, metadata = []
}
idrCall :: String -> [Operand] -> Instruction
idrCall name args =
Call { isTailCall = False
, callingConvention = CC.Fast
, returnAttributes = []
, function = Right . ConstantOperand . C.GlobalReference . Name $ name
, arguments = map (\x -> (x, [])) args
, functionAttributes = []
, metadata = []
}
assert :: Operand -> String -> Codegen ()
assert condition message = do
passed <- getName "assertPassed"
failed <- getName "assertFailed"
terminate $ CondBr condition passed failed []
newBlock failed
cgExpr (SError message)
terminate $ Unreachable []
newBlock passed