Permalink
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...
scpmw committed Aug 13, 2012
1 parent 0a6c42d commit 71112493a9b23ed0c705144245111734ae2e922c
View
@@ -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
@@ -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,16 +84,14 @@ 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)
; mapM_ (cg . getCmm . cgTopBinding dflags) stg_binds
; mapM_ (cg . cgTyCon) data_tycons
-
- ; liftIO $ liftM cgs_tick_map $ readIORef cgref
}
mkModuleInit
@@ -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
@@ -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,
@@ -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
@@ -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)
@@ -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 ()
Oops, something went wrong.

0 comments on commit 7111249

Please sign in to comment.