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

@@ -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

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,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

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)

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,

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

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)

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 ()