diff options
Diffstat (limited to 'compiler/llvmGen/LlvmCodeGen')
| -rw-r--r-- | compiler/llvmGen/LlvmCodeGen/Base.hs | 404 | ||||
| -rw-r--r-- | compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 1175 | ||||
| -rw-r--r-- | compiler/llvmGen/LlvmCodeGen/Data.hs | 155 | ||||
| -rw-r--r-- | compiler/llvmGen/LlvmCodeGen/Ppr.hs | 85 | ||||
| -rw-r--r-- | compiler/llvmGen/LlvmCodeGen/Regs.hs | 55 |
5 files changed, 1015 insertions, 859 deletions
diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index bcfce3401e..dda2c9e05b 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -13,15 +13,23 @@ module LlvmCodeGen.Base ( LlvmVersion, defaultLlvmVersion, minSupportLlvmVersion, maxSupportLlvmVersion, - LlvmEnv, initLlvmEnv, clearVars, varLookup, varInsert, - funLookup, funInsert, getLlvmVer, setLlvmVer, getLlvmPlatform, - getDflags, ghcInternalFunctions, + LlvmM, + runLlvm, liftStream, withClearVars, varLookup, varInsert, + markStackReg, checkStackReg, + funLookup, funInsert, getLlvmVer, getDynFlags, getDynFlag, getLlvmPlatform, + dumpIfSetLlvm, renderLlvm, runUs, markUsedVar, getUsedVars, + ghcInternalFunctions, + + getMetaUniqueId, + setUniqMeta, getUniqMeta, + freshSectionId, cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy, llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign, llvmPtrBits, mkLlvmFunc, tysToParams, - strCLabel_llvm, genCmmLabelRef, genStringLabelRef + strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm, + getGlobalPtr, generateAliases, ) where @@ -36,9 +44,15 @@ import DynFlags import FastString import Cmm import qualified Outputable as Outp +import qualified Pretty as Prt import Platform import UniqFM import Unique +import BufWrite ( BufHandle ) +import UniqSet +import UniqSupply +import ErrUtils +import qualified Stream -- ---------------------------------------------------------------------------- -- * Some Data Types @@ -93,30 +107,32 @@ llvmGhcCC dflags | otherwise = CC_Ncc 10 -- | Llvm Function type for Cmm function -llvmFunTy :: DynFlags -> LiveGlobalRegs -> LlvmType -llvmFunTy dflags live = LMFunction $ llvmFunSig' dflags live (fsLit "a") ExternallyVisible +llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType +llvmFunTy live = return . LMFunction =<< llvmFunSig' live (fsLit "a") ExternallyVisible -- | Llvm Function signature -llvmFunSig :: LlvmEnv -> LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LlvmFunctionDecl -llvmFunSig env live lbl link - = llvmFunSig' (getDflags env) live (strCLabel_llvm env lbl) link - -llvmFunSig' :: DynFlags -> LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmFunctionDecl -llvmFunSig' dflags live lbl link - = let toParams x | isPointer x = (x, [NoAlias, NoCapture]) - | otherwise = (x, []) - in LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs - (map (toParams . getVarType) (llvmFunArgs dflags live)) - (llvmFunAlign dflags) +llvmFunSig :: LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LlvmM LlvmFunctionDecl +llvmFunSig live lbl link = do + lbl' <- strCLabel_llvm lbl + llvmFunSig' live lbl' link + +llvmFunSig' :: LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmM LlvmFunctionDecl +llvmFunSig' live lbl link + = do let toParams x | isPointer x = (x, [NoAlias, NoCapture]) + | otherwise = (x, []) + dflags <- getDynFlags + return $ LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs + (map (toParams . getVarType) (llvmFunArgs dflags live)) + (llvmFunAlign dflags) -- | Create a Haskell function in LLVM. -mkLlvmFunc :: LlvmEnv -> LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks - -> LlvmFunction -mkLlvmFunc env live lbl link sec blks - = let dflags = getDflags env - funDec = llvmFunSig env live lbl link - funArgs = map (fsLit . getPlainName) (llvmFunArgs dflags live) - in LlvmFunction funDec funArgs llvmStdFunAttrs sec blks +mkLlvmFunc :: LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks + -> LlvmM LlvmFunction +mkLlvmFunc live lbl link sec blks + = do funDec <- llvmFunSig live lbl link + dflags <- getDynFlags + let funArgs = map (fsLit . Outp.showSDoc dflags . ppPlainName) (llvmFunArgs dflags live) + return $ LlvmFunction funDec funArgs llvmStdFunAttrs sec blks -- | Alignment to use for functions llvmFunAlign :: DynFlags -> LMAlign @@ -166,102 +182,292 @@ minSupportLlvmVersion :: LlvmVersion minSupportLlvmVersion = 28 maxSupportLlvmVersion :: LlvmVersion -maxSupportLlvmVersion = 33 +maxSupportLlvmVersion = 34 -- ---------------------------------------------------------------------------- -- * Environment Handling -- --- two maps, one for functions and one for local vars. -newtype LlvmEnv = LlvmEnv (LlvmEnvMap, LlvmEnvMap, LlvmVersion, DynFlags) +data LlvmEnv = LlvmEnv + { envVersion :: LlvmVersion -- ^ LLVM version + , envDynFlags :: DynFlags -- ^ Dynamic flags + , envOutput :: BufHandle -- ^ Output buffer + , envUniq :: UniqSupply -- ^ Supply of unique values + , envNextSection :: Int -- ^ Supply of fresh section IDs + , envFreshMeta :: Int -- ^ Supply of fresh metadata IDs + , envUniqMeta :: UniqFM Int -- ^ Global metadata nodes + , envFunMap :: LlvmEnvMap -- ^ Global functions so far, with type + , envAliases :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References] + , envUsedVars :: [LlvmVar] -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@) + + -- the following get cleared for every function (see @withClearVars@) + , envVarMap :: LlvmEnvMap -- ^ Local variables so far, with type + , envStackRegs :: [GlobalReg] -- ^ Non-constant registers (alloca'd in the function prelude) + } type LlvmEnvMap = UniqFM LlvmType --- | Get initial Llvm environment. -initLlvmEnv :: DynFlags -> LlvmEnv -initLlvmEnv dflags = LlvmEnv (initFuncs, emptyUFM, defaultLlvmVersion, dflags) - where initFuncs = listToUFM $ [ (n, LMFunction ty) | (n, ty) <- ghcInternalFunctions dflags ] +-- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad +newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) } +instance Monad LlvmM where + return x = LlvmM $ \env -> return (x, env) + m >>= f = LlvmM $ \env -> do (x, env') <- runLlvmM m env + runLlvmM (f x) env' +instance Functor LlvmM where + fmap f m = LlvmM $ \env -> do (x, env') <- runLlvmM m env + return (f x, env') --- | Here we pre-initialise some functions that are used internally by GHC --- so as to make sure they have the most general type in the case that --- user code also uses these functions but with a different type than GHC --- internally. (Main offender is treating return type as 'void' instead of --- 'void *'. Fixes trac #5486. -ghcInternalFunctions :: DynFlags -> [(LMString, LlvmFunctionDecl)] -ghcInternalFunctions dflags = - [ mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags] - , mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags] - , mk "memset" i8Ptr [i8Ptr, llvmWord dflags, llvmWord dflags] - , mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr] - ] - where - mk n ret args = - let n' = fsLit n - in (n', LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret - FixedArgs (tysToParams args) Nothing) - --- | Clear variables from the environment. -clearVars :: LlvmEnv -> LlvmEnv -clearVars (LlvmEnv (e1, _, n, p)) = {-# SCC "llvm_env_clear" #-} - LlvmEnv (e1, emptyUFM, n, p) - --- | Insert local variables into the environment. -varInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv -varInsert s t (LlvmEnv (e1, e2, n, p)) = {-# SCC "llvm_env_vinsert" #-} - LlvmEnv (e1, addToUFM e2 s t, n, p) - --- | Insert functions into the environment. -funInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv -funInsert s t (LlvmEnv (e1, e2, n, p)) = {-# SCC "llvm_env_finsert" #-} - LlvmEnv (addToUFM e1 s t, e2, n, p) - --- | Lookup local variables in the environment. -varLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType -varLookup s (LlvmEnv (_, e2, _, _)) = {-# SCC "llvm_env_vlookup" #-} - lookupUFM e2 s - --- | Lookup functions in the environment. -funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType -funLookup s (LlvmEnv (e1, _, _, _)) = {-# SCC "llvm_env_flookup" #-} - lookupUFM e1 s +instance HasDynFlags LlvmM where + getDynFlags = LlvmM $ \env -> return (envDynFlags env, env) + +-- | Lifting of IO actions. Not exported, as we want to encapsulate IO. +liftIO :: IO a -> LlvmM a +liftIO m = LlvmM $ \env -> do x <- m + return (x, env) + +-- | Get initial Llvm environment. +runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> UniqSupply -> LlvmM () -> IO () +runLlvm dflags ver out us m = do + _ <- runLlvmM m env + return () + where env = LlvmEnv { envFunMap = emptyUFM + , envVarMap = emptyUFM + , envStackRegs = [] + , envUsedVars = [] + , envAliases = emptyUniqSet + , envVersion = ver + , envDynFlags = dflags + , envOutput = out + , envUniq = us + , envFreshMeta = 0 + , envUniqMeta = emptyUFM + , envNextSection = 1 + } + +-- | Get environment (internal) +getEnv :: (LlvmEnv -> a) -> LlvmM a +getEnv f = LlvmM (\env -> return (f env, env)) + +-- | Modify environment (internal) +modifyEnv :: (LlvmEnv -> LlvmEnv) -> LlvmM () +modifyEnv f = LlvmM (\env -> return ((), f env)) + +-- | Lift a stream into the LlvmM monad +liftStream :: Stream.Stream IO a x -> Stream.Stream LlvmM a x +liftStream s = Stream.Stream $ do + r <- liftIO $ Stream.runStream s + case r of + Left b -> return (Left b) + Right (a, r2) -> return (Right (a, liftStream r2)) + +-- | Clear variables from the environment for a subcomputation +withClearVars :: LlvmM a -> LlvmM a +withClearVars m = LlvmM $ \env -> do + (x, env') <- runLlvmM m env { envVarMap = emptyUFM, envStackRegs = [] } + return (x, env' { envVarMap = emptyUFM, envStackRegs = [] }) + +-- | Insert variables or functions into the environment. +varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmM () +varInsert s t = modifyEnv $ \env -> env { envVarMap = addToUFM (envVarMap env) s t } +funInsert s t = modifyEnv $ \env -> env { envFunMap = addToUFM (envFunMap env) s t } + +-- | Lookup variables or functions in the environment. +varLookup, funLookup :: Uniquable key => key -> LlvmM (Maybe LlvmType) +varLookup s = getEnv (flip lookupUFM s . envVarMap) +funLookup s = getEnv (flip lookupUFM s . envFunMap) + +-- | Set a register as allocated on the stack +markStackReg :: GlobalReg -> LlvmM () +markStackReg r = modifyEnv $ \env -> env { envStackRegs = r : envStackRegs env } + +-- | Check whether a register is allocated on the stack +checkStackReg :: GlobalReg -> LlvmM Bool +checkStackReg r = getEnv ((elem r) . envStackRegs) + +-- | Allocate a new global unnamed metadata identifier +getMetaUniqueId :: LlvmM Int +getMetaUniqueId = LlvmM $ \env -> return (envFreshMeta env, env { envFreshMeta = envFreshMeta env + 1}) -- | Get the LLVM version we are generating code for -getLlvmVer :: LlvmEnv -> LlvmVersion -getLlvmVer (LlvmEnv (_, _, n, _)) = n +getLlvmVer :: LlvmM LlvmVersion +getLlvmVer = getEnv envVersion --- | Set the LLVM version we are generating code for -setLlvmVer :: LlvmVersion -> LlvmEnv -> LlvmEnv -setLlvmVer n (LlvmEnv (e1, e2, _, p)) = LlvmEnv (e1, e2, n, p) +-- | Get the platform we are generating code for +getDynFlag :: (DynFlags -> a) -> LlvmM a +getDynFlag f = getEnv (f . envDynFlags) -- | Get the platform we are generating code for -getLlvmPlatform :: LlvmEnv -> Platform -getLlvmPlatform (LlvmEnv (_, _, _, d)) = targetPlatform d +getLlvmPlatform :: LlvmM Platform +getLlvmPlatform = getDynFlag targetPlatform + +-- | Dumps the document if the corresponding flag has been set by the user +dumpIfSetLlvm :: DumpFlag -> String -> Outp.SDoc -> LlvmM () +dumpIfSetLlvm flag hdr doc = do + dflags <- getDynFlags + liftIO $ dumpIfSet_dyn dflags flag hdr doc + +-- | Prints the given contents to the output handle +renderLlvm :: Outp.SDoc -> LlvmM () +renderLlvm sdoc = do + + -- Write to output + dflags <- getDynFlags + out <- getEnv envOutput + let doc = Outp.withPprStyleDoc dflags (Outp.mkCodeStyle Outp.CStyle) sdoc + liftIO $ Prt.bufLeftRender out doc + + -- Dump, if requested + dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" sdoc + return () + +-- | Run a @UniqSM@ action with our unique supply +runUs :: UniqSM a -> LlvmM a +runUs m = LlvmM $ \env -> do + let (x, us') = initUs (envUniq env) m + return (x, env { envUniq = us' }) + +-- | Marks a variable as "used" +markUsedVar :: LlvmVar -> LlvmM () +markUsedVar v = modifyEnv $ \env -> env { envUsedVars = v : envUsedVars env } + +-- | Return all variables marked as "used" so far +getUsedVars :: LlvmM [LlvmVar] +getUsedVars = getEnv envUsedVars + +-- | Saves that at some point we didn't know the type of the label and +-- generated a reference to a type variable instead +saveAlias :: LMString -> LlvmM () +saveAlias lbl = modifyEnv $ \env -> env { envAliases = addOneToUniqSet (envAliases env) lbl } + +-- | Sets metadata node for a given unique +setUniqMeta :: Unique -> Int -> LlvmM () +setUniqMeta f m = modifyEnv $ \env -> env { envUniqMeta = addToUFM (envUniqMeta env) f m } +-- | Gets metadata node for given unique +getUniqMeta :: Unique -> LlvmM (Maybe Int) +getUniqMeta s = getEnv (flip lookupUFM s . envUniqMeta) + +-- | Returns a fresh section ID +freshSectionId :: LlvmM Int +freshSectionId = LlvmM $ \env -> return (envNextSection env, env { envNextSection = envNextSection env + 1}) + +-- ---------------------------------------------------------------------------- +-- * Internal functions +-- --- | Get the DynFlags for this compilation pass -getDflags :: LlvmEnv -> DynFlags -getDflags (LlvmEnv (_, _, _, d)) = d +-- | Here we pre-initialise some functions that are used internally by GHC +-- so as to make sure they have the most general type in the case that +-- user code also uses these functions but with a different type than GHC +-- internally. (Main offender is treating return type as 'void' instead of +-- 'void *'). Fixes trac #5486. +ghcInternalFunctions :: LlvmM () +ghcInternalFunctions = do + dflags <- getDynFlags + mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags] + mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags] + mk "memset" i8Ptr [i8Ptr, llvmWord dflags, llvmWord dflags] + mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr] + where + mk n ret args = do + let n' = fsLit n + decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret + FixedArgs (tysToParams args) Nothing + renderLlvm $ ppLlvmFunctionDecl decl + funInsert n' (LMFunction decl) -- ---------------------------------------------------------------------------- -- * Label handling -- -- | Pretty print a 'CLabel'. -strCLabel_llvm :: LlvmEnv -> CLabel -> LMString -strCLabel_llvm env l = {-# SCC "llvm_strCLabel" #-} - (fsLit . toString . pprCLabel (getLlvmPlatform env)) l - where dflags = getDflags env - style = Outp.mkCodeStyle Outp.CStyle - toString doc = Outp.renderWithStyle dflags doc style - --- | Create an external definition for a 'CLabel' defined in another module. -genCmmLabelRef :: LlvmEnv -> CLabel -> LMGlobal -genCmmLabelRef env = genStringLabelRef (getDflags env) . strCLabel_llvm env - --- | As above ('genCmmLabelRef') but taking a 'LMString', not 'CLabel'. -genStringLabelRef :: DynFlags -> LMString -> LMGlobal -genStringLabelRef dflags cl - = let ty = LMPointer $ LMArray 0 (llvmWord dflags) - in (LMGlobalVar cl ty External Nothing Nothing False, Nothing) +strCLabel_llvm :: CLabel -> LlvmM LMString +strCLabel_llvm lbl = do + platform <- getLlvmPlatform + dflags <- getDynFlags + let sdoc = pprCLabel platform lbl + str = Outp.renderWithStyle dflags sdoc (Outp.mkCodeStyle Outp.CStyle) + return (fsLit str) + +strDisplayName_llvm :: CLabel -> LlvmM LMString +strDisplayName_llvm lbl = do + platform <- getLlvmPlatform + dflags <- getDynFlags + let sdoc = pprCLabel platform lbl + depth = Outp.PartWay 1 + style = Outp.mkUserStyle (const Outp.NameNotInScope2, const True) depth + str = Outp.renderWithStyle dflags sdoc style + return (fsLit (dropInfoSuffix str)) + +dropInfoSuffix :: String -> String +dropInfoSuffix = go + where go "_info" = [] + go "_static_info" = [] + go "_con_info" = [] + go (x:xs) = x:go xs + go [] = [] + +strProcedureName_llvm :: CLabel -> LlvmM LMString +strProcedureName_llvm lbl = do + platform <- getLlvmPlatform + dflags <- getDynFlags + let sdoc = pprCLabel platform lbl + depth = Outp.PartWay 1 + style = Outp.mkUserStyle (const Outp.NameUnqual, const False) depth + str = Outp.renderWithStyle dflags sdoc style + return (fsLit str) + +-- ---------------------------------------------------------------------------- +-- * Global variables / forward references +-- + +-- | Create/get a pointer to a global value. Might return an alias if +-- the value in question hasn't been defined yet. We especially make +-- no guarantees on the type of the returned pointer. +getGlobalPtr :: LMString -> LlvmM LlvmVar +getGlobalPtr llvmLbl = do + m_ty <- funLookup llvmLbl + let mkGlbVar lbl ty = LMGlobalVar lbl (LMPointer ty) Private Nothing Nothing + case m_ty of + -- Directly reference if we have seen it already + Just ty -> return $ mkGlbVar llvmLbl ty Global + -- Otherwise use a forward alias of it + Nothing -> do + saveAlias llvmLbl + return $ mkGlbVar (llvmLbl `appendFS` fsLit "$alias") i8 Alias + +-- | Generate definitions for aliases forward-referenced by @getGlobalPtr@. +-- +-- Must be called at a point where we are sure that no new global definitions +-- will be generated anymore! +generateAliases :: LlvmM ([LMGlobal], [LlvmType]) +generateAliases = do + delayed <- fmap uniqSetToList $ getEnv envAliases + defss <- flip mapM delayed $ \lbl -> do + let var ty = LMGlobalVar lbl (LMPointer ty) External Nothing Nothing Global + aliasLbl = lbl `appendFS` fsLit "$alias" + aliasVar = LMGlobalVar aliasLbl i8Ptr Private Nothing Nothing Alias + -- If we have a definition, set the alias value using a + -- cost. Otherwise, declare it as an undefined external symbol. + m_ty <- funLookup lbl + case m_ty of + Just ty -> return [LMGlobal aliasVar $ Just $ LMBitc (LMStaticPointer (var ty)) i8Ptr] + Nothing -> return [LMGlobal (var i8) Nothing, + LMGlobal aliasVar $ Just $ LMStaticPointer (var i8) ] + -- Reset forward list + modifyEnv $ \env -> env { envAliases = emptyUniqSet } + return (concat defss, []) + +-- Note [Llvm Forward References] +-- +-- The issue here is that LLVM insists on being strongly typed at +-- every corner, so the first time we mention something, we have to +-- settle what type we assign to it. That makes things awkward, as Cmm +-- will often reference things before their definition, and we have no +-- idea what (LLVM) type it is going to be before that point. +-- +-- Our work-around is to define "aliases" of a standard type (i8 *) in +-- these kind of situations, which we later tell LLVM to be either +-- references to their actual local definitions (involving a cast) or +-- an external reference. This obviously only works for pointers. -- ---------------------------------------------------------------------------- -- * Misc diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 915981752e..6f898fa56c 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -29,232 +29,216 @@ import Platform import OrdList import UniqSupply import Unique -import Util -import Data.List ( partition ) +import Data.List ( nub ) +import Data.Maybe ( catMaybes ) type LlvmStatements = OrdList LlvmStatement -- ----------------------------------------------------------------------------- -- | Top-level of the LLVM proc Code generator -- -genLlvmProc :: LlvmEnv -> RawCmmDecl -> UniqSM (LlvmEnv, [LlvmCmmDecl]) -genLlvmProc env (CmmProc infos lbl live graph) = do +genLlvmProc :: RawCmmDecl -> LlvmM [LlvmCmmDecl] +genLlvmProc (CmmProc infos lbl live graph) = do let blocks = toBlockListEntryFirstFalseFallthrough graph - (env', lmblocks, lmdata) <- basicBlocksCodeGen env live blocks ([], []) + (lmblocks, lmdata) <- basicBlocksCodeGen live blocks let info = mapLookup (g_entry graph) infos proc = CmmProc info lbl live (ListGraph lmblocks) - return (env', proc:lmdata) + return (proc:lmdata) -genLlvmProc _ _ = panic "genLlvmProc: case that shouldn't reach here!" +genLlvmProc _ = panic "genLlvmProc: case that shouldn't reach here!" -- ----------------------------------------------------------------------------- -- * Block code generation -- --- | Generate code for a list of blocks that make up a complete procedure. -basicBlocksCodeGen :: LlvmEnv - -> LiveGlobalRegs - -> [CmmBlock] - -> ( [LlvmBasicBlock] , [LlvmCmmDecl] ) - -> UniqSM (LlvmEnv, [LlvmBasicBlock] , [LlvmCmmDecl] ) -basicBlocksCodeGen env live [] (blocks0, tops0) - = return (env, fblocks, tops) - where - dflags = getDflags env - blocks = reverse blocks0 - tops = reverse tops0 - (blocks', allocs) = mapAndUnzip dominateAllocs blocks - allocs' = concat allocs - (BasicBlock id fstmts : rblks) = blocks' - fblocks = (BasicBlock id $ funPrologue dflags live ++ allocs' ++ fstmts):rblks - -basicBlocksCodeGen env live (block:blocks) (lblocks, ltops) - = do (env', lb, lt) <- basicBlockCodeGen env block - basicBlocksCodeGen env' live blocks (lb : lblocks, reverse lt ++ ltops) +-- | Generate code for a list of blocks that make up a complete +-- procedure. The first block in the list is exepected to be the entry +-- point and will get the prologue. +basicBlocksCodeGen :: LiveGlobalRegs -> [CmmBlock] + -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl]) +basicBlocksCodeGen _ [] = panic "no entry block!" +basicBlocksCodeGen live (entryBlock:cmmBlocks) + = do (prologue, prologueTops) <- funPrologue live (entryBlock:cmmBlocks) + -- Generate code + (BasicBlock bid entry, entryTops) <- basicBlockCodeGen entryBlock + (blocks, topss) <- fmap unzip $ mapM basicBlockCodeGen cmmBlocks --- | Allocations need to be extracted so they can be moved to the entry --- of a function to make sure they dominate all possible paths in the CFG. -dominateAllocs :: LlvmBasicBlock -> (LlvmBasicBlock, [LlvmStatement]) -dominateAllocs (BasicBlock id stmts) - = let (allocs, stmts') = partition isAlloc stmts - isAlloc (Assignment _ (Alloca _ _)) = True - isAlloc _other = False - in (BasicBlock id stmts', allocs) + -- Compose + let entryBlock = BasicBlock bid (fromOL prologue ++ entry) + return (entryBlock : blocks, prologueTops ++ entryTops ++ concat topss) -- | Generate code for one block -basicBlockCodeGen :: LlvmEnv - -> CmmBlock - -> UniqSM ( LlvmEnv, LlvmBasicBlock, [LlvmCmmDecl] ) -basicBlockCodeGen env block +basicBlockCodeGen :: CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] ) +basicBlockCodeGen block = do let (CmmEntry id, nodes, tail) = blockSplit block - let stmts = blockToList nodes - (env', mid_instrs, top) <- stmtsToInstrs env stmts (nilOL, []) - (env'', tail_instrs, top') <- stmtToInstrs env' tail + (mid_instrs, top) <- stmtsToInstrs $ blockToList nodes + (tail_instrs, top') <- stmtToInstrs tail let instrs = fromOL (mid_instrs `appOL` tail_instrs) - return (env'', BasicBlock id instrs, top' ++ top) + return (BasicBlock id instrs, top' ++ top) -- ----------------------------------------------------------------------------- -- * CmmNode code generation -- -- A statement conversion return data. --- * LlvmEnv: The new environment -- * LlvmStatements: The compiled LLVM statements. -- * LlvmCmmDecl: Any global data needed. -type StmtData = (LlvmEnv, LlvmStatements, [LlvmCmmDecl]) +type StmtData = (LlvmStatements, [LlvmCmmDecl]) -- | Convert a list of CmmNode's to LlvmStatement's -stmtsToInstrs :: LlvmEnv -> [CmmNode e x] -> (LlvmStatements, [LlvmCmmDecl]) - -> UniqSM StmtData -stmtsToInstrs env [] (llvm, top) - = return (env, llvm, top) +stmtsToInstrs :: [CmmNode e x] -> LlvmM StmtData +stmtsToInstrs stmts + = do (instrss, topss) <- fmap unzip $ mapM stmtToInstrs stmts + return (concatOL instrss, concat topss) -stmtsToInstrs env (stmt : stmts) (llvm, top) - = do (env', instrs, tops) <- stmtToInstrs env stmt - stmtsToInstrs env' stmts (llvm `appOL` instrs, top ++ tops) +-- | Convert a CmmStmt to a list of LlvmStatement's +stmtToInstrs :: CmmNode e x -> LlvmM StmtData +stmtToInstrs stmt = case stmt of --- | Convert a CmmNode to a list of LlvmStatement's -stmtToInstrs :: LlvmEnv -> CmmNode e x - -> UniqSM StmtData -stmtToInstrs env stmt = case stmt of + CmmComment _ -> return (nilOL, []) -- nuke comments - CmmComment _ -> return (env, nilOL, []) -- nuke comments + CmmAssign reg src -> genAssign reg src + CmmStore addr src -> genStore addr src - CmmAssign reg src -> genAssign env reg src - CmmStore addr src -> genStore env addr src - - CmmBranch id -> genBranch env id - CmmCondBranch arg true false -> genCondBranch env arg true false - CmmSwitch arg ids -> genSwitch env arg ids + CmmBranch id -> genBranch id + CmmCondBranch arg true false + -> genCondBranch arg true false + CmmSwitch arg ids -> genSwitch arg ids -- Foreign Call - CmmUnsafeForeignCall target res args -> genCall env target res args + CmmUnsafeForeignCall target res args + -> genCall target res args -- Tail call CmmCall { cml_target = arg, - cml_args_regs = live } -> genJump env arg live + cml_args_regs = live } -> genJump arg live _ -> panic "Llvm.CodeGen.stmtToInstrs" +-- | Wrapper function to declare an instrinct function by function type +getInstrinct2 :: LMString -> LlvmType -> LlvmM ExprData +getInstrinct2 fname fty@(LMFunction funSig) = do + + let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing Constant + + fn <- funLookup fname + tops <- case fn of + Just _ -> + return [] + Nothing -> do + funInsert fname fty + return [CmmData Data [([],[fty])]] + + return (fv, nilOL, tops) + +getInstrinct2 _ _ = error "getInstrinct2: Non-function type!" + +-- | Declares an instrinct function by return and parameter types +getInstrinct :: LMString -> LlvmType -> [LlvmType] -> LlvmM ExprData +getInstrinct fname retTy parTys = + let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc retTy + FixedArgs (tysToParams parTys) Nothing + fty = LMFunction funSig + in getInstrinct2 fname fty + -- | Memory barrier instruction for LLVM >= 3.0 -barrier :: LlvmEnv -> UniqSM StmtData -barrier env = do +barrier :: LlvmM StmtData +barrier = do let s = Fence False SyncSeqCst - return (env, unitOL s, []) + return (unitOL s, []) -- | Memory barrier instruction for LLVM < 3.0 -oldBarrier :: LlvmEnv -> UniqSM StmtData -oldBarrier env = do - let dflags = getDflags env - let fname = fsLit "llvm.memory.barrier" - let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc LMVoid - FixedArgs (tysToParams [i1, i1, i1, i1, i1]) (llvmFunAlign dflags) - let fty = LMFunction funSig - - let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing False - let tops = case funLookup fname env of - Just _ -> [] - Nothing -> [CmmData Data [([],[fty])]] +oldBarrier :: LlvmM StmtData +oldBarrier = do + + (fv, _, tops) <- getInstrinct (fsLit "llvm.memory.barrier") LMVoid [i1, i1, i1, i1, i1] let args = [lmTrue, lmTrue, lmTrue, lmTrue, lmTrue] let s1 = Expr $ Call StdCall fv args llvmStdFunAttrs - let env' = funInsert fname fty env - return (env', unitOL s1, tops) + return (unitOL s1, tops) where lmTrue :: LlvmVar lmTrue = mkIntLit i1 (-1) -- | Foreign Calls -genCall :: LlvmEnv -> ForeignTarget -> [CmmFormal] -> [CmmActual] - -> UniqSM StmtData +genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] + -> LlvmM StmtData -- Write barrier needs to be handled specially as it is implemented as an LLVM -- intrinsic function. -genCall env (PrimTarget MO_WriteBarrier) _ _ - | platformArch (getLlvmPlatform env) `elem` [ArchX86, ArchX86_64, ArchSPARC] - = return (env, nilOL, []) - | getLlvmVer env > 29 = barrier env - | otherwise = oldBarrier env - -genCall env (PrimTarget MO_Touch) _ _ - = return (env, nilOL, []) - -genCall env (PrimTarget (MO_UF_Conv w)) [dst] [e] = do - let (env1, dstV, stmts1, top1) = getCmmReg env (CmmLocal dst) - ty = cmmToLlvmType $ localRegType dst +genCall (PrimTarget MO_WriteBarrier) _ _ = do + platform <- getLlvmPlatform + ver <- getLlvmVer + case () of + _ | platformArch platform `elem` [ArchX86, ArchX86_64, ArchSPARC] + -> return (nilOL, []) + | ver > 29 -> barrier + | otherwise -> oldBarrier + +genCall (PrimTarget MO_Touch) _ _ + = return (nilOL, []) + +genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = do + dstV <- getCmmReg (CmmLocal dst) + let ty = cmmToLlvmType $ localRegType dst width = widthToLlvmFloat w castV <- mkLocalVar ty - (env2, ve, stmts2, top2) <- exprToVar env1 e + (ve, stmts, top) <- exprToVar e let stmt3 = Assignment castV $ Cast LM_Uitofp ve width stmt4 = Store castV dstV - stmts = stmts1 `appOL` stmts2 `snocOL` stmt3 `snocOL` stmt4 - return (env2, stmts, top1 ++ top2) + return (stmts `snocOL` stmt3 `snocOL` stmt4, top) -genCall _ (PrimTarget (MO_UF_Conv _)) [_] args = +genCall (PrimTarget (MO_UF_Conv _)) [_] args = panic $ "genCall: Too many arguments to MO_UF_Conv. " ++ "Can only handle 1, given" ++ show (length args) ++ "." -- Handle prefetching data -genCall env t@(PrimTarget MO_Prefetch_Data) [] args = do - let dflags = getDflags env - argTy = [i8Ptr, i32, i32, i32] +genCall t@(PrimTarget MO_Prefetch_Data) [] args = do + ver <- getLlvmVer + let argTy | ver <= 29 = [i8Ptr, i32, i32] + | otherwise = [i8Ptr, i32, i32, i32] funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing let (_, arg_hints) = foreignTargetHints t let args_hints' = zip args arg_hints - (env1, argVars, stmts1, top1) <- arg_vars env args_hints' ([], nilOL, []) - (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy t - (argVars', stmts3) <- castVars dflags $ zip argVars argTy - - let arguments = argVars' ++ [mkIntLit i32 0, mkIntLit i32 3, mkIntLit i32 1] - call = Expr $ Call StdCall fptr arguments [] + (argVars, stmts1, top1) <- arg_vars args_hints' ([], nilOL, []) + (fptr, stmts2, top2) <- getFunPtr funTy t + (argVars', stmts3) <- castVars $ zip argVars argTy + + trash <- getTrashStmts + let argSuffix | ver <= 29 = [mkIntLit i32 0, mkIntLit i32 3] + | otherwise = [mkIntLit i32 0, mkIntLit i32 3, mkIntLit i32 1] + call = Expr $ Call StdCall fptr (argVars' ++ argSuffix) [] stmts = stmts1 `appOL` stmts2 `appOL` stmts3 - `appOL` trashStmts (getDflags env) `snocOL` call - return (env2, stmts, top1 ++ top2) - --- Handle popcnt function specifically since GHC only really has i32 and i64 --- types and things like Word8 are backed by an i32 and just present a logical --- i8 range. So we must handle conversions from i32 to i8 explicitly as LLVM --- is strict about types. -genCall env t@(PrimTarget (MO_PopCnt w)) [dst] args = do - let dflags = getDflags env - width = widthToLlvmInt w - dstTy = cmmToLlvmType $ localRegType dst - funTy = \n -> LMFunction $ LlvmFunctionDecl n ExternallyVisible - CC_Ccc width FixedArgs (tysToParams [width]) Nothing - (env1, dstV, stmts1, top1) = getCmmReg env (CmmLocal dst) + `appOL` trash `snocOL` call + return (stmts, top1 ++ top2) - let (_, arg_hints) = foreignTargetHints t - let args_hints = zip args arg_hints - (env2, argsV, stmts2, top2) <- arg_vars env1 args_hints ([], nilOL, []) - (env3, fptr, stmts3, top3) <- getFunPtr env2 funTy t - (argsV', stmts4) <- castVars dflags $ zip argsV [width] - (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] - ([retV'], stmts5) <- castVars dflags [(retV,dstTy)] - let s2 = Store retV' dstV - - let stmts = stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` - s1 `appOL` stmts5 `snocOL` s2 - return (env3, stmts, top1 ++ top2 ++ top3) +-- Handle PopCnt and BSwap that need to only convert arg and return types +genCall t@(PrimTarget (MO_PopCnt w)) dsts args = + genCallSimpleCast w t dsts args +genCall t@(PrimTarget (MO_BSwap w)) dsts args = + genCallSimpleCast w t dsts args -- Handle memcpy function specifically since llvm's intrinsic version takes -- some extra parameters. -genCall env t@(PrimTarget op) [] args' +genCall t@(PrimTarget op) [] args' | op == MO_Memcpy || op == MO_Memset || op == MO_Memmove = do - let dflags = getDflags env - (args, alignVal) = splitAlignVal args' - (isVolTy, isVolVal) = if getLlvmVer env >= 28 - then ([i1], [mkIntLit i1 0]) else ([], []) + ver <- getLlvmVer + dflags <- getDynFlags + let (args, alignVal) = splitAlignVal args' + (isVolTy, isVolVal) + | ver >= 28 = ([i1], [mkIntLit i1 0]) + | otherwise = ([], []) argTy | op == MO_Memset = [i8Ptr, i8, llvmWord dflags, i32] ++ isVolTy | otherwise = [i8Ptr, i8Ptr, llvmWord dflags, i32] ++ isVolTy funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible @@ -262,16 +246,16 @@ genCall env t@(PrimTarget op) [] args' let (_, arg_hints) = foreignTargetHints t let args_hints = zip args arg_hints - (env1, argVars, stmts1, top1) <- arg_vars env args_hints ([], nilOL, []) - (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy t - (argVars', stmts3) <- castVars dflags $ zip argVars argTy + (argVars, stmts1, top1) <- arg_vars args_hints ([], nilOL, []) + (fptr, stmts2, top2) <- getFunPtr funTy t + (argVars', stmts3) <- castVars $ zip argVars argTy + stmts4 <- getTrashStmts let arguments = argVars' ++ (alignVal:isVolVal) call = Expr $ Call StdCall fptr arguments [] stmts = stmts1 `appOL` stmts2 `appOL` stmts3 - `appOL` trashStmts (getDflags env) `snocOL` call - return (env2, stmts, top1 ++ top2) - + `appOL` stmts4 `snocOL` call + return (stmts, top1 ++ top2) where splitAlignVal xs = (init xs, extractLit $ last xs) @@ -284,9 +268,9 @@ genCall env t@(PrimTarget op) [] args' mkIntLit i32 0 -- Handle all other foreign calls and prim ops. -genCall env target res args = do +genCall target res args = do - let dflags = getDflags env + dflags <- getDynFlags -- parameter types let arg_type (_, AddrHint) = i8Ptr @@ -301,10 +285,11 @@ genCall env target res args = do ++ " 0 or 1, given " ++ show (length t) ++ "." -- extract Cmm call convention, and translate to LLVM call convention + platform <- getLlvmPlatform let lmconv = case target of ForeignTarget _ (ForeignConvention conv _ _ _) -> case conv of - StdCallConv -> case platformArch (getLlvmPlatform env) of + StdCallConv -> case platformArch platform of ArchX86 -> CC_X86_Stdcc ArchX86_64 -> CC_X86_Stdcc _ -> CC_Ccc @@ -341,22 +326,22 @@ genCall env target res args = do lmconv retTy FixedArgs argTy (llvmFunAlign dflags) - - (env1, argVars, stmts1, top1) <- arg_vars env args_hints ([], nilOL, []) - (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy target + (argVars, stmts1, top1) <- arg_vars args_hints ([], nilOL, []) + (fptr, stmts2, top2) <- getFunPtr funTy target let retStmt | ccTy == TailCall = unitOL $ Return Nothing | never_returns = unitOL $ Unreachable | otherwise = nilOL - let stmts = stmts1 `appOL` stmts2 `appOL` trashStmts (getDflags env) + stmts3 <- getTrashStmts + let stmts = stmts1 `appOL` stmts2 `appOL` stmts3 -- make the actual call case retTy of LMVoid -> do let s1 = Expr $ Call ccTy fptr argVars fnAttrs let allStmts = stmts `snocOL` s1 `appOL` retStmt - return (env2, allStmts, top1 ++ top2) + return (allStmts, top1 ++ top2) _ -> do (v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs @@ -365,13 +350,13 @@ genCall env target res args = do ret_reg t = panic $ "genCall: Bad number of registers! Can only handle" ++ " 1, given " ++ show (length t) ++ "." let creg = ret_reg res - let (env3, vreg, stmts3, top3) = getCmmReg env2 (CmmLocal creg) - let allStmts = stmts `snocOL` s1 `appOL` stmts3 + vreg <- getCmmReg (CmmLocal creg) + let allStmts = stmts `snocOL` s1 if retTy == pLower (getVarType vreg) then do let s2 = Store v1 vreg - return (env3, allStmts `snocOL` s2 `appOL` retStmt, - top1 ++ top2 ++ top3) + return (allStmts `snocOL` s2 `appOL` retStmt, + top1 ++ top2) else do let ty = pLower $ getVarType vreg let op = case ty of @@ -383,102 +368,110 @@ genCall env target res args = do (v2, s2) <- doExpr ty $ Cast op v1 ty let s3 = Store v2 vreg - return (env3, allStmts `snocOL` s2 `snocOL` s3 - `appOL` retStmt, top1 ++ top2 ++ top3) + return (allStmts `snocOL` s2 `snocOL` s3 + `appOL` retStmt, top1 ++ top2) + +-- Handle simple function call that only need simple type casting, of the form: +-- truncate arg >>= \a -> call(a) >>= zext +-- +-- since GHC only really has i32 and i64 types and things like Word8 are backed +-- by an i32 and just present a logical i8 range. So we must handle conversions +-- from i32 to i8 explicitly as LLVM is strict about types. +genCallSimpleCast :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual] + -> LlvmM StmtData +genCallSimpleCast w t@(PrimTarget op) [dst] args = do + let width = widthToLlvmInt w + dstTy = cmmToLlvmType $ localRegType dst + + fname <- cmmPrimOpFunctions op + (fptr, _, top3) <- getInstrinct fname width [width] + + dstV <- getCmmReg (CmmLocal dst) + + let (_, arg_hints) = foreignTargetHints t + let args_hints = zip args arg_hints + (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, []) + (argsV', stmts4) <- castVars $ zip argsV [width] + (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] + ([retV'], stmts5) <- castVars [(retV,dstTy)] + let s2 = Store retV' dstV + let stmts = stmts2 `appOL` stmts4 `snocOL` + s1 `appOL` stmts5 `snocOL` s2 + return (stmts, top2 ++ top3) +genCallSimpleCast _ _ dsts _ = + panic ("genCallSimpleCast: " ++ show (length dsts) ++ " dsts") -- | Create a function pointer from a target. -getFunPtr :: LlvmEnv -> (LMString -> LlvmType) -> ForeignTarget - -> UniqSM ExprData -getFunPtr env funTy targ = case targ of - ForeignTarget (CmmLit (CmmLabel lbl)) _ -> litCase $ strCLabel_llvm env lbl +getFunPtr :: (LMString -> LlvmType) -> ForeignTarget + -> LlvmM ExprData +getFunPtr funTy targ = case targ of + ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do + name <- strCLabel_llvm lbl + getHsFunc' name (funTy name) ForeignTarget expr _ -> do - (env', v1, stmts, top) <- exprToVar env expr + (v1, stmts, top) <- exprToVar expr + dflags <- getDynFlags let fty = funTy $ fsLit "dynamic" cast = case getVarType v1 of ty | isPointer ty -> LM_Bitcast ty | isInt ty -> LM_Inttoptr ty -> panic $ "genCall: Expr is of bad type for function" - ++ " call! (" ++ show (ty) ++ ")" + ++ " call! (" ++ showSDoc dflags (ppr ty) ++ ")" (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty) - return (env', v2, stmts `snocOL` s1, top) - - PrimTarget mop -> litCase $ cmmPrimOpFunctions env mop - - where - litCase name = do - case funLookup name env of - Just ty'@(LMFunction sig) -> do - -- Function in module in right form - let fun = LMGlobalVar name ty' (funcLinkage sig) - Nothing Nothing False - return (env, fun, nilOL, []) - - Just ty' -> do - -- label in module but not function pointer, convert - let fty@(LMFunction sig) = funTy name - fun = LMGlobalVar name (pLift ty') (funcLinkage sig) - Nothing Nothing False - (v1, s1) <- doExpr (pLift fty) - $ Cast LM_Bitcast fun (pLift fty) - return (env, v1, unitOL s1, []) - - Nothing -> do - -- label not in module, create external reference - let fty@(LMFunction sig) = funTy name - fun = LMGlobalVar name fty (funcLinkage sig) - Nothing Nothing False - top = [CmmData Data [([],[fty])]] - env' = funInsert name fty env - return (env', fun, nilOL, top) + return (v2, stmts `snocOL` s1, top) + PrimTarget mop -> do + name <- cmmPrimOpFunctions mop + let fty = funTy name + getInstrinct2 name fty -- | Conversion of call arguments. -arg_vars :: LlvmEnv - -> [(CmmActual, ForeignHint)] +arg_vars :: [(CmmActual, ForeignHint)] -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) - -> UniqSM (LlvmEnv, [LlvmVar], LlvmStatements, [LlvmCmmDecl]) + -> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) -arg_vars env [] (vars, stmts, tops) - = return (env, vars, stmts, tops) +arg_vars [] (vars, stmts, tops) + = return (vars, stmts, tops) -arg_vars env ((e, AddrHint):rest) (vars, stmts, tops) - = do (env', v1, stmts', top') <- exprToVar env e +arg_vars ((e, AddrHint):rest) (vars, stmts, tops) + = do (v1, stmts', top') <- exprToVar e + dflags <- getDynFlags let op = case getVarType v1 of ty | isPointer ty -> LM_Bitcast ty | isInt ty -> LM_Inttoptr a -> panic $ "genCall: Can't cast llvmType to i8*! (" - ++ show a ++ ")" + ++ showSDoc dflags (ppr a) ++ ")" (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr - arg_vars env' rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1, + arg_vars rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1, tops ++ top') -arg_vars env ((e, _):rest) (vars, stmts, tops) - = do (env', v1, stmts', top') <- exprToVar env e - arg_vars env' rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top') +arg_vars ((e, _):rest) (vars, stmts, tops) + = do (v1, stmts', top') <- exprToVar e + arg_vars rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top') -- | Cast a collection of LLVM variables to specific types. -castVars :: DynFlags -> [(LlvmVar, LlvmType)] - -> UniqSM ([LlvmVar], LlvmStatements) -castVars dflags vars = do - done <- mapM (uncurry (castVar dflags)) vars +castVars :: [(LlvmVar, LlvmType)] + -> LlvmM ([LlvmVar], LlvmStatements) +castVars vars = do + done <- mapM (uncurry castVar) vars let (vars', stmts) = unzip done return (vars', toOL stmts) -- | Cast an LLVM variable to a specific type, panicing if it can't be done. -castVar :: DynFlags -> LlvmVar -> LlvmType -> UniqSM (LlvmVar, LlvmStatement) -castVar dflags v t - | getVarType v == t +castVar :: LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement) +castVar v t | getVarType v == t = return (v, Nop) | otherwise - = let op = case (getVarType v, t) of + = do dflags <- getDynFlags + let op = case (getVarType v, t) of (LMInt n, LMInt m) -> if n < m then LM_Sext else LM_Trunc (vt, _) | isFloat vt && isFloat t @@ -492,14 +485,24 @@ castVar dflags v t (vt, _) | isVector vt && isVector t -> LM_Bitcast (vt, _) -> panic $ "castVars: Can't cast this type (" - ++ show vt ++ ") to (" ++ show t ++ ")" - in doExpr t $ Cast op v t + ++ showSDoc dflags (ppr vt) ++ ") to (" ++ showSDoc dflags (ppr t) ++ ")" + doExpr t $ Cast op v t -- | Decide what C function to use to implement a CallishMachOp -cmmPrimOpFunctions :: LlvmEnv -> CallishMachOp -> LMString -cmmPrimOpFunctions env mop - = case mop of +cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString +cmmPrimOpFunctions mop = do + + ver <- getLlvmVer + dflags <- getDynFlags + let intrinTy1 = (if ver >= 28 + then "p0i8.p0i8." else "") ++ showSDoc dflags (ppr $ llvmWord dflags) + intrinTy2 = (if ver >= 28 + then "p0i8." else "") ++ showSDoc dflags (ppr $ llvmWord dflags) + unsupported = panic ("cmmPrimOpFunctions: " ++ show mop + ++ " not supported here") + + return $ case mop of MO_F32_Exp -> fsLit "expf" MO_F32_Log -> fsLit "logf" MO_F32_Sqrt -> fsLit "llvm.sqrt.f32" @@ -538,7 +541,8 @@ cmmPrimOpFunctions env mop MO_Memmove -> fsLit $ "llvm.memmove." ++ intrinTy1 MO_Memset -> fsLit $ "llvm.memset." ++ intrinTy2 - (MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ show (widthToLlvmInt w) + (MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ showSDoc dflags (ppr $ widthToLlvmInt w) + (MO_BSwap w) -> fsLit $ "llvm.bswap." ++ showSDoc dflags (ppr $ widthToLlvmInt w) MO_Prefetch_Data -> fsLit "llvm.prefetch" @@ -551,44 +555,36 @@ cmmPrimOpFunctions env mop MO_Touch -> unsupported MO_UF_Conv _ -> unsupported - where - dflags = getDflags env - intrinTy1 = (if getLlvmVer env >= 28 - then "p0i8.p0i8." else "") ++ show (llvmWord dflags) - intrinTy2 = (if getLlvmVer env >= 28 - then "p0i8." else "") ++ show (llvmWord dflags) - unsupported = panic ("cmmPrimOpFunctions: " ++ show mop - ++ " not supported here") - -- | Tail function calls -genJump :: LlvmEnv -> CmmExpr -> [GlobalReg] -> UniqSM StmtData +genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData -- Call to known function -genJump env (CmmLit (CmmLabel lbl)) live = do - (env', vf, stmts, top) <- getHsFunc env live lbl - (stgRegs, stgStmts) <- funEpilogue env live +genJump (CmmLit (CmmLabel lbl)) live = do + (vf, stmts, top) <- getHsFunc live lbl + (stgRegs, stgStmts) <- funEpilogue live let s1 = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs let s2 = Return Nothing - return (env', stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top) + return (stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top) -- Call to unknown function / address -genJump env expr live = do - let fty = llvmFunTy (getDflags env) live - (env', vf, stmts, top) <- exprToVar env expr +genJump expr live = do + fty <- llvmFunTy live + (vf, stmts, top) <- exprToVar expr + dflags <- getDynFlags let cast = case getVarType vf of ty | isPointer ty -> LM_Bitcast ty | isInt ty -> LM_Inttoptr ty -> panic $ "genJump: Expr is of bad type for function call! (" - ++ show (ty) ++ ")" + ++ showSDoc dflags (ppr ty) ++ ")" (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty) - (stgRegs, stgStmts) <- funEpilogue env live + (stgRegs, stgStmts) <- funEpilogue live let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs let s3 = Return Nothing - return (env', stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3, + return (stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3, top) @@ -596,81 +592,81 @@ genJump env expr live = do -- -- We use stack allocated variables for CmmReg. The optimiser will replace -- these with registers when possible. -genAssign :: LlvmEnv -> CmmReg -> CmmExpr -> UniqSM StmtData -genAssign env reg val = do - let dflags = getDflags env - (env1, vreg, stmts1, top1) = getCmmReg env reg - (env2, vval, stmts2, top2) <- exprToVar env1 val - let stmts = stmts1 `appOL` stmts2 +genAssign :: CmmReg -> CmmExpr -> LlvmM StmtData +genAssign reg val = do + vreg <- getCmmReg reg + (vval, stmts2, top2) <- exprToVar val + let stmts = stmts2 let ty = (pLower . getVarType) vreg + dflags <- getDynFlags case ty of -- Some registers are pointer types, so need to cast value to pointer LMPointer _ | getVarType vval == llvmWord dflags -> do (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty let s2 = Store v vreg - return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) + return (stmts `snocOL` s1 `snocOL` s2, top2) LMVector _ _ -> do (v, s1) <- doExpr ty $ Cast LM_Bitcast vval ty let s2 = Store v vreg - return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) + return (stmts `snocOL` s1 `snocOL` s2, top2) _ -> do let s1 = Store vval vreg - return (env2, stmts `snocOL` s1, top1 ++ top2) + return (stmts `snocOL` s1, top2) -- | CmmStore operation -genStore :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData +genStore :: CmmExpr -> CmmExpr -> LlvmM StmtData -- First we try to detect a few common cases and produce better code for -- these then the default case. We are mostly trying to detect Cmm code -- like I32[Sp + n] and use 'getelementptr' operations instead of the -- generic case that uses casts and pointer arithmetic -genStore env addr@(CmmReg (CmmGlobal r)) val - = genStore_fast env addr r 0 val +genStore addr@(CmmReg (CmmGlobal r)) val + = genStore_fast addr r 0 val -genStore env addr@(CmmRegOff (CmmGlobal r) n) val - = genStore_fast env addr r n val +genStore addr@(CmmRegOff (CmmGlobal r) n) val + = genStore_fast addr r n val -genStore env addr@(CmmMachOp (MO_Add _) [ +genStore addr@(CmmMachOp (MO_Add _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]) val - = genStore_fast env addr r (fromInteger n) val + = genStore_fast addr r (fromInteger n) val -genStore env addr@(CmmMachOp (MO_Sub _) [ +genStore addr@(CmmMachOp (MO_Sub _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]) val - = genStore_fast env addr r (negate $ fromInteger n) val + = genStore_fast addr r (negate $ fromInteger n) val -- generic case -genStore env addr val = genStore_slow env addr val [other] +genStore addr val + = do other <- getTBAAMeta otherN + genStore_slow addr val other -- | CmmStore operation -- This is a special case for storing to a global register pointer -- offset such as I32[Sp+8]. -genStore_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmExpr - -> UniqSM StmtData -genStore_fast env addr r n val - = let dflags = getDflags env - gr = lmGlobalRegVar (getDflags env) r - meta = [getTBAA r] - grt = (pLower . getVarType) gr - (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) - in case isPointer grt && rem == 0 of +genStore_fast :: CmmExpr -> GlobalReg -> Int -> CmmExpr + -> LlvmM StmtData +genStore_fast addr r n val + = do dflags <- getDynFlags + (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) + meta <- getTBAARegMeta r + let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) + case isPointer grt && rem == 0 of True -> do - (env', vval, stmts, top) <- exprToVar env val - (gv, s1) <- doExpr grt $ Load gr + (vval, stmts, top) <- exprToVar val (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] -- We might need a different pointer type, so check case pLower grt == getVarType vval of -- were fine True -> do let s3 = MetaStmt meta $ Store vval ptr - return (env', stmts `snocOL` s1 `snocOL` s2 + return (stmts `appOL` s1 `snocOL` s2 `snocOL` s3, top) -- cast to pointer type needed @@ -678,68 +674,69 @@ genStore_fast env addr r n val let ty = (pLift . getVarType) vval (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty let s4 = MetaStmt meta $ Store vval ptr' - return (env', stmts `snocOL` s1 `snocOL` s2 + return (stmts `appOL` s1 `snocOL` s2 `snocOL` s3 `snocOL` s4, top) -- If its a bit type then we use the slow method since -- we can't avoid casting anyway. - False -> genStore_slow env addr val meta + False -> genStore_slow addr val meta -- | CmmStore operation -- Generic case. Uses casts and pointer arithmetic if needed. -genStore_slow :: LlvmEnv -> CmmExpr -> CmmExpr -> [MetaData] -> UniqSM StmtData -genStore_slow env addr val meta = do - (env1, vaddr, stmts1, top1) <- exprToVar env addr - (env2, vval, stmts2, top2) <- exprToVar env1 val +genStore_slow :: CmmExpr -> CmmExpr -> [MetaAnnot] -> LlvmM StmtData +genStore_slow addr val meta = do + (vaddr, stmts1, top1) <- exprToVar addr + (vval, stmts2, top2) <- exprToVar val let stmts = stmts1 `appOL` stmts2 + dflags <- getDynFlags case getVarType vaddr of -- sometimes we need to cast an int to a pointer before storing LMPointer ty@(LMPointer _) | getVarType vval == llvmWord dflags -> do (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty let s2 = MetaStmt meta $ Store v vaddr - return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) + return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) LMPointer _ -> do let s1 = MetaStmt meta $ Store vval vaddr - return (env2, stmts `snocOL` s1, top1 ++ top2) + return (stmts `snocOL` s1, top1 ++ top2) i@(LMInt _) | i == llvmWord dflags -> do let vty = pLift $ getVarType vval (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty let s2 = MetaStmt meta $ Store vval vptr - return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) + return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) other -> pprPanic "genStore: ptr not right type!" (PprCmm.pprExpr addr <+> text ( "Size of Ptr: " ++ show (llvmPtrBits dflags) ++ ", Size of var: " ++ show (llvmWidthInBits dflags other) ++ - ", Var: " ++ show vaddr)) - where dflags = getDflags env + ", Var: " ++ showSDoc dflags (ppr vaddr))) -- | Unconditional branch -genBranch :: LlvmEnv -> BlockId -> UniqSM StmtData -genBranch env id = +genBranch :: BlockId -> LlvmM StmtData +genBranch id = let label = blockIdToLlvm id - in return (env, unitOL $ Branch label, []) + in return (unitOL $ Branch label, []) -- | Conditional branch -genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> BlockId -> UniqSM StmtData -genCondBranch env cond idT idF = do +genCondBranch :: CmmExpr -> BlockId -> BlockId -> LlvmM StmtData +genCondBranch cond idT idF = do let labelT = blockIdToLlvm idT let labelF = blockIdToLlvm idF -- See Note [Literals and branch conditions]. - (env', vc, stmts, top) <- exprToVarOpt env i1Option cond + (vc, stmts, top) <- exprToVarOpt i1Option cond if getVarType vc == i1 then do let s1 = BranchIf vc labelT labelF - return $ (env', stmts `snocOL` s1, top) - else - panic $ "genCondBranch: Cond expr not bool! (" ++ show vc ++ ")" + return (stmts `snocOL` s1, top) + else do + dflags <- getDynFlags + panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppr vc) ++ ")" {- Note [Literals and branch conditions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -797,9 +794,9 @@ For a real example of this, see ./rts/StgStdThunks.cmm -- -- N.B. We remove Nothing's from the list of branches, as they are 'undefined'. -- However, they may be defined one day, so we better document this behaviour. -genSwitch :: LlvmEnv -> CmmExpr -> [Maybe BlockId] -> UniqSM StmtData -genSwitch env cond maybe_ids = do - (env', vc, stmts, top) <- exprToVar env cond +genSwitch :: CmmExpr -> [Maybe BlockId] -> LlvmM StmtData +genSwitch cond maybe_ids = do + (vc, stmts, top) <- exprToVar cond let ty = getVarType vc let pairs = [ (ix, id) | (ix,Just id) <- zip [0..] maybe_ids ] @@ -808,7 +805,7 @@ genSwitch env cond maybe_ids = do let (_, defLbl) = head labels let s1 = Switch vc defLbl labels - return $ (env', stmts `snocOL` s1, top) + return $ (stmts `snocOL` s1, top) -- ----------------------------------------------------------------------------- @@ -816,11 +813,10 @@ genSwitch env cond maybe_ids = do -- -- | An expression conversion return data: --- * LlvmEnv: The new enviornment -- * LlvmVar: The var holding the result of the expression -- * LlvmStatements: Any statements needed to evaluate the expression -- * LlvmCmmDecl: Any global data needed for this expression -type ExprData = (LlvmEnv, LlvmVar, LlvmStatements, [LlvmCmmDecl]) +type ExprData = (LlvmVar, LlvmStatements, [LlvmCmmDecl]) -- | Values which can be passed to 'exprToVar' to configure its -- behaviour in certain circumstances. @@ -840,47 +836,47 @@ wordOption = EOption False -- | Convert a CmmExpr to a list of LlvmStatements with the result of the -- expression being stored in the returned LlvmVar. -exprToVar :: LlvmEnv -> CmmExpr -> UniqSM ExprData -exprToVar env = exprToVarOpt env wordOption +exprToVar :: CmmExpr -> LlvmM ExprData +exprToVar = exprToVarOpt wordOption -exprToVarOpt :: LlvmEnv -> EOption -> CmmExpr -> UniqSM ExprData -exprToVarOpt env opt e = case e of +exprToVarOpt :: EOption -> CmmExpr -> LlvmM ExprData +exprToVarOpt opt e = case e of CmmLit lit - -> genLit opt env lit + -> genLit opt lit CmmLoad e' ty - -> genLoad env e' ty + -> genLoad e' ty -- Cmmreg in expression is the value, so must load. If you want actual -- reg pointer, call getCmmReg directly. CmmReg r -> do - let (env', vreg, stmts, top) = getCmmReg env r - (v1, s1) <- doExpr (pLower $ getVarType vreg) $ Load vreg - case (isPointer . getVarType) v1 of + (v1, ty, s1) <- getCmmRegVal r + case isPointer ty of True -> do -- Cmm wants the value, so pointer types must be cast to ints + dflags <- getDynFlags (v2, s2) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint v1 (llvmWord dflags) - return (env', v2, stmts `snocOL` s1 `snocOL` s2, top) + return (v2, s1 `snocOL` s2, []) - False -> return (env', v1, stmts `snocOL` s1, top) + False -> return (v1, s1, []) CmmMachOp op exprs - -> genMachOp env opt op exprs + -> genMachOp opt op exprs CmmRegOff r i - -> exprToVar env $ expandCmmReg dflags (r, i) + -> do dflags <- getDynFlags + exprToVar $ expandCmmReg dflags (r, i) CmmStackSlot _ _ -> panic "exprToVar: CmmStackSlot not supported!" - where dflags = getDflags env -- | Handle CmmMachOp expressions -genMachOp :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData +genMachOp :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData -- Unary Machop -genMachOp env _ op [x] = case op of +genMachOp _ op [x] = case op of MO_Not w -> let all1 = mkIntLit (widthToLlvmInt w) (-1) @@ -980,29 +976,28 @@ genMachOp env _ op [x] = case op of MO_VF_Quot _ _ -> panicOp where - dflags = getDflags env - negate ty v2 negOp = do - (env', vx, stmts, top) <- exprToVar env x + (vx, stmts, top) <- exprToVar x (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx - return (env', v1, stmts `snocOL` s1, top) + return (v1, stmts `snocOL` s1, top) negateVec ty v2 negOp = do - (env', vx, stmts1, top) <- exprToVar env x - ([vx'], stmts2) <- castVars dflags [(vx, ty)] + (vx, stmts1, top) <- exprToVar x + ([vx'], stmts2) <- castVars [(vx, ty)] (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx' - return (env', v1, stmts1 `appOL` stmts2 `snocOL` s1, top) + return (v1, stmts1 `appOL` stmts2 `snocOL` s1, top) fiConv ty convOp = do - (env', vx, stmts, top) <- exprToVar env x + (vx, stmts, top) <- exprToVar x (v1, s1) <- doExpr ty $ Cast convOp vx ty - return (env', v1, stmts `snocOL` s1, top) + return (v1, stmts `snocOL` s1, top) sameConv from ty reduce expand = do - x'@(env', vx, stmts, top) <- exprToVar env x + x'@(vx, stmts, top) <- exprToVar x let sameConv' op = do (v1, s1) <- doExpr ty $ Cast op vx ty - return (env', v1, stmts `snocOL` s1, top) + return (v1, stmts `snocOL` s1, top) + dflags <- getDynFlags let toWidth = llvmWidthInBits dflags ty -- LLVM doesn't like trying to convert to same width, so -- need to check for that as we do get Cmm code doing it. @@ -1015,88 +1010,82 @@ genMachOp env _ op [x] = case op of ++ "with one argument! (" ++ show op ++ ")" -- Handle GlobalRegs pointers -genMachOp env opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))] - = genMachOp_fast env opt o r (fromInteger n) e +genMachOp opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))] + = genMachOp_fast opt o r (fromInteger n) e -genMachOp env opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))] - = genMachOp_fast env opt o r (negate . fromInteger $ n) e +genMachOp opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))] + = genMachOp_fast opt o r (negate . fromInteger $ n) e -- Generic case -genMachOp env opt op e = genMachOp_slow env opt op e +genMachOp opt op e = genMachOp_slow opt op e -- | Handle CmmMachOp expressions -- This is a specialised method that handles Global register manipulations like -- 'Sp - 16', using the getelementptr instruction. -genMachOp_fast :: LlvmEnv -> EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr] - -> UniqSM ExprData -genMachOp_fast env opt op r n e - = let dflags = getDflags env - gr = lmGlobalRegVar dflags r - grt = (pLower . getVarType) gr - (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) - in case isPointer grt && rem == 0 of +genMachOp_fast :: EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr] + -> LlvmM ExprData +genMachOp_fast opt op r n e + = do (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) + dflags <- getDynFlags + let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) + case isPointer grt && rem == 0 of True -> do - (gv, s1) <- doExpr grt $ Load gr (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] (var, s3) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint ptr (llvmWord dflags) - return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, []) + return (var, s1 `snocOL` s2 `snocOL` s3, []) - False -> genMachOp_slow env opt op e + False -> genMachOp_slow opt op e -- | Handle CmmMachOp expressions -- This handles all the cases not handle by the specialised genMachOp_fast. -genMachOp_slow :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData +genMachOp_slow :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData -- Element extraction -genMachOp_slow env _ (MO_V_Extract l w) [val, idx] = do - (env1, vval, stmts1, top1) <- exprToVar env val - (env2, vidx, stmts2, top2) <- exprToVar env1 idx - ([vval'], stmts3) <- castVars dflags [(vval, LMVector l ty)] - (v1, s1) <- doExpr ty $ Extract vval' vidx - return (env2, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2) +genMachOp_slow _ (MO_V_Extract l w) [val, idx] = do + (vval, stmts1, top1) <- exprToVar val + (vidx, stmts2, top2) <- exprToVar idx + ([vval'], stmts3) <- castVars [(vval, LMVector l ty)] + (v1, s1) <- doExpr ty $ Extract vval' vidx + return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2) where - dflags = getDflags env ty = widthToLlvmInt w -genMachOp_slow env _ (MO_VF_Extract l w) [val, idx] = do - (env1, vval, stmts1, top1) <- exprToVar env val - (env2, vidx, stmts2, top2) <- exprToVar env1 idx - ([vval'], stmts3) <- castVars dflags [(vval, LMVector l ty)] - (v1, s1) <- doExpr ty $ Extract vval' vidx - return (env2, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2) +genMachOp_slow _ (MO_VF_Extract l w) [val, idx] = do + (vval, stmts1, top1) <- exprToVar val + (vidx, stmts2, top2) <- exprToVar idx + ([vval'], stmts3) <- castVars [(vval, LMVector l ty)] + (v1, s1) <- doExpr ty $ Extract vval' vidx + return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2) where - dflags = getDflags env ty = widthToLlvmFloat w -- Element insertion -genMachOp_slow env _ (MO_V_Insert l w) [val, elt, idx] = do - (env1, vval, stmts1, top1) <- exprToVar env val - (env2, velt, stmts2, top2) <- exprToVar env1 elt - (env3, vidx, stmts3, top3) <- exprToVar env2 idx - ([vval'], stmts4) <- castVars dflags [(vval, ty)] - (v1, s1) <- doExpr ty $ Insert vval' velt vidx - return (env3, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1, +genMachOp_slow _ (MO_V_Insert l w) [val, elt, idx] = do + (vval, stmts1, top1) <- exprToVar val + (velt, stmts2, top2) <- exprToVar elt + (vidx, stmts3, top3) <- exprToVar idx + ([vval'], stmts4) <- castVars [(vval, ty)] + (v1, s1) <- doExpr ty $ Insert vval' velt vidx + return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1, top1 ++ top2 ++ top3) where - dflags = getDflags env ty = LMVector l (widthToLlvmInt w) -genMachOp_slow env _ (MO_VF_Insert l w) [val, elt, idx] = do - (env1, vval, stmts1, top1) <- exprToVar env val - (env2, velt, stmts2, top2) <- exprToVar env1 elt - (env3, vidx, stmts3, top3) <- exprToVar env2 idx - ([vval'], stmts4) <- castVars dflags [(vval, ty)] - (v1, s1) <- doExpr ty $ Insert vval' velt vidx - return (env3, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1, +genMachOp_slow _ (MO_VF_Insert l w) [val, elt, idx] = do + (vval, stmts1, top1) <- exprToVar val + (velt, stmts2, top2) <- exprToVar elt + (vidx, stmts3, top3) <- exprToVar idx + ([vval'], stmts4) <- castVars [(vval, ty)] + (v1, s1) <- doExpr ty $ Insert vval' velt vidx + return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1, top1 ++ top2 ++ top3) where - dflags = getDflags env ty = LMVector l (widthToLlvmFloat w) -- Binary MachOp -genMachOp_slow env opt op [x, y] = case op of +genMachOp_slow opt op [x, y] = case op of MO_Eq _ -> genBinComp opt LM_CMP_Eq MO_Ne _ -> genBinComp opt LM_CMP_Ne @@ -1177,21 +1166,19 @@ genMachOp_slow env opt op [x, y] = case op of MO_VF_Neg {} -> panicOp where - dflags = getDflags env - binLlvmOp ty binOp = do - (env1, vx, stmts1, top1) <- exprToVar env x - (env2, vy, stmts2, top2) <- exprToVar env1 y + (vx, stmts1, top1) <- exprToVar x + (vy, stmts2, top2) <- exprToVar y if getVarType vx == getVarType vy then do (v1, s1) <- doExpr (ty vx) $ binOp vx vy - return (env2, v1, stmts1 `appOL` stmts2 `snocOL` s1, + return (v1, stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2) else do -- Error. Continue anyway so we can debug the generated ll file. - let dflags = getDflags env - style = mkCodeStyle CStyle + dflags <- getDynFlags + let style = mkCodeStyle CStyle toString doc = renderWithStyle dflags doc style cmmToStr = (lines . toString . PprCmm.pprExpr) let dx = Comment $ map fsLit $ cmmToStr x @@ -1199,31 +1186,32 @@ genMachOp_slow env opt op [x, y] = case op of (v1, s1) <- doExpr (ty vx) $ binOp vx vy let allStmts = stmts1 `appOL` stmts2 `snocOL` dx `snocOL` dy `snocOL` s1 - return (env2, v1, allStmts, top1 ++ top2) + return (v1, allStmts, top1 ++ top2) binCastLlvmOp ty binOp = do - (env1, vx, stmts1, top1) <- exprToVar env x - (env2, vy, stmts2, top2) <- exprToVar env1 y - ([vx', vy'], stmts3) <- castVars dflags [(vx, ty), (vy, ty)] + (vx, stmts1, top1) <- exprToVar x + (vy, stmts2, top2) <- exprToVar y + ([vx', vy'], stmts3) <- castVars [(vx, ty), (vy, ty)] (v1, s1) <- doExpr ty $ binOp vx' vy' - return (env2, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, + return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2) -- | Need to use EOption here as Cmm expects word size results from -- comparisons while LLVM return i1. Need to extend to llvmWord type -- if expected. See Note [Literals and branch conditions]. genBinComp opt cmp = do - ed@(env', v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp) + ed@(v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp) + dflags <- getDynFlags if getVarType v1 == i1 then case i1Expected opt of True -> return ed False -> do let w_ = llvmWord dflags (v2, s1) <- doExpr w_ $ Cast LM_Zext v1 w_ - return (env', v2, stmts `snocOL` s1, top) + return (v2, stmts `snocOL` s1, top) else panic $ "genBinComp: Compare returned type other then i1! " - ++ (show $ getVarType v1) + ++ (showSDoc dflags $ ppr $ getVarType v1) genBinMach op = binLlvmOp getVarType (LlvmOp op) @@ -1233,11 +1221,12 @@ genMachOp_slow env opt op [x, y] = case op of -- CmmExpr's. This is the LLVM assembly equivalent of the NCG -- implementation. Its much longer due to type information/safety. -- This should actually compile to only about 3 asm instructions. - isSMulOK :: Width -> CmmExpr -> CmmExpr -> UniqSM ExprData + isSMulOK :: Width -> CmmExpr -> CmmExpr -> LlvmM ExprData isSMulOK _ x y = do - (env1, vx, stmts1, top1) <- exprToVar env x - (env2, vy, stmts2, top2) <- exprToVar env1 y + (vx, stmts1, top1) <- exprToVar x + (vy, stmts2, top2) <- exprToVar y + dflags <- getDynFlags let word = getVarType vx let word2 = LMInt $ 2 * (llvmWidthInBits dflags $ getVarType vx) let shift = llvmWidthInBits dflags word @@ -1256,127 +1245,151 @@ genMachOp_slow env opt op [x, y] = case op of (dst, s8) <- doExpr word $ LlvmOp LM_MO_Sub rlow2 rhigh2 let stmts = (unitOL s1) `snocOL` s2 `snocOL` s3 `snocOL` s4 `snocOL` s5 `snocOL` s6 `snocOL` s7 `snocOL` s8 - return (env2, dst, stmts1 `appOL` stmts2 `appOL` stmts, + return (dst, stmts1 `appOL` stmts2 `appOL` stmts, top1 ++ top2) else - panic $ "isSMulOK: Not bit type! (" ++ show word ++ ")" + panic $ "isSMulOK: Not bit type! (" ++ showSDoc dflags (ppr word) ++ ")" panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encourntered" ++ "with two arguments! (" ++ show op ++ ")" -- More then two expression, invalid! -genMachOp_slow _ _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!" +genMachOp_slow _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!" -- | Handle CmmLoad expression. -genLoad :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData +genLoad :: CmmExpr -> CmmType -> LlvmM ExprData -- First we try to detect a few common cases and produce better code for -- these then the default case. We are mostly trying to detect Cmm code -- like I32[Sp + n] and use 'getelementptr' operations instead of the -- generic case that uses casts and pointer arithmetic -genLoad env e@(CmmReg (CmmGlobal r)) ty - = genLoad_fast env e r 0 ty +genLoad e@(CmmReg (CmmGlobal r)) ty + = genLoad_fast e r 0 ty -genLoad env e@(CmmRegOff (CmmGlobal r) n) ty - = genLoad_fast env e r n ty +genLoad e@(CmmRegOff (CmmGlobal r) n) ty + = genLoad_fast e r n ty -genLoad env e@(CmmMachOp (MO_Add _) [ +genLoad e@(CmmMachOp (MO_Add _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]) ty - = genLoad_fast env e r (fromInteger n) ty + = genLoad_fast e r (fromInteger n) ty -genLoad env e@(CmmMachOp (MO_Sub _) [ +genLoad e@(CmmMachOp (MO_Sub _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]) ty - = genLoad_fast env e r (negate $ fromInteger n) ty + = genLoad_fast e r (negate $ fromInteger n) ty -- generic case -genLoad env e ty = genLoad_slow env e ty [other] +genLoad e ty + = do other <- getTBAAMeta otherN + genLoad_slow e ty other -- | Handle CmmLoad expression. -- This is a special case for loading from a global register pointer -- offset such as I32[Sp+8]. -genLoad_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmType - -> UniqSM ExprData -genLoad_fast env e r n ty = - let dflags = getDflags env - gr = lmGlobalRegVar dflags r - meta = [getTBAA r] - grt = (pLower . getVarType) gr - ty' = cmmToLlvmType ty +genLoad_fast :: CmmExpr -> GlobalReg -> Int -> CmmType + -> LlvmM ExprData +genLoad_fast e r n ty = do + dflags <- getDynFlags + (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) + meta <- getTBAARegMeta r + let ty' = cmmToLlvmType ty (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) - in case isPointer grt && rem == 0 of + case isPointer grt && rem == 0 of True -> do - (gv, s1) <- doExpr grt $ Load gr (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] -- We might need a different pointer type, so check case grt == ty' of -- were fine True -> do - (var, s3) <- doExpr ty' (MetaExpr meta $ Load ptr) - return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, + (var, s3) <- doExpr ty' (MExpr meta $ Load ptr) + return (var, s1 `snocOL` s2 `snocOL` s3, []) -- cast to pointer type needed False -> do let pty = pLift ty' (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty - (var, s4) <- doExpr ty' (MetaExpr meta $ Load ptr') - return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3 + (var, s4) <- doExpr ty' (MExpr meta $ Load ptr') + return (var, s1 `snocOL` s2 `snocOL` s3 `snocOL` s4, []) -- If its a bit type then we use the slow method since -- we can't avoid casting anyway. - False -> genLoad_slow env e ty meta + False -> genLoad_slow e ty meta -- | Handle Cmm load expression. -- Generic case. Uses casts and pointer arithmetic if needed. -genLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> [MetaData] -> UniqSM ExprData -genLoad_slow env e ty meta = do - (env', iptr, stmts, tops) <- exprToVar env e +genLoad_slow :: CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData +genLoad_slow e ty meta = do + (iptr, stmts, tops) <- exprToVar e + dflags <- getDynFlags case getVarType iptr of LMPointer _ -> do (dvar, load) <- doExpr (cmmToLlvmType ty) - (MetaExpr meta $ Load iptr) - return (env', dvar, stmts `snocOL` load, tops) + (MExpr meta $ Load iptr) + return (dvar, stmts `snocOL` load, tops) i@(LMInt _) | i == llvmWord dflags -> do let pty = LMPointer $ cmmToLlvmType ty (ptr, cast) <- doExpr pty $ Cast LM_Inttoptr iptr pty (dvar, load) <- doExpr (cmmToLlvmType ty) - (MetaExpr meta $ Load ptr) - return (env', dvar, stmts `snocOL` cast `snocOL` load, tops) + (MExpr meta $ Load ptr) + return (dvar, stmts `snocOL` cast `snocOL` load, tops) - other -> pprPanic "exprToVar: CmmLoad expression is not right type!" + other -> do dflags <- getDynFlags + pprPanic "exprToVar: CmmLoad expression is not right type!" (PprCmm.pprExpr e <+> text ( "Size of Ptr: " ++ show (llvmPtrBits dflags) ++ ", Size of var: " ++ show (llvmWidthInBits dflags other) ++ - ", Var: " ++ show iptr)) - where dflags = getDflags env - --- | Handle CmmReg expression --- --- We allocate CmmReg on the stack. This avoids having to map a CmmReg to an --- equivalent SSA form and avoids having to deal with Phi node insertion. --- This is also the approach recommended by LLVM developers. -getCmmReg :: LlvmEnv -> CmmReg -> ExprData -getCmmReg env r@(CmmLocal (LocalReg un _)) - = let exists = varLookup un env - (newv, stmts) = allocReg r - nenv = varInsert un (pLower $ getVarType newv) env - in case exists of - Just ety -> (env, (LMLocalVar un $ pLift ety), nilOL, []) - Nothing -> (nenv, newv, stmts, []) - -getCmmReg env (CmmGlobal g) = (env, lmGlobalRegVar (getDflags env) g, nilOL, []) - - --- | Allocate a CmmReg on the stack + ", Var: " ++ showSDoc dflags (ppr iptr))) + + +-- | Handle CmmReg expression. This will return a pointer to the stack +-- location of the register. Throws an error if it isn't allocated on +-- the stack. +getCmmReg :: CmmReg -> LlvmM LlvmVar +getCmmReg (CmmLocal (LocalReg un _)) + = do exists <- varLookup un + dflags <- getDynFlags + case exists of + Just ety -> return (LMLocalVar un $ pLift ety) + Nothing -> fail $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr un) ++ " was not allocated!" + -- This should never happen, as every local variable should + -- have been assigned a value at some point, triggering + -- "funPrologue" to allocate it on the stack. + +getCmmReg (CmmGlobal g) + = do onStack <- checkStackReg g + dflags <- getDynFlags + if onStack + then return (lmGlobalRegVar dflags g) + else fail $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr g) ++ " not stack-allocated!" + +-- | Return the value of a given register, as well as its type. Might +-- need to be load from stack. +getCmmRegVal :: CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements) +getCmmRegVal reg = + case reg of + CmmGlobal g -> do + onStack <- checkStackReg g + dflags <- getDynFlags + if onStack then loadFromStack else do + let r = lmGlobalRegArg dflags g + return (r, getVarType r, nilOL) + _ -> loadFromStack + where loadFromStack = do + ptr <- getCmmReg reg + let ty = pLower $ getVarType ptr + (v, s) <- doExpr ty (Load ptr) + return (v, ty, unitOL s) + +-- | Allocate a local CmmReg on the stack allocReg :: CmmReg -> (LlvmVar, LlvmStatements) allocReg (CmmLocal (LocalReg un ty)) = let ty' = cmmToLlvmType ty @@ -1389,8 +1402,8 @@ allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should" -- | Generate code for a literal -genLit :: EOption -> LlvmEnv -> CmmLit -> UniqSM ExprData -genLit opt env (CmmInt i w) +genLit :: EOption -> CmmLit -> LlvmM ExprData +genLit opt (CmmInt i w) -- See Note [Literals and branch conditions]. = let width | i1Expected opt = i1 | otherwise = LMInt (widthInBits w) @@ -1398,56 +1411,41 @@ genLit opt env (CmmInt i w) -- , fsLit $ "Width : " ++ show w -- , fsLit $ "Width' : " ++ show (widthInBits w) -- ] - in return (env, mkIntLit width i, nilOL, []) + in return (mkIntLit width i, nilOL, []) -genLit _ env (CmmFloat r w) - = return (env, LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w), +genLit _ (CmmFloat r w) + = return (LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w), nilOL, []) - -genLit opt env (CmmVec ls) + +genLit opt (CmmVec ls) = do llvmLits <- mapM toLlvmLit ls - return (env, LMLitVar $ LMVectorLit llvmLits, nilOL, []) + return (LMLitVar $ LMVectorLit llvmLits, nilOL, []) where - toLlvmLit :: CmmLit -> UniqSM LlvmLit + toLlvmLit :: CmmLit -> LlvmM LlvmLit toLlvmLit lit = do - (_, llvmLitVar, _, _) <- genLit opt env lit + (llvmLitVar, _, _) <- genLit opt lit case llvmLitVar of LMLitVar llvmLit -> return llvmLit _ -> panic "genLit" -genLit _ env cmm@(CmmLabel l) - = let dflags = getDflags env - label = strCLabel_llvm env l - ty = funLookup label env - lmty = cmmToLlvmType $ cmmLitType dflags cmm - in case ty of - -- Make generic external label definition and then pointer to it - Nothing -> do - let glob@(var, _) = genStringLabelRef dflags label - let ldata = [CmmData Data [([glob], [])]] - let env' = funInsert label (pLower $ getVarType var) env - (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags) - return (env', v1, unitOL s1, ldata) - - -- Referenced data exists in this module, retrieve type and make - -- pointer to it. - Just ty' -> do - let var = LMGlobalVar label (LMPointer ty') - ExternallyVisible Nothing Nothing False - (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags) - return (env, v1, unitOL s1, []) - -genLit opt env (CmmLabelOff label off) = do - let dflags = getDflags env - (env', vlbl, stmts, stat) <- genLit opt env (CmmLabel label) +genLit _ cmm@(CmmLabel l) + = do var <- getGlobalPtr =<< strCLabel_llvm l + dflags <- getDynFlags + let lmty = cmmToLlvmType $ cmmLitType dflags cmm + (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags) + return (v1, unitOL s1, []) + +genLit opt (CmmLabelOff label off) = do + dflags <- getDynFlags + (vlbl, stmts, stat) <- genLit opt (CmmLabel label) let voff = toIWord dflags off (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff - return (env', v1, stmts `snocOL` s1, stat) + return (v1, stmts `snocOL` s1, stat) -genLit opt env (CmmLabelDiffOff l1 l2 off) = do - let dflags = getDflags env - (env1, vl1, stmts1, stat1) <- genLit opt env (CmmLabel l1) - (env2, vl2, stmts2, stat2) <- genLit opt env1 (CmmLabel l2) +genLit opt (CmmLabelDiffOff l1 l2 off) = do + dflags <- getDynFlags + (vl1, stmts1, stat1) <- genLit opt (CmmLabel l1) + (vl2, stmts2, stat2) <- genLit opt (CmmLabel l2) let voff = toIWord dflags off let ty1 = getVarType vl1 let ty2 = getVarType vl2 @@ -1457,16 +1455,16 @@ genLit opt env (CmmLabelDiffOff l1 l2 off) = do then do (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2 (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff - return (env2, v2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2, + return (v2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2, stat1 ++ stat2) else panic "genLit: CmmLabelDiffOff encountered with different label ty!" -genLit opt env (CmmBlock b) - = genLit opt env (CmmLabel $ infoTblLbl b) +genLit opt (CmmBlock b) + = genLit opt (CmmLabel $ infoTblLbl b) -genLit _ _ CmmHighStackMark +genLit _ CmmHighStackMark = panic "genStaticLit - CmmHighStackMark unsupported!" @@ -1474,51 +1472,82 @@ genLit _ _ CmmHighStackMark -- * Misc -- --- | Function prologue. Load STG arguments into variables for function. -funPrologue :: DynFlags -> LiveGlobalRegs -> [LlvmStatement] -funPrologue dflags live = concat $ map getReg $ activeStgRegs platform - where platform = targetPlatform dflags - isLive r = r `elem` alwaysLive || r `elem` live - getReg rr = - let reg = lmGlobalRegVar dflags rr - arg = lmGlobalRegArg dflags rr - ty = (pLower . getVarType) reg - trash = LMLitVar $ LMUndefLit ty - alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1 - in - if isLive rr - then [alloc, Store arg reg] - else [alloc, Store trash reg] - +-- | Find CmmRegs that get assigned and allocate them on the stack +-- +-- Any register that gets written needs to be allcoated on the +-- stack. This avoids having to map a CmmReg to an equivalent SSA form +-- and avoids having to deal with Phi node insertion. This is also +-- the approach recommended by LLVM developers. +-- +-- On the other hand, this is unecessarily verbose if the register in +-- question is never written. Therefore we skip it where we can to +-- save a few lines in the output and hopefully speed compilation up a +-- bit. +funPrologue :: LiveGlobalRegs -> [CmmBlock] -> LlvmM StmtData +funPrologue live cmmBlocks = do + + trash <- getTrashRegs + let getAssignedRegs :: CmmNode O O -> [CmmReg] + getAssignedRegs (CmmAssign reg _) = [reg] + -- Calls will trash all registers. Unfortunately, this needs them to + -- be stack-allocated in the first place. + getAssignedRegs (CmmUnsafeForeignCall _ rs _) = map CmmGlobal trash ++ map CmmLocal rs + getAssignedRegs _ = [] + getRegsBlock (_, body, _) = concatMap getAssignedRegs $ blockToList body + assignedRegs = nub $ concatMap (getRegsBlock . blockSplit) cmmBlocks + isLive r = r `elem` alwaysLive || r `elem` live + + dflags <- getDynFlags + stmtss <- flip mapM assignedRegs $ \reg -> + case reg of + CmmLocal (LocalReg un _) -> do + let (newv, stmts) = allocReg reg + varInsert un (pLower $ getVarType newv) + return stmts + CmmGlobal r -> do + let reg = lmGlobalRegVar dflags r + arg = lmGlobalRegArg dflags r + ty = (pLower . getVarType) reg + trash = LMLitVar $ LMUndefLit ty + rval = if isLive r then arg else trash + alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1 + markStackReg r + return $ toOL [alloc, Store rval reg] + + return (concatOL stmtss, []) -- | Function epilogue. Load STG variables to use as argument for call. -- STG Liveness optimisation done here. -funEpilogue :: LlvmEnv -> LiveGlobalRegs -> UniqSM ([LlvmVar], LlvmStatements) +funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements) +funEpilogue live = do + + -- Have information and liveness optimisation is enabled? + let liveRegs = alwaysLive ++ live + isSSE (FloatReg _) = True + isSSE (DoubleReg _) = True + isSSE (XmmReg _) = True + isSSE _ = False + + -- Set to value or "undef" depending on whether the register is + -- actually live + dflags <- getDynFlags + let loadExpr r = do + (v, _, s) <- getCmmRegVal (CmmGlobal r) + return (Just $ v, s) + loadUndef r = do + let ty = (pLower . getVarType $ lmGlobalRegVar dflags r) + return (Just $ LMLitVar $ LMUndefLit ty, nilOL) + platform <- getDynFlag targetPlatform + loads <- flip mapM (activeStgRegs platform) $ \r -> case () of + _ | r `elem` liveRegs -> loadExpr r + | not (isSSE r) -> loadUndef r + | otherwise -> return (Nothing, nilOL) --- Have information and liveness optimisation is enabled -funEpilogue env live = do - loads <- mapM loadExpr (filter isPassed (activeStgRegs platform)) let (vars, stmts) = unzip loads - return (vars, concatOL stmts) - where - dflags = getDflags env - platform = targetPlatform dflags - isLive r = r `elem` alwaysLive || r `elem` live - isPassed r = not (isSSE r) || isLive r - isSSE (FloatReg _) = True - isSSE (DoubleReg _) = True - isSSE (XmmReg _) = True - isSSE _ = False - loadExpr r | isLive r = do - let reg = lmGlobalRegVar dflags r - (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg - return (v, unitOL s) - loadExpr r = do - let ty = (pLower . getVarType $ lmGlobalRegVar dflags r) - return (LMLitVar $ LMUndefLit ty, unitOL Nop) - - --- | A serries of statements to trash all the STG registers. + return (catMaybes vars, concatOL stmts) + + +-- | A series of statements to trash all the STG registers. -- -- In LLVM we pass the STG registers around everywhere in function calls. -- So this means LLVM considers them live across the entire function, when @@ -1529,59 +1558,47 @@ funEpilogue env live = do -- before the call by assigning the 'undef' value to them. The ones we -- need are restored from the Cmm local var and the ones we don't need -- are fine to be trashed. -trashStmts :: DynFlags -> LlvmStatements -trashStmts dflags = concatOL $ map trashReg $ activeStgRegs platform - where platform = targetPlatform dflags - trashReg r = - let reg = lmGlobalRegVar dflags r - ty = (pLower . getVarType) reg - trash = unitOL $ Store (LMLitVar $ LMUndefLit ty) reg - in case callerSaves (targetPlatform dflags) r of - True -> trash - False -> nilOL - +getTrashStmts :: LlvmM LlvmStatements +getTrashStmts = do + regs <- getTrashRegs + stmts <- flip mapM regs $ \ r -> do + reg <- getCmmReg (CmmGlobal r) + let ty = (pLower . getVarType) reg + return $ Store (LMLitVar $ LMUndefLit ty) reg + return $ toOL stmts + +getTrashRegs :: LlvmM [GlobalReg] +getTrashRegs = do plat <- getLlvmPlatform + return $ filter (callerSaves plat) (activeStgRegs plat) -- | Get a function pointer to the CLabel specified. -- -- This is for Haskell functions, function type is assumed, so doesn't work -- with foreign functions. -getHsFunc :: LlvmEnv -> LiveGlobalRegs -> CLabel -> UniqSM ExprData -getHsFunc env live lbl - = let dflags = getDflags env - fn = strCLabel_llvm env lbl - ty = funLookup fn env - in case ty of - -- Function in module in right form - Just ty'@(LMFunction sig) -> do - let fun = LMGlobalVar fn ty' (funcLinkage sig) Nothing Nothing False - return (env, fun, nilOL, []) - - -- label in module but not function pointer, convert - Just ty' -> do - let fun = LMGlobalVar fn (pLift ty') ExternallyVisible - Nothing Nothing False - (v1, s1) <- doExpr (pLift (llvmFunTy dflags live)) $ - Cast LM_Bitcast fun (pLift (llvmFunTy dflags live)) - return (env, v1, unitOL s1, []) - - -- label not in module, create external reference - Nothing -> do - let ty' = LMFunction $ llvmFunSig env live lbl ExternallyVisible - let fun = LMGlobalVar fn ty' ExternallyVisible Nothing Nothing False - let top = CmmData Data [([],[ty'])] - let env' = funInsert fn ty' env - return (env', fun, nilOL, [top]) - +getHsFunc :: LiveGlobalRegs -> CLabel -> LlvmM ExprData +getHsFunc live lbl + = do fty <- llvmFunTy live + name <- strCLabel_llvm lbl + getHsFunc' name fty + +getHsFunc' :: LMString -> LlvmType -> LlvmM ExprData +getHsFunc' name fty + = do fun <- getGlobalPtr name + if getVarType fun == fty + then return (fun, nilOL, []) + else do (v1, s1) <- doExpr (pLift fty) + $ Cast LM_Bitcast fun (pLift fty) + return (v1, unitOL s1, []) -- | Create a new local var -mkLocalVar :: LlvmType -> UniqSM LlvmVar +mkLocalVar :: LlvmType -> LlvmM LlvmVar mkLocalVar ty = do - un <- getUniqueUs + un <- runUs getUniqueUs return $ LMLocalVar un ty -- | Execute an expression, assigning result to a var -doExpr :: LlvmType -> LlvmExpression -> UniqSM (LlvmVar, LlvmStatement) +doExpr :: LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement) doExpr ty expr = do v <- mkLocalVar ty return (v, Assignment v expr) @@ -1618,3 +1635,13 @@ panic s = Outputable.panic $ "LlvmCodeGen.CodeGen." ++ s pprPanic :: String -> SDoc -> a pprPanic s d = Outputable.pprPanic ("LlvmCodeGen.CodeGen." ++ s) d + +-- | Returns TBAA meta data by unique +getTBAAMeta :: Unique -> LlvmM [MetaAnnot] +getTBAAMeta u = do + mi <- getUniqMeta u + return [MetaAnnot tbaa (MetaNode i) | let Just i = mi] + +-- | Returns TBAA meta data for given register +getTBAARegMeta :: GlobalReg -> LlvmM [MetaAnnot] +getTBAARegMeta = getTBAAMeta . getTBAA diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs index 83b5453aa9..6212cfc9fb 100644 --- a/compiler/llvmGen/LlvmCodeGen/Data.hs +++ b/compiler/llvmGen/LlvmCodeGen/Data.hs @@ -3,7 +3,7 @@ -- module LlvmCodeGen.Data ( - genLlvmData, resolveLlvmDatas, resolveLlvmData + genLlvmData ) where #include "HsVersions.h" @@ -18,8 +18,6 @@ import Cmm import FastString import qualified Outputable -import Data.List (foldl') - -- ---------------------------------------------------------------------------- -- * Constants -- @@ -32,43 +30,23 @@ structStr = fsLit "_struct" -- * Top level -- --- | Pass a CmmStatic section to an equivalent Llvm code. Can't --- complete this completely though as we need to pass all CmmStatic --- sections before all references can be resolved. This last step is --- done by 'resolveLlvmData'. -genLlvmData :: LlvmEnv -> (Section, CmmStatics) -> LlvmUnresData -genLlvmData env (sec, Statics lbl xs) = - let dflags = getDflags env - static = map genData xs - label = strCLabel_llvm env lbl - - types = map getStatTypes static - getStatTypes (Left x) = cmmToLlvmType $ cmmLitType dflags x - getStatTypes (Right x) = getStatType x +-- | Pass a CmmStatic section to an equivalent Llvm code. +genLlvmData :: (Section, CmmStatics) -> LlvmM LlvmData +genLlvmData (sec, Statics lbl xs) = do + label <- strCLabel_llvm lbl + static <- mapM genData xs + let types = map getStatType static strucTy = LMStruct types alias = LMAlias ((label `appendFS` structStr), strucTy) - in (lbl, sec, alias, static) - -resolveLlvmDatas :: LlvmEnv -> [LlvmUnresData] -> (LlvmEnv, [LlvmData]) -resolveLlvmDatas env ldata - = foldl' res (env, []) ldata - where res (e, xs) ll = - let (e', nd) = resolveLlvmData e ll - in (e', nd:xs) - --- | Fix up CLabel references now that we should have passed all CmmData. -resolveLlvmData :: LlvmEnv -> LlvmUnresData -> (LlvmEnv, LlvmData) -resolveLlvmData env (lbl, sec, alias, unres) = - let (env', static, refs) = resDatas env unres ([], []) struct = Just $ LMStaticStruc static alias - label = strCLabel_llvm env lbl link = if (externallyVisibleCLabel lbl) then ExternallyVisible else Internal - const = isSecConstant sec + const = if isSecConstant sec then Constant else Global glob = LMGlobalVar label alias link Nothing Nothing const - in (env', ((glob,struct):refs, [alias])) + + return ([LMGlobal glob struct], [alias]) -- | Should a data in this section be considered constant isSecConstant :: Section -> Bool @@ -82,80 +60,19 @@ isSecConstant (OtherSection _) = False -- ---------------------------------------------------------------------------- --- ** Resolve Data/CLabel references --- - --- | Resolve data list -resDatas :: LlvmEnv -> [UnresStatic] -> ([LlvmStatic], [LMGlobal]) - -> (LlvmEnv, [LlvmStatic], [LMGlobal]) - -resDatas env [] (stats, glob) - = (env, stats, glob) - -resDatas env (cmm:rest) (stats, globs) - = let (env', nstat, nglob) = resData env cmm - in resDatas env' rest (stats ++ [nstat], globs ++ nglob) - --- | Resolve an individual static label if it needs to be. --- --- We check the 'LlvmEnv' to see if the reference has been defined in this --- module. If it has we can retrieve its type and make a pointer, otherwise --- we introduce a generic external definition for the referenced label and --- then make a pointer. -resData :: LlvmEnv -> UnresStatic -> (LlvmEnv, LlvmStatic, [LMGlobal]) - -resData env (Right stat) = (env, stat, []) - -resData env (Left cmm@(CmmLabel l)) = - let dflags = getDflags env - label = strCLabel_llvm env l - ty = funLookup label env - lmty = cmmToLlvmType $ cmmLitType dflags cmm - in case ty of - -- Make generic external label defenition and then pointer to it - Nothing -> - let glob@(var, _) = genStringLabelRef dflags label - env' = funInsert label (pLower $ getVarType var) env - ptr = LMStaticPointer var - in (env', LMPtoI ptr lmty, [glob]) - -- Referenced data exists in this module, retrieve type and make - -- pointer to it. - Just ty' -> - let var = LMGlobalVar label (LMPointer ty') - ExternallyVisible Nothing Nothing False - ptr = LMStaticPointer var - in (env, LMPtoI ptr lmty, []) - -resData env (Left (CmmLabelOff label off)) = - let dflags = getDflags env - (env', var, glob) = resData env (Left (CmmLabel label)) - offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags) - in (env', LMAdd var offset, glob) - -resData env (Left (CmmLabelDiffOff l1 l2 off)) = - let dflags = getDflags env - (env1, var1, glob1) = resData env (Left (CmmLabel l1)) - (env2, var2, glob2) = resData env1 (Left (CmmLabel l2)) - var = LMSub var1 var2 - offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags) - in (env2, LMAdd var offset, glob1 ++ glob2) - -resData _ _ = panic "resData: Non CLabel expr as left type!" - --- ---------------------------------------------------------------------------- -- * Generate static data -- -- | Handle static data -genData :: CmmStatic -> UnresStatic +genData :: CmmStatic -> LlvmM LlvmStatic -genData (CmmString str) = +genData (CmmString str) = do let v = map (\x -> LMStaticLit $ LMIntLit (fromIntegral x) i8) str ve = v ++ [LMStaticLit $ LMIntLit 0 i8] - in Right $ LMStaticArray ve (LMArray (length ve) i8) + return $ LMStaticArray ve (LMArray (length ve) i8) genData (CmmUninitialised bytes) - = Right $ LMUninitType (LMArray bytes i8) + = return $ LMUninitType (LMArray bytes i8) genData (CmmStaticLit lit) = genStaticLit lit @@ -164,27 +81,47 @@ genData (CmmStaticLit lit) -- -- Will either generate the code or leave it unresolved if it is a 'CLabel' -- which isn't yet known. -genStaticLit :: CmmLit -> UnresStatic +genStaticLit :: CmmLit -> LlvmM LlvmStatic genStaticLit (CmmInt i w) - = Right $ LMStaticLit (LMIntLit i (LMInt $ widthInBits w)) + = return $ LMStaticLit (LMIntLit i (LMInt $ widthInBits w)) genStaticLit (CmmFloat r w) - = Right $ LMStaticLit (LMFloatLit (fromRational r) (widthToLlvmFloat w)) + = return $ LMStaticLit (LMFloatLit (fromRational r) (widthToLlvmFloat w)) genStaticLit (CmmVec ls) - = Right $ LMStaticLit (LMVectorLit (map toLlvmLit ls)) + = do sls <- mapM toLlvmLit ls + return $ LMStaticLit (LMVectorLit sls) where - toLlvmLit :: CmmLit -> LlvmLit - toLlvmLit lit = case genStaticLit lit of - Right (LMStaticLit llvmLit) -> llvmLit - _ -> panic "genStaticLit" + toLlvmLit :: CmmLit -> LlvmM LlvmLit + toLlvmLit lit = do + slit <- genStaticLit lit + case slit of + LMStaticLit llvmLit -> return llvmLit + _ -> panic "genStaticLit" -- Leave unresolved, will fix later -genStaticLit c@(CmmLabel _ ) = Left $ c -genStaticLit c@(CmmLabelOff _ _) = Left $ c -genStaticLit c@(CmmLabelDiffOff _ _ _) = Left $ c +genStaticLit cmm@(CmmLabel l) = do + var <- getGlobalPtr =<< strCLabel_llvm l + dflags <- getDynFlags + let ptr = LMStaticPointer var + lmty = cmmToLlvmType $ cmmLitType dflags cmm + return $ LMPtoI ptr lmty + +genStaticLit (CmmLabelOff label off) = do + dflags <- getDynFlags + var <- genStaticLit (CmmLabel label) + let offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags) + return $ LMAdd var offset + +genStaticLit (CmmLabelDiffOff l1 l2 off) = do + dflags <- getDynFlags + var1 <- genStaticLit (CmmLabel l1) + var2 <- genStaticLit (CmmLabel l2) + let var = LMSub var1 var2 + offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags) + return $ LMAdd var offset -genStaticLit (CmmBlock b) = Left $ CmmLabel $ infoTblLbl b +genStaticLit (CmmBlock b) = genStaticLit $ CmmLabel $ infoTblLbl b genStaticLit (CmmHighStackMark) = panic "genStaticLit: CmmHighStackMark unsupported!" diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs index c699631e9c..1c63d3f67f 100644 --- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -11,7 +11,6 @@ module LlvmCodeGen.Ppr ( import Llvm import LlvmCodeGen.Base import LlvmCodeGen.Data -import LlvmCodeGen.Regs import CLabel import Cmm @@ -28,12 +27,7 @@ import Unique -- | Header code for LLVM modules pprLlvmHeader :: SDoc -pprLlvmHeader = sdocWithDynFlags $ \dflags -> - moduleLayout - $+$ text "" - $+$ ppLlvmFunctionDecls (map snd (ghcInternalFunctions dflags)) - $+$ ppLlvmMetas stgTBAA - $+$ text "" +pprLlvmHeader = moduleLayout -- | LLVM module layout description for the host target @@ -61,6 +55,9 @@ moduleLayout = sdocWithPlatform $ \platform -> Platform { platformArch = ArchARM {}, platformOS = OSAndroid } -> text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\"" $+$ text "target triple = \"arm-unknown-linux-androideabi\"" + Platform { platformArch = ArchARM {}, platformOS = OSQNXNTO } -> + text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\"" + $+$ text "target triple = \"arm-unknown-nto-qnx8.0.0eabi\"" Platform { platformArch = ArchARM {}, platformOS = OSiOS } -> text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\"" $+$ text "target triple = \"arm-apple-darwin10\"" @@ -72,63 +69,61 @@ moduleLayout = sdocWithPlatform $ \platform -> -- | Pretty print LLVM data code pprLlvmData :: LlvmData -> SDoc pprLlvmData (globals, types) = - let tryConst (v, Just s ) = ppLlvmGlobal (v, Just s) - tryConst g@(_, Nothing) = ppLlvmGlobal g - - ppLlvmTys (LMAlias a) = ppLlvmAlias a + let ppLlvmTys (LMAlias a) = ppLlvmAlias a ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f ppLlvmTys _other = empty types' = vcat $ map ppLlvmTys types - globals' = vcat $ map tryConst globals + globals' = ppLlvmGlobals globals in types' $+$ globals' -- | Pretty print LLVM code -pprLlvmCmmDecl :: LlvmEnv -> Int -> LlvmCmmDecl -> (SDoc, [LlvmVar]) -pprLlvmCmmDecl _ _ (CmmData _ lmdata) - = (vcat $ map pprLlvmData lmdata, []) +pprLlvmCmmDecl :: Int -> LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar]) +pprLlvmCmmDecl _ (CmmData _ lmdata) + = return (vcat $ map pprLlvmData lmdata, []) -pprLlvmCmmDecl env count (CmmProc mb_info entry_lbl live (ListGraph blks)) - = let (idoc, ivar) = case mb_info of - Nothing -> (empty, []) +pprLlvmCmmDecl count (CmmProc mb_info entry_lbl live (ListGraph blks)) + = do (idoc, ivar) <- case mb_info of + Nothing -> return (empty, []) Just (Statics info_lbl dat) - -> pprInfoTable env count info_lbl (Statics entry_lbl dat) - in (idoc $+$ ( - let sec = mkLayoutSection (count + 1) - (lbl',sec') = case mb_info of + -> pprInfoTable count info_lbl (Statics entry_lbl dat) + + let sec = mkLayoutSection (count + 1) + (lbl',sec') = case mb_info of Nothing -> (entry_lbl, Nothing) Just (Statics info_lbl _) -> (info_lbl, sec) - link = if externallyVisibleCLabel lbl' + link = if externallyVisibleCLabel lbl' then ExternallyVisible else Internal - lmblocks = map (\(BasicBlock id stmts) -> + lmblocks = map (\(BasicBlock id stmts) -> LlvmBlock (getUnique id) stmts) blks - fun = mkLlvmFunc env live lbl' link sec' lmblocks - in ppLlvmFunction fun - ), ivar) + + fun <- mkLlvmFunc live lbl' link sec' lmblocks + + return (idoc $+$ ppLlvmFunction fun, ivar) -- | Pretty print CmmStatic -pprInfoTable :: LlvmEnv -> Int -> CLabel -> CmmStatics -> (SDoc, [LlvmVar]) -pprInfoTable env count info_lbl stat - = let dflags = getDflags env - unres = genLlvmData env (Text, stat) - (_, (ldata, ltypes)) = resolveLlvmData env unres - - setSection ((LMGlobalVar _ ty l _ _ c), d) - = let sec = mkLayoutSection count - ilabel = strCLabel_llvm env info_lbl - `appendFS` fsLit iTableSuf - gv = LMGlobalVar ilabel ty l sec (llvmInfAlign dflags) c - v = if l == Internal then [gv] else [] - in ((gv, d), v) - setSection v = (v,[]) - - (ldata', llvmUsed) = setSection (last ldata) - in if length ldata /= 1 +pprInfoTable :: Int -> CLabel -> CmmStatics -> LlvmM (SDoc, [LlvmVar]) +pprInfoTable count info_lbl stat + = do (ldata, ltypes) <- genLlvmData (Text, stat) + + dflags <- getDynFlags + let setSection (LMGlobal (LMGlobalVar _ ty l _ _ c) d) = do + lbl <- strCLabel_llvm info_lbl + let sec = mkLayoutSection count + ilabel = lbl `appendFS` fsLit iTableSuf + gv = LMGlobalVar ilabel ty l sec (llvmInfAlign dflags) c + v = if l == Internal then [gv] else [] + funInsert ilabel ty + return (LMGlobal gv d, v) + setSection v = return (v,[]) + + (ldata', llvmUsed) <- setSection (last ldata) + if length ldata /= 1 then Outputable.panic "LlvmCodeGen.Ppr: invalid info table!" - else (pprLlvmData ([ldata'], ltypes), llvmUsed) + else return (pprLlvmData ([ldata'], ltypes), llvmUsed) -- | We generate labels for info tables by converting them to the same label diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs index 7271c2f3d9..1b87929499 100644 --- a/compiler/llvmGen/LlvmCodeGen/Regs.hs +++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs @@ -4,7 +4,7 @@ module LlvmCodeGen.Regs ( lmGlobalRegArg, lmGlobalRegVar, alwaysLive, - stgTBAA, top, base, stack, heap, rx, other, tbaa, getTBAA + stgTBAA, baseN, stackN, heapN, rxN, otherN, tbaa, getTBAA ) where #include "HsVersions.h" @@ -15,6 +15,7 @@ import CmmExpr import DynFlags import FastString import Outputable ( panic ) +import Unique -- | Get the LlvmVar function variable storing the real register lmGlobalRegVar :: DynFlags -> GlobalReg -> LlvmVar @@ -76,48 +77,38 @@ lmGlobalReg dflags suf reg alwaysLive :: [GlobalReg] alwaysLive = [BaseReg, Sp, Hp, SpLim, HpLim, node] --- | STG Type Based Alias Analysis metadata -stgTBAA :: [LlvmMeta] +-- | STG Type Based Alias Analysis hierarchy +stgTBAA :: [(Unique, LMString, Maybe Unique)] stgTBAA - = [ MetaUnamed topN [MetaStr (fsLit "top")] - , MetaUnamed stackN [MetaStr (fsLit "stack"), MetaNode topN] - , MetaUnamed heapN [MetaStr (fsLit "heap"), MetaNode topN] - , MetaUnamed rxN [MetaStr (fsLit "rx"), MetaNode heapN] - , MetaUnamed baseN [MetaStr (fsLit "base"), MetaNode topN] + = [ (topN, fsLit "top", Nothing) + , (stackN, fsLit "stack", Just topN) + , (heapN, fsLit "heap", Just topN) + , (rxN, fsLit "rx", Just heapN) + , (baseN, fsLit "base", Just topN) -- FIX: Not 100% sure about 'others' place. Might need to be under 'heap'. -- OR I think the big thing is Sp is never aliased, so might want -- to change the hieracy to have Sp on its own branch that is never -- aliased (e.g never use top as a TBAA node). - , MetaUnamed otherN [MetaStr (fsLit "other"), MetaNode topN] + , (otherN, fsLit "other", Just topN) ] -- | Id values -topN, stackN, heapN, rxN, baseN, otherN:: LlvmMetaUnamed -topN = LMMetaUnamed 0 -stackN = LMMetaUnamed 1 -heapN = LMMetaUnamed 2 -rxN = LMMetaUnamed 3 -baseN = LMMetaUnamed 4 -otherN = LMMetaUnamed 5 - --- | The various TBAA types -top, heap, stack, rx, base, other :: MetaData -top = (tbaa, topN) -heap = (tbaa, heapN) -stack = (tbaa, stackN) -rx = (tbaa, rxN) -base = (tbaa, baseN) -other = (tbaa, otherN) +topN, stackN, heapN, rxN, baseN, otherN :: Unique +topN = getUnique (fsLit "LlvmCodeGen.Regs.topN") +stackN = getUnique (fsLit "LlvmCodeGen.Regs.stackN") +heapN = getUnique (fsLit "LlvmCodeGen.Regs.heapN") +rxN = getUnique (fsLit "LlvmCodeGen.Regs.rxN") +baseN = getUnique (fsLit "LlvmCodeGen.Regs.baseN") +otherN = getUnique (fsLit "LlvmCodeGen.Regs.otherN") -- | The TBAA metadata identifier tbaa :: LMString tbaa = fsLit "tbaa" -- | Get the correct TBAA metadata information for this register type -getTBAA :: GlobalReg -> MetaData -getTBAA BaseReg = base -getTBAA Sp = stack -getTBAA Hp = heap -getTBAA (VanillaReg _ _) = rx -getTBAA _ = top - +getTBAA :: GlobalReg -> Unique +getTBAA BaseReg = baseN +getTBAA Sp = stackN +getTBAA Hp = heapN +getTBAA (VanillaReg _ _) = rxN +getTBAA _ = topN |