From 71112493a9b23ed0c705144245111734ae2e922c Mon Sep 17 00:00:00 2001 From: Peter Wortmann Date: Mon, 13 Aug 2012 17:38:20 +0100 Subject: [PATCH] Streaming support for the LLVM backend Involves some trickery to support forward references which we don't know the type of. See note [Llvm Forward References]. --- compiler/cmm/CmmInfo.hs | 10 +- compiler/codeGen/CodeGen.lhs | 8 +- compiler/coreSyn/CoreLint.lhs | 2 + compiler/llvmGen/Llvm.hs | 1 + compiler/llvmGen/Llvm/PpLlvm.hs | 5 +- compiler/llvmGen/Llvm/Types.hs | 6 +- compiler/llvmGen/LlvmCodeGen.hs | 62 +++++++----- compiler/llvmGen/LlvmCodeGen/Base.hs | 122 +++++++++++++++++++++--- compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 98 ++++--------------- compiler/llvmGen/LlvmCodeGen/Data.hs | 49 ++++------ compiler/llvmGen/LlvmMeta.hs | 21 ++-- compiler/main/CodeOutput.lhs | 18 ++-- compiler/main/HscMain.hs | 16 ++-- 13 files changed, 227 insertions(+), 191 deletions(-) diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index 5fb727b0a640..ea28f90be400 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -42,15 +42,15 @@ mkEmptyContInfoTable info_lbl , cit_prof = NoProfilingInfo , cit_srt = NoC_SRT } -cmmToRawCmm :: DynFlags -> Stream IO Old.CmmGroup a - -> IO (Stream IO Old.RawCmmGroup a) +cmmToRawCmm :: DynFlags -> Stream IO (Old.CmmGroup, a) () + -> IO (Stream IO (Old.RawCmmGroup, a) ()) cmmToRawCmm dflags cmms = do { uniqs <- mkSplitUniqSupply 'i' - ; let do_one uniqs cmm = do + ; let do_one uniqs (cmm, ticks) = do case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of - (b,uniqs') -> return (uniqs',b) + (b,uniqs') -> return (uniqs',(b, ticks)) -- NB. strictness fixes a space leak. DO NOT REMOVE. - ; return (Stream.mapAccumL do_one uniqs cmms >>= return . snd) + ; return (Stream.mapAccumL do_one uniqs cmms >> return ()) } -- Make a concrete info table, represented as a list of CmmStatic diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs index 6e92dc2ef811..a49e67a37aaa 100644 --- a/compiler/codeGen/CodeGen.lhs +++ b/compiler/codeGen/CodeGen.lhs @@ -62,7 +62,7 @@ codeGen :: DynFlags -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. -> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs -> HpcInfo -- Profiling info - -> Stream IO CmmGroup TickMap + -> Stream IO (CmmGroup, TickMap) () -- N.B. returning '[Cmm]' and not 'Cmm' here makes it -- possible for object splitting to split up the -- pieces later. @@ -72,7 +72,7 @@ codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info = do { liftIO $ showPass dflags "CodeGen" ; cgref <- liftIO $ newIORef =<< initC - ; let cg :: FCode CmmGroup -> Stream IO CmmGroup () + ; let cg :: FCode CmmGroup -> Stream IO (CmmGroup, TickMap) () cg fcode = do cmm <- liftIO $ do st <- readIORef cgref @@ -84,7 +84,7 @@ codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info -- a big space leak. DO NOT REMOVE! writeIORef cgref $! st'{ cgs_tops = nilOL, cgs_stmts = nilOL } - return a + return (a, cgs_tick_map st') Stream.yield cmm ; cg (getCmm $ mkModuleInit dflags cost_centre_info this_mod hpc_info) @@ -92,8 +92,6 @@ codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info ; mapM_ (cg . getCmm . cgTopBinding dflags) stg_binds ; mapM_ (cg . cgTyCon) data_tycons - - ; liftIO $ liftM cgs_tick_map $ readIORef cgref } mkModuleInit diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index dcd366f381ad..37b69189494c 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -197,9 +197,11 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) -- Check whether binder's specialisations contain any out-of-scope variables ; mapM_ (checkBndrIdInScope binder) bndr_vars +{- ; when (isStrongLoopBreaker (idOccInfo binder) && isInlinePragma (idInlinePragma binder)) (addWarnL (ptext (sLit "INLINE binder is (non-rule) loop breaker:") <+> ppr binder)) -- Only non-rule loop breakers inhibit inlining +-} -- Check whether arity and demand type are consistent (only if demand analysis -- already happened) diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs index 7e31b4499051..28ef7a296758 100644 --- a/compiler/llvmGen/Llvm.hs +++ b/compiler/llvmGen/Llvm.hs @@ -33,6 +33,7 @@ module Llvm ( -- * Variables and Type System LlvmVar(..), LlvmStatic(..), LlvmLit(..), LlvmType(..), LlvmAlias, LMGlobal(..), LMString, LMSection, LMAlign, + LMConst(..), -- ** Some basic types i64, i32, i16, i8, i1, i8Ptr, llvmWord, llvmWordPtr, diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs index d358478651f3..559d3a94c40b 100644 --- a/compiler/llvmGen/Llvm/PpLlvm.hs +++ b/compiler/llvmGen/Llvm/PpLlvm.hs @@ -70,7 +70,10 @@ ppLlvmGlobal (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) = Just stat -> ppr stat Nothing -> ppr (pLower $ getVarType var) - const' = if c then text "constant" else text "global" + const' = case c of + Global -> text "global" + Constant -> text "constant" + Alias -> text "alias" in ppAssignment var $ ppr link <+> const' <+> rhs <> sect <> align $+$ newLine diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs index 46111c3ed5fa..2543a8774740 100644 --- a/compiler/llvmGen/Llvm/Types.hs +++ b/compiler/llvmGen/Llvm/Types.hs @@ -86,7 +86,11 @@ ppParams varg p -- | An LLVM section definition. If Nothing then let LLVM decide the section type LMSection = Maybe LMString type LMAlign = Maybe Int -type LMConst = Bool -- ^ is a variable constant or not + +data LMConst = Global -- ^ Mutable global variable + | Constant -- ^ Constant global variable + | Alias -- ^ Alias of another variable + deriving (Eq) newtype LMMetaInt = LMMetaInt {unLMMetaVar :: Int} deriving (Eq, Num, Outputable, Show) diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index a21758d5a4b9..fbf4b43e532c 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -30,6 +30,7 @@ import Outputable import UniqSupply import SysTools ( figureLlvmVersion ) import MonadUtils +import qualified Stream import Data.Maybe ( fromMaybe, catMaybes ) import Control.Monad ( when ) @@ -39,12 +40,14 @@ import System.IO -- ----------------------------------------------------------------------------- -- | Top-level of the LLVM Code generator -- -llvmCodeGen :: DynFlags -> ModLocation -> Handle -> UniqSupply -> [RawCmmGroup] -> TickMap -> IO () -llvmCodeGen dflags location h us cmms tick_map +llvmCodeGen :: DynFlags -> ModLocation -> Handle -> UniqSupply + -> Stream.Stream IO (RawCmmGroup,TickMap) () + -> IO () +llvmCodeGen dflags location h us cmm_stream = do bufh <- newBufHandle h -- get llvm version, cache for later use - ver <- getLlvmVersion + ver <- getLlvmVersion dflags -- warn if unsupported when (ver < minSupportLlvmVersion) $ @@ -58,12 +61,13 @@ llvmCodeGen dflags location h us cmms tick_map -- run code generation runLlvm dflags ver bufh us $ - llvmCodeGen' location cmms tick_map + llvmCodeGen' location (liftStream cmm_stream) bFlush bufh - where - -- | Handle setting up the LLVM version. - getLlvmVersion = do + +-- | Handle setting up the LLVM version. +getLlvmVersion :: DynFlags -> IO Int +getLlvmVersion dflags = do ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags -- cache llvm version for later use writeIORef (llvmVersion dflags) ver @@ -78,35 +82,45 @@ llvmCodeGen dflags location h us cmms tick_map return ver +llvmCodeGen' :: ModLocation -> Stream.Stream LlvmM (RawCmmGroup,TickMap) () -> LlvmM () +llvmCodeGen' location cmm_stream + = do -- Preamble + renderLlvm pprLlvmHeader + ghcInternalFunctions + cmmMetaLlvmPrelude location + + -- Procedures + let llvmStream = Stream.mapM (llvmGroupLlvmGens location) cmm_stream + tick_maps <- Stream.collect llvmStream + + -- Declare aliases for forward references + renderLlvm . pprLlvmData =<< generateAliases + + -- Postamble + cmmMetaLlvmUnit location + cmmDebugLlvmGens location (last tick_maps) + cmmUsedLlvmGens + +llvmGroupLlvmGens :: ModLocation -> (RawCmmGroup, TickMap) -> LlvmM TickMap +llvmGroupLlvmGens location (cmm, tick_map) = do -llvmCodeGen' :: ModLocation -> [RawCmmGroup] -> TickMap -> LlvmM () -llvmCodeGen' location cmms tick_map - = do -- Insert functions into map, collect data let split (CmmData s d' ) = return $ Just (s, d') split p@(CmmProc _ l _) = do - lbl <- strCLabel_llvm $ case topInfoTable p of + let l' = case topInfoTable p of Nothing -> l Just (Statics info_lbl _) -> info_lbl - funInsert lbl =<< llvmFunTy + lml <- strCLabel_llvm l' + funInsert lml =<< llvmFunTy + labelInsert l l' return Nothing - let cmm = concat cmms cdata <- fmap catMaybes $ mapM split cmm - renderLlvm pprLlvmHeader - ghcInternalFunctions - cmmMetaLlvmPrelude location - {-# SCC "llvm_datas_gen" #-} cmmDataLlvmGens cdata [] {-# SCC "llvm_procs_gen" #-} cmmProcLlvmGens location cmm tick_map 1 - - cmmMetaLlvmUnit location - cmmDebugLlvmGens location tick_map cmm - - cmmUsedLlvmGens - + return tick_map -- ----------------------------------------------------------------------------- -- | Do LLVM code generation on all these Cmms data sections. @@ -196,7 +210,7 @@ cmmUsedLlvmGens = do ty = (LMArray (length ivars) i8Ptr) usedArray = LMStaticArray (map cast ivars) ty sectName = Just $ fsLit "llvm.metadata" - lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending sectName Nothing False + lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending sectName Nothing Constant lmUsed = LMGlobal lmUsedVar (Just usedArray) if null ivars then return () diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index ab81f1296837..2cbebd4c2e30 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -13,9 +13,10 @@ module LlvmCodeGen.Base ( maxSupportLlvmVersion, LlvmM, - runLlvm, withClearVars, varLookup, varInsert, + runLlvm, liftStream, withClearVars, varLookup, varInsert, markStackReg, checkStackReg, funLookup, funInsert, getLlvmVer, getDynFlag, getLlvmPlatform, + labelInsert, getLabelMap, renderLlvm, runUs, markUsedVar, getUsedVars, ghcInternalFunctions, @@ -29,7 +30,7 @@ module LlvmCodeGen.Base ( llvmRegArgPos, llvmPtrBits, mkLlvmFunc, tysToParams, strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm, - genCmmLabelRef, genStringLabelRef + getGlobalPtr, generateAliases, ) where @@ -51,8 +52,10 @@ import UniqFM import Unique import MonadUtils ( MonadIO(..) ) import BufWrite ( BufHandle ) +import UniqSet import UniqSupply import ErrUtils +import qualified Stream import Data.List ( elemIndex ) @@ -187,6 +190,8 @@ data LlvmEnv = LlvmEnv , envVarMap :: LlvmEnvMap , envStackRegs :: [GlobalReg] , envUsedVars :: [LlvmVar] + , envDelayedTypes :: UniqSet LMString + , envLabelMap :: [(CLabel, CLabel)] , envVersion :: LlvmVersion , envDynFlags :: DynFlags , envOutput :: BufHandle @@ -224,6 +229,8 @@ runLlvm dflags ver out us m = do , envVarMap = emptyUFM , envStackRegs = [] , envUsedVars = [] + , envDelayedTypes = emptyUniqSet + , envLabelMap = [] , envVersion = ver , envDynFlags = dflags , envOutput = out @@ -234,11 +241,27 @@ runLlvm dflags ver out us m = do , envProcMeta = [] } +-- | Get environment (internal) +getEnv :: LlvmM LlvmEnv +getEnv = LlvmM $ \env -> return (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. withClearVars :: LlvmM a -> LlvmM a withClearVars m = LlvmM $ \env -> do (x, env') <- runLlvmM m env { envVarMap = emptyUFM, envStackRegs = [] } - return (x, env' { envVarMap = envVarMap env, envStackRegs = envStackRegs env }) + return (x, env' { envVarMap = emptyUFM, envStackRegs = [] }) -- | Insert variables or functions into the environment. varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmM () @@ -258,6 +281,14 @@ markStackReg r = LlvmM $ \env -> return ((), env { envStackRegs = r : envStackRe checkStackReg :: GlobalReg -> LlvmM Bool checkStackReg r = LlvmM $ \env -> return (r `elem` envStackRegs env, env) +-- | Register the LLVM label for a CMM label +labelInsert :: CLabel -> CLabel -> LlvmM () +labelInsert cl ll = LlvmM $ \env -> return ((), env { envLabelMap = (ll,cl):envLabelMap env }) + +-- | Lookup LLVM label of a CMM label +getLabelMap :: LlvmM [(CLabel, CLabel)] +getLabelMap = LlvmM $ \env -> return (envLabelMap env, env) + -- | Allocate a new global unnamed metadata identifier getMetaUniqueId :: LlvmM LMMetaInt getMetaUniqueId = LlvmM $ \env -> return (envFreshMeta env, env { envFreshMeta = envFreshMeta env + 1}) @@ -320,6 +351,10 @@ markUsedVar v = LlvmM $ \env -> return ((), env { envUsedVars = v : envUsedVars getUsedVars :: LlvmM [LlvmVar] getUsedVars = LlvmM $ \env -> return (envUsedVars env, env) +-- | Saves that at some point we didn't know the type of the label and +-- generated a reference to a type variable instead +delayType :: LMString -> LlvmM () +delayType lbl = LlvmM $ \env -> return ((), env { envDelayedTypes = addOneToUniqSet (envDelayedTypes env) lbl }) -- | Convenience functions for defining getters getLlvmEnv :: (LlvmEnv -> a) -> LlvmM a @@ -389,16 +424,79 @@ strProcedureName_llvm lbl = do str = Outp.renderWithStyle dflags sdoc style return (fsLit str) --- | Create an external definition for a 'CLabel' defined in another module. -genCmmLabelRef :: CLabel -> LlvmM LMGlobal -genCmmLabelRef = fmap genStringLabelRef . strCLabel_llvm - --- | As above ('genCmmLabelRef') but taking a 'LMString', not 'CLabel'. -genStringLabelRef :: LMString -> LMGlobal -genStringLabelRef cl - = let ty = LMPointer $ LMArray 0 llvmWord - in LMGlobal (LMGlobalVar cl ty External Nothing Nothing False) Nothing +-- ---------------------------------------------------------------------------- +-- | Create/get a pointer to a static value. The value type might be +-- an undefined forward type alias if the value in question hasn't +-- been defined yet. +getGlobalPtr :: LMString -> LlvmM LlvmVar +getGlobalPtr llvmLbl = do + m_ty <- funLookup llvmLbl + let mkGlbVar lbl ty = LMGlobalVar lbl (LMPointer ty) ExternallyVisible Nothing Nothing + case m_ty of + -- Directly reference if we have seen it already + Just ty -> return $ mkGlbVar llvmLbl ty Global + -- Otherwise reference a forward alias of it + Nothing -> do + delayType llvmLbl + return $ mkGlbVar + (llvmLbl `appendFS` fsLit "_alias") + (LMAlias (llvmLbl `appendFS` fsLit "_type", undefined)) + Alias + +-- | Generate aliases for references that were created while compiling. +generateAliases :: LlvmM ([LMGlobal], [LlvmType]) +generateAliases = do + delayed <- fmap (uniqSetToList . envDelayedTypes) getEnv + defss <- flip mapM delayed $ \lbl -> do + -- Defined by now? + m_ty <- funLookup lbl + let mkVar ty link = LMGlobalVar lbl (LMPointer ty) link Nothing Nothing Global + (defs, ty, var) = case m_ty of + Just ty -> ([], ty, mkVar ty ExternallyVisible) + Nothing -> let ty = LMArray 0 llvmWord + var = mkVar ty External + in ([LMGlobal var Nothing], ty, var) + aliasLbl = lbl `appendFS` fsLit "_alias" + tyLbl = lbl `appendFS` fsLit "_type" + aliasVar = LMGlobalVar aliasLbl (LMPointer ty) ExternallyVisible Nothing Nothing Alias + return ((LMGlobal aliasVar $ Just $ LMStaticPointer var) : defs, + LMAlias (tyLbl, ty) + ) + -- Reset forward list + modifyEnv $ \env -> env { envDelayedTypes = emptyUniqSet } + let (gss, ts) = unzip defss + return (concat gss, ts) + +-- Note [Llvm Forward References] +-- +-- The big issue here is that we might want to refer to values that haven't +-- been defined by this point in the compilation process - and we can't +-- really wait or the whole streaming wouldn't make sense. And after all, LLVM +-- plays really well with forward references, so why not use that? +-- +-- Well, the problem is that LLVM is strongly typed, so we positively can't +-- refer to something of which we don't know the type. Sadly, CMM also doesn't +-- carry that kind of information (unless I'm mistaken, of course). So what +-- we do is to define type aliases into the code so we can fill in later what +-- the type in question is expected to be. +-- +-- So why do we have to alias the value *itself*? This is actually mainly a +-- workaround, as it turns out that LLVM chokes on this code: +-- +-- @ptr = constant %typ* @fun; +-- %typ = type i32 (); +-- define i32 @fun() { ret i32 0; } +-- +-- No matter what we do, opt will crash, because it doesn't expect "fun" to have +-- been mentioned with an aliased type. So what we do here is to actually never +-- refer to "fun" itself, but instead refer to a *value* alias of it instead, +-- which we can later set to the proper value without any further hassle: +-- +-- @ptr = constant %typ* @fun_alias; +-- define i32 @fun() { ret i32 0; } +-- %typ = type i32 (); +-- @fun_alias = alias %typ* @fun; -- ---------------------------------------------------------------------------- -- * Misc diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index b63d06ba855a..f412251ca7f3 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -124,7 +124,7 @@ declareInstrinct fname retTy parTys = do FixedArgs (tysToParams parTys) Nothing let fty = LMFunction funSig - let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing False + let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing Constant fn <- funLookup fname tops <- case fn of @@ -337,9 +337,9 @@ genCall target res args ret = do getFunPtr :: (LMString -> LlvmType) -> CmmCallTarget -> LlvmM ExprData getFunPtr funTy targ = case targ of - CmmCallee (CmmLit (CmmLabel lbl)) _ -> do + CmmCallee (CmmLit (CmmLabel lbl)) _ -> do name <- strCLabel_llvm lbl - litCase name + getHsFunc' name (funTy name) CmmCallee expr _ -> do (v1, stmts, top) <- exprToVar expr @@ -355,36 +355,9 @@ getFunPtr funTy targ = case targ of (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty) return (v2, stmts `snocOL` s1, top) - CmmPrim mop _ -> cmmPrimOpFunctions mop >>= litCase - - where - litCase name = do - fn <- funLookup name - case fn of - Just ty'@(LMFunction sig) -> do - -- Function in module in right form - let fun = LMGlobalVar name ty' (funcLinkage sig) - Nothing Nothing False - return (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 (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])]] - funInsert name fty - return (fun, nilOL, top) - + CmmPrim mop _ -> do + name <- cmmPrimOpFunctions mop + getHsFunc' name (funTy name) -- | Conversion of call arguments. arg_vars :: [HintedCmmActual] @@ -1201,25 +1174,10 @@ genLit (CmmFloat r w) nilOL, []) genLit cmm@(CmmLabel l) - = do label <- strCLabel_llvm l - ty <- funLookup label + = do var <- getGlobalPtr =<< strCLabel_llvm l let lmty = cmmToLlvmType $ cmmLitType cmm - case ty of - -- Make generic external label definition and then pointer to it - Nothing -> do - let glob@(LMGlobal var _) = genStringLabelRef label - let ldata = [CmmData Data [([glob], [])]] - funInsert label (pLower $ getVarType var) - (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord - return (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 - return (v1, unitOL s1, []) + (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord + return (v1, unitOL s1, []) genLit (CmmLabelOff label off) = do (vlbl, stmts, stat) <- genLit (CmmLabel label) @@ -1404,32 +1362,18 @@ trashRegs = do plat <- getLlvmPlatform -- with foreign functions. getHsFunc :: CLabel -> LlvmM ExprData getHsFunc lbl - = do fn <- strCLabel_llvm lbl - ty <- funLookup fn - 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 (fun, nilOL, []) - - -- label in module but not function pointer, convert - Just ty' -> do - let fun = LMGlobalVar fn (pLift ty') ExternallyVisible - Nothing Nothing False - funTy <- llvmFunTy - (v1, s1) <- doExpr (pLift funTy) $ - Cast LM_Bitcast fun (pLift funTy) - return (v1, unitOL s1, []) - - -- label not in module, create external reference - Nothing -> do - sig <- llvmFunSig lbl ExternallyVisible - let ty' = LMFunction sig - let fun = LMGlobalVar fn ty' ExternallyVisible Nothing Nothing False - let top = CmmData Data [([],[ty'])] - funInsert fn ty' - return (fun, nilOL, [top]) - + = do fty <- llvmFunTy + 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 -> LlvmM LlvmVar diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs index 4af338cfdc43..b92aa61bd894 100644 --- a/compiler/llvmGen/LlvmCodeGen/Data.hs +++ b/compiler/llvmGen/LlvmCodeGen/Data.hs @@ -55,13 +55,13 @@ resolveLlvmDatas = mapM resolveLlvmData resolveLlvmData :: LlvmUnresData -> LlvmM LlvmData resolveLlvmData (lbl, sec, alias, unres) = do label <- strCLabel_llvm lbl - (static, refs) <- resDatas unres + static <- resDatas unres let struct = Just $ LMStaticStruc static alias 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 - return (LMGlobal glob struct : refs, [alias]) + return ([LMGlobal glob struct], [alias]) -- | Should a data in this section be considered constant isSecConstant :: Section -> Bool @@ -79,52 +79,37 @@ isSecConstant (OtherSection _) = False -- -- | Resolve data list -resDatas :: [UnresStatic] -> LlvmM ([LlvmStatic], [LMGlobal]) +resDatas :: [UnresStatic] -> LlvmM [LlvmStatic] -resDatas cmms = do - (stats, globss) <- fmap unzip $ mapM resData cmms - return (stats, concat globss) +resDatas cmms = mapM resData cmms -- | 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 :: UnresStatic -> LlvmM (LlvmStatic, [LMGlobal]) +-- then make a pointer (see @getCmmStatic@). +resData :: UnresStatic -> LlvmM LlvmStatic -resData (Right stat) = return (stat, []) +resData (Right stat) = return stat resData (Left cmm@(CmmLabel l)) = do - label <- strCLabel_llvm l - ty <- funLookup label - let lmty = cmmToLlvmType $ cmmLitType cmm - case ty of - -- Make generic external label defenition and then pointer to it - Nothing -> do - let glob@(LMGlobal var _) = genStringLabelRef label - ptr = LMStaticPointer var - funInsert label (pLower $ getVarType var) - return (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 return (LMPtoI ptr lmty, []) + var <- getGlobalPtr =<< strCLabel_llvm l + let ptr = LMStaticPointer var + lmty = cmmToLlvmType $ cmmLitType cmm + return $ LMPtoI ptr lmty resData (Left (CmmLabelOff label off)) = do - (var, glob) <- resData (Left (CmmLabel label)) + var <- resData (Left (CmmLabel label)) let offset = LMStaticLit $ LMIntLit (toInteger off) llvmWord - return (LMAdd var offset, glob) + return $ LMAdd var offset resData (Left (CmmLabelDiffOff l1 l2 off)) = do - (var1, glob1) <- resData (Left (CmmLabel l1)) - (var2, glob2) <- resData (Left (CmmLabel l2)) + var1 <- resData (Left (CmmLabel l1)) + var2 <- resData (Left (CmmLabel l2)) let var = LMSub var1 var2 offset = LMStaticLit $ LMIntLit (toInteger off) llvmWord - return (LMAdd var offset, glob1 ++ glob2) + return $ LMAdd var offset resData _ = panic "resData: Non CLabel expr as left type!" diff --git a/compiler/llvmGen/LlvmMeta.hs b/compiler/llvmGen/LlvmMeta.hs index f1529fb845d4..671655987ddd 100644 --- a/compiler/llvmGen/LlvmMeta.hs +++ b/compiler/llvmGen/LlvmMeta.hs @@ -23,7 +23,6 @@ import LlvmCodeGen.Base import LlvmCodeGen.Ppr import LlvmCodeGen.Regs ( stgTBAA ) -import BlockId ( blockLbl ) import CLabel import Module import DynFlags @@ -32,7 +31,6 @@ import Debug import Binary import Config ( cProjectName, cProjectVersion ) -import OldCmm import Platform import SrcLoc (srcSpanFile, srcSpanStartLine, srcSpanStartCol, @@ -252,8 +250,8 @@ cmmMetaLlvmProc cmmLabel entryLabel blockLabels mod_loc tiMap = do displayName <- strDisplayName_llvm entryLabel funTy <- llvmFunTy - let funRef = LMGlobalVar linkageName (LMPointer funTy) Internal Nothing Nothing True - local = not . externallyVisibleCLabel $ entryLabel + funRef <- getGlobalPtr linkageName + let local = not . externallyVisibleCLabel $ entryLabel procedureName = displayName opt <- getDynFlag optLevel @@ -514,19 +512,12 @@ bufferAsString (len, buf) = liftIO $ do -- because the pretty-printing will append a zero byte. return $ LMStaticStr str $ LMArray (len + 1) i8 -cmmDebugLlvmGens :: ModLocation -> TickMap -> [RawCmmDecl] -> LlvmM () -cmmDebugLlvmGens mod_loc tick_map cmm = do - - -- Build a list mapping Cmm labels to linker labels - let proc_lbl p l = case topInfoTable p of - Just (Statics info_lbl _) -> info_lbl - _ -> l - block_lbls (BasicBlock i _) = let l = blockLbl i in (l,l) - lbls = concat [ (l, proc_lbl p l) : map block_lbls bs - | p@(CmmProc _ l (ListGraph bs)) <- cmm] +cmmDebugLlvmGens :: ModLocation -> TickMap -> LlvmM () +cmmDebugLlvmGens mod_loc tick_map = do -- Write debug data as event log dflags <- getDynFlag id + lbls <- getLabelMap dbg <- liftIO $ debugWriteEventlog dflags mod_loc tick_map lbls -- Convert to a string @@ -539,7 +530,7 @@ cmmDebugLlvmGens mod_loc tick_map cmm = do OSDarwin -> "__DWARF," _ -> "." sectName = Just $ fsLit (sectPrefix ++ "debug_ghc") - lmDebugVar = LMGlobalVar debug_sym (getStatType dbgStr) Internal sectName Nothing False + lmDebugVar = LMGlobalVar debug_sym (getStatType dbgStr) Internal sectName Nothing Constant lmDebug = LMGlobal lmDebugVar (Just dbgStr) renderLlvm $ pprLlvmData ([lmDebug], []) diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index ef6efe738a19..90a11c7a39ba 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -49,7 +49,7 @@ codeOutput :: DynFlags -> ModLocation -> ForeignStubs -> [PackageId] - -> Stream IO RawCmmGroup TickMap -- Compiled C-- + -> Stream IO (RawCmmGroup, TickMap) () -- Compiled C-- -> IO (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}) codeOutput dflags this_mod location foreign_stubs pkg_deps cmm_stream @@ -61,20 +61,20 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps cmm_stream then Stream.mapM do_lint cmm_stream else cmm_stream - do_lint cmm = do + do_lint r@(cmm, _) = do { showPass dflags "CmmLint" ; case cmmLint (targetPlatform dflags) cmm of Just err -> do { log_action dflags dflags SevDump noSrcSpan defaultDumpStyle err ; ghcExit dflags 1 } Nothing -> return () - ; return cmm + ; return r } ; showPass dflags "CodeOutput" - ; let filenm = hscOutName dflags + ; let filenm = hscOutName dflags ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs - ; let unticked_cmm_stream = linted_cmm_stream >> return () + ; let unticked_cmm_stream = Stream.map fst linted_cmm_stream ; case hscTarget dflags of { HscInterpreted -> return (); HscAsm -> outputAsm dflags filenm unticked_cmm_stream; @@ -162,17 +162,13 @@ outputAsm dflags filenm cmm_stream %************************************************************************ \begin{code} -outputLlvm :: DynFlags -> ModLocation -> FilePath -> Stream IO RawCmmGroup TickMap -> IO () +outputLlvm :: DynFlags -> ModLocation -> FilePath -> Stream IO (RawCmmGroup,TickMap) () -> IO () outputLlvm dflags location filenm cmm_stream = do ncg_uniqs <- mkSplitUniqSupply 'n' - -- ToDo: make the LLVM backend consume the C-- incrementally, - -- by pushing the cmm_stream inside (c.f. nativeCodeGen) - (rawcmms, tick_map) <- Stream.collect2 cmm_stream - {-# SCC "llvm_output" #-} doOutput filenm $ \f -> {-# SCC "llvm_CodeGen" #-} - llvmCodeGen dflags location f ncg_uniqs rawcmms tick_map + llvmCodeGen dflags location f ncg_uniqs cmm_stream \end{code} diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 03c3d15edba0..305e964ef7f8 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -1287,7 +1287,7 @@ hscGenHardCode cgguts mod_summary = do cmmToRawCmm dflags cmms let dump a = do dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm" - (ppr a) + (ppr $ fst a) return a rawcmms1 = Stream.mapM dump rawcmms0 @@ -1343,8 +1343,8 @@ hscCompileCmmFile hsc_env filename = runHsc hsc_env $ do let dflags = hsc_dflags hsc_env cmm <- ioMsgMaybe $ parseCmmFile dflags filename liftIO $ do - rawCmms <- cmmToRawCmm dflags (Stream.yield cmm) - _ <- codeOutput dflags no_mod no_loc NoStubs [] (rawCmms >> return Data.Map.empty) + rawCmms <- cmmToRawCmm dflags (Stream.yield (cmm, Data.Map.empty)) + _ <- codeOutput dflags no_mod no_loc NoStubs [] rawCmms return () where no_mod = panic "hscCmmFile: no_mod" @@ -1358,7 +1358,7 @@ tryNewCodeGen :: HscEnv -> Module -> [TyCon] -> CollectedCCs -> [(StgBinding,[(Id,[Id])])] -> HpcInfo - -> IO (Stream IO Old.CmmGroup TickMap) + -> IO (Stream IO (Old.CmmGroup, TickMap) ()) -- Note we produce a 'Stream' of CmmGroups, so that the -- backend can be run incrementally. Otherwise it generates all -- the C-- up front, which has a significant space cost. @@ -1389,19 +1389,19 @@ tryNewCodeGen hsc_env this_mod data_tycons let run_pipeline topSRT cmmgroup = do (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT cmmgroup - return (topSRT,cmmOfZgraph cmmgroup) + return (topSRT,(cmmOfZgraph cmmgroup, Data.Map.empty)) let pipeline_stream = {-# SCC "cmmPipeline" #-} do (topSRT, _) <- Stream.mapAccumL run_pipeline initTopSRT ppr_stream1 - Stream.yield (cmmOfZgraph (srtToData topSRT)) + Stream.yield (cmmOfZgraph (srtToData topSRT), Data.Map.empty) let - dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" $ ppr a + dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" $ ppr $ fst a return a ppr_stream2 = Stream.mapM dump2 pipeline_stream - return (ppr_stream2 >> return Data.Map.empty) + return ppr_stream2