Major Llvm refactoring

This combined patch reworks the LLVM backend in a number of ways:

1. Most prominently, we introduce a LlvmM monad carrying the contents of
   the old LlvmEnv around. This patch completely removes LlvmEnv and
   refactors towards standard library monad combinators wherever possible.

2. Support for streaming - we can now generate chunks of Llvm for Cmm as
   it comes in. This might improve our speed.

3. To allow streaming, we need a more flexible way to handle forward
   references. The solution (getGlobalPtr) unifies LlvmCodeGen.Data
   and getHsFunc as well.

4. Skip alloca-allocation for registers that are actually never written.
   LLVM will automatically eliminate these, but output is smaller and
   friendlier to human eyes this way.

5. We use LlvmM to collect references for llvm.used. This allows places
   other than cmmProcLlvmGens to generate entries.

compiler/llvmGen/Llvm/Types.hs

@@ -623,6 +623,8 @@ data LlvmLinkageType
   -- | Alias for 'ExternallyVisible' but with explicit textual form in LLVM
   --  assembly.
   | External
+  -- | Symbol is private to the module and should not appear in the symbol table
+  | Private
   deriving (Eq)
 
 instance Outputable LlvmLinkageType where

compiler/llvmGen/LlvmCodeGen.hs

@@ -11,6 +11,7 @@ import LlvmCodeGen.Base
 import LlvmCodeGen.CodeGen
 import LlvmCodeGen.Data
 import LlvmCodeGen.Ppr
+import LlvmCodeGen.Regs
 import LlvmMangler
 
 import CgUtils ( fixStgRegisters )
@@ -23,143 +24,175 @@ import DynFlags
 import ErrUtils
 import FastString
 import Outputable
-import qualified Pretty as Prt
 import UniqSupply
-import Util
 import SysTools ( figureLlvmVersion )
+import MonadUtils
+import qualified Stream
 
 import Control.Monad ( when )
 import Data.IORef ( writeIORef )
-import Data.Maybe ( fromMaybe )
+import Data.Maybe ( fromMaybe, catMaybes )
 import System.IO
 
 -- -----------------------------------------------------------------------------
 -- | Top-level of the LLVM Code generator
 --
-llvmCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmmGroup] -> IO ()
-llvmCodeGen dflags h us cmms
-  = let cmm = concat cmms
-        (cdata,env) = {-# SCC "llvm_split" #-}
-                      foldr split ([], initLlvmEnv dflags) cmm
-        split (CmmData s d' ) (d,e) = ((s,d'):d,e)
-        split (CmmProc h l live g) (d,e) =
-            let lbl = strCLabel_llvm env $
-                        case mapLookup (g_entry g) h of
-                          Nothing                   -> l
-                          Just (Statics info_lbl _) -> info_lbl
-                env' = funInsert lbl (llvmFunTy dflags live) e
-            in (d,env')
-    in do
-        showPass dflags "LlVM CodeGen"
-        dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" pprLlvmHeader
-        bufh <- newBufHandle h
-        Prt.bufLeftRender bufh $ withPprStyleDoc dflags (mkCodeStyle CStyle) pprLlvmHeader
-        ver  <- getLlvmVersion
-        env' <- {-# SCC "llvm_datas_gen" #-}
-                cmmDataLlvmGens dflags bufh (setLlvmVer ver env) cdata []
-        {-# SCC "llvm_procs_gen" #-}
-             cmmProcLlvmGens dflags bufh us env' cmm 1 []
-        bFlush bufh
-        return  ()
-
-  where
-    -- | Handle setting up the LLVM version.
-    getLlvmVersion = do
-        ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags
-        -- cache llvm version for later use
-        writeIORef (llvmVersion dflags) ver
-        debugTraceMsg dflags 2
-            (text "Using LLVM version:" <+> text (show ver))
-        let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags
-        when (ver < minSupportLlvmVersion && doWarn) $
-            errorMsg dflags (text "You are using an old version of LLVM that"
-                             <> text " isn't supported anymore!"
-                             $+$ text "We will try though...")
-        when (ver > maxSupportLlvmVersion && doWarn) $
-            putMsg dflags (text "You are using a new version of LLVM that"
-                           <> text " hasn't been tested yet!"
-                           $+$ text "We will try though...")
-        return ver
+llvmCodeGen :: DynFlags -> Handle -> UniqSupply
+               -> Stream.Stream IO RawCmmGroup ()
+               -> IO ()
+llvmCodeGen dflags h us cmm_stream
+  = do bufh <- newBufHandle h
+
+       -- Pass header
+       showPass dflags "LLVM CodeGen"
 
+       -- get llvm version, cache for later use
+       ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags
+       writeIORef (llvmVersion dflags) ver
+
+       -- warn if unsupported
+       debugTraceMsg dflags 2
+            (text "Using LLVM version:" <+> text (show ver))
+       let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags
+       when (ver < minSupportLlvmVersion && doWarn) $
+           errorMsg dflags (text "You are using an old version of LLVM that"
+                            <> text " isn't supported anymore!"
+                            $+$ text "We will try though...")
+       when (ver > maxSupportLlvmVersion && doWarn) $
+           putMsg dflags (text "You are using a new version of LLVM that"
+                          <> text " hasn't been tested yet!"
+                          $+$ text "We will try though...")
+
+       -- run code generation
+       runLlvm dflags ver bufh us $
+         llvmCodeGen' (liftStream cmm_stream)
+
+       bFlush bufh
+
+llvmCodeGen' :: Stream.Stream LlvmM RawCmmGroup () -> LlvmM ()
+llvmCodeGen' cmm_stream
+  = do  -- Preamble
+        renderLlvm pprLlvmHeader
+        ghcInternalFunctions
+        cmmMetaLlvmPrelude
+
+        -- Procedures
+        let llvmStream = Stream.mapM llvmGroupLlvmGens cmm_stream
+        _ <- Stream.collect llvmStream
+
+        -- Declare aliases for forward references
+        renderLlvm . pprLlvmData =<< generateAliases
+
+        -- Postamble
+        cmmUsedLlvmGens
+
+llvmGroupLlvmGens :: RawCmmGroup -> LlvmM ()
+llvmGroupLlvmGens cmm = do
+
+        -- Insert functions into map, collect data
+        let split (CmmData s d' )     = return $ Just (s, d')
+            split (CmmProc h l live g) = do
+              -- Set function type
+              let l' = case mapLookup (g_entry g) h of
+                         Nothing                   -> l
+                         Just (Statics info_lbl _) -> info_lbl
+              lml <- strCLabel_llvm l'
+              funInsert lml =<< llvmFunTy live
+              return Nothing
+        cdata <- fmap catMaybes $ mapM split cmm
+
+        {-# SCC "llvm_datas_gen" #-}
+          cmmDataLlvmGens cdata
+        {-# SCC "llvm_procs_gen" #-}
+          mapM_ cmmLlvmGen cmm
 
 -- -----------------------------------------------------------------------------
 -- | Do LLVM code generation on all these Cmms data sections.
 --
-cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [(Section,CmmStatics)]
-                -> [LlvmUnresData] -> IO ( LlvmEnv )
-
-cmmDataLlvmGens dflags h env [] lmdata
-  = let (env', lmdata') = {-# SCC "llvm_resolve" #-}
-                          resolveLlvmDatas env lmdata
-        lmdoc = {-# SCC "llvm_data_ppr" #-}
-                vcat $ map pprLlvmData lmdata'
-    in do
-        dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" lmdoc
-        {-# SCC "llvm_data_out" #-}
-            Prt.bufLeftRender h $ withPprStyleDoc dflags (mkCodeStyle CStyle) lmdoc
-        return env'
-
-cmmDataLlvmGens dflags h env (cmm:cmms) lmdata
-  = let lm@(l, _, ty, _) = {-# SCC "llvm_data_gen" #-}
-                           genLlvmData env cmm
-        env' = {-# SCC "llvm_data_insert" #-}
-               funInsert (strCLabel_llvm env l) ty env
-        lmdata' = {-# SCC "llvm_data_append" #-}
-                  lm:lmdata
-    in cmmDataLlvmGens dflags h env' cmms lmdata'
+cmmDataLlvmGens :: [(Section,CmmStatics)] -> LlvmM ()
 
+cmmDataLlvmGens statics
+  = do lmdatas <- mapM genLlvmData statics
 
--- -----------------------------------------------------------------------------
--- | Do LLVM code generation on all these Cmms procs.
---
-cmmProcLlvmGens :: DynFlags -> BufHandle -> UniqSupply -> LlvmEnv -> [RawCmmDecl]
-      -> Int         -- ^ count, used for generating unique subsections
-      -> [[LlvmVar]] -- ^ info tables that need to be marked as 'used'
-      -> IO ()
-
-cmmProcLlvmGens dflags h _ _ [] _ ivars
-    | null ivars' = return ()
-    | otherwise   = Prt.bufLeftRender h $
-                        {-# SCC "llvm_used_ppr" #-}
-                        withPprStyleDoc dflags (mkCodeStyle CStyle) $
-                        pprLlvmData ([lmUsed], [])
-  where
-    ivars' = concat ivars
-    cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
-    ty     = (LMArray (length ivars') i8Ptr)
-    usedArray = LMStaticArray (map cast ivars') ty
-    lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending
-                  (Just $ fsLit "llvm.metadata") Nothing Global
-    lmUsed    = LMGlobal lmUsedVar (Just usedArray)
-
-cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars
- = cmmProcLlvmGens dflags h us env cmms count ivars
-
-cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars = do
-    (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm
-    let (docs, ivar) = mapAndUnzip (pprLlvmCmmDecl env' count) llvm
-    Prt.bufLeftRender h $ {-# SCC "llvm_proc_ppr" #-}
-                          withPprStyleDoc dflags (mkCodeStyle CStyle) $ vcat docs
-    cmmProcLlvmGens dflags h us' env' cmms (count + 2) (ivar ++ ivars)
+       let (gss, tss) = unzip lmdatas
 
+       let regGlobal (LMGlobal (LMGlobalVar l ty _ _ _ _) _)
+                        = funInsert l ty
+           regGlobal _  = return ()
+       mapM_ regGlobal (concat gss)
+
+       renderLlvm $ pprLlvmData (concat gss, concat tss)
 
 -- | Complete LLVM code generation phase for a single top-level chunk of Cmm.
-cmmLlvmGen :: DynFlags -> UniqSupply -> LlvmEnv -> RawCmmDecl
-            -> IO ( UniqSupply, LlvmEnv, [LlvmCmmDecl] )
-cmmLlvmGen dflags us env cmm = do
+cmmLlvmGen ::RawCmmDecl -> LlvmM ()
+cmmLlvmGen cmm@CmmProc{} = do
+
     -- rewrite assignments to global regs
+    dflags <- getDynFlag id
     let fixed_cmm = {-# SCC "llvm_fix_regs" #-}
                     fixStgRegisters dflags cmm
 
-    dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm"
+    liftIO $ dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm"
         (pprCmmGroup [fixed_cmm])
 
     -- generate llvm code from cmm
-    let ((env', llvmBC), usGen) = {-# SCC "llvm_proc_gen" #-}
-                                  initUs us $ genLlvmProc env fixed_cmm
+    llvmBC <- withClearVars $ genLlvmProc fixed_cmm
 
-    dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code"
-        (vcat $ map (fst . pprLlvmCmmDecl env' 0) llvmBC)
+    -- allocate IDs for info table and code, so the mangler can later
+    -- make sure they end up next to each other.
+    itableSection <- freshSectionId
+    _codeSection <- freshSectionId
 
-    return (usGen, env', llvmBC)
+    -- pretty print
+    (docs, ivars) <- fmap unzip $ mapM (pprLlvmCmmDecl itableSection) llvmBC
+
+    -- Output, note down used variables
+    renderLlvm (vcat docs)
+    mapM_ markUsedVar $ concat ivars
+
+cmmLlvmGen _ = return ()
+
+-- -----------------------------------------------------------------------------
+-- | Generate meta data nodes
+--
+
+cmmMetaLlvmPrelude :: LlvmM ()
+cmmMetaLlvmPrelude = do
+  metas <- flip mapM stgTBAA $ \(uniq, name, parent) -> do
+    -- Generate / lookup meta data IDs
+    tbaaId <- getMetaUniqueId
+    setUniqMeta uniq tbaaId
+    parentId <- maybe (return Nothing) getUniqMeta parent
+    -- Build definition
+    return $ MetaUnamed tbaaId $ MetaStruct
+        [ MetaStr name
+        , case parentId of
+          Just p  -> MetaNode p
+          Nothing -> MetaVar $ LMLitVar $ LMNullLit i8Ptr
+        ]
+  renderLlvm $ ppLlvmMetas metas
+
+-- -----------------------------------------------------------------------------
+-- | Marks variables as used where necessary
+--
 
+cmmUsedLlvmGens :: LlvmM ()
+cmmUsedLlvmGens = do
+
+  -- LLVM would discard variables that are internal and not obviously
+  -- used if we didn't provide these hints. This will generate a
+  -- definition of the form
+  --
+  --   @llvm.used = appending global [42 x i8*] [i8* bitcast <var> to i8*, ...]
+  --
+  -- Which is the LLVM way of protecting them against getting removed.
+  ivars <- getUsedVars
+  let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
+      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 Constant
+      lmUsed    = LMGlobal lmUsedVar (Just usedArray)
+  if null ivars
+     then return ()
+     else renderLlvm $ pprLlvmData ([lmUsed], [])