Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

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].
  • Loading branch information...
commit 71112493a9b23ed0c705144245111734ae2e922c 1 parent 0a6c42d
@scpmw authored
View
10 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
View
8 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
View
2  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)
View
1  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,
View
5 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
View
6 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)
View
62 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 ()
View
122 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
View
98 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
View
49 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!"
View
21 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], [])
View
18 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}
View
16 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
Please sign in to comment.
Something went wrong with that request. Please try again.