Modules: Llvm (#13009)

6 files changed, 3241 insertions, 0 deletions

diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs
new file mode 100644
index 0000000000..c0bd742840
--- /dev/null
+++ b/compiler/GHC/CmmToLlvm/Base.hs
@@ -0,0 +1,685 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
+
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+
+-- ----------------------------------------------------------------------------
+-- | Base LLVM Code Generation module
+--
+-- Contains functions useful through out the code generator.
+--
+
+module GHC.CmmToLlvm.Base (
+
+        LlvmCmmDecl, LlvmBasicBlock,
+        LiveGlobalRegs,
+        LlvmUnresData, LlvmData, UnresLabel, UnresStatic,
+
+        LlvmVersion, supportedLlvmVersion, llvmVersionSupported, parseLlvmVersion,
+        llvmVersionStr, llvmVersionList,
+
+        LlvmM,
+        runLlvm, liftStream, withClearVars, varLookup, varInsert,
+        markStackReg, checkStackReg,
+        funLookup, funInsert, getLlvmVer, getDynFlags, getDynFlag, getLlvmPlatform,
+        dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars,
+        ghcInternalFunctions,
+
+        getMetaUniqueId,
+        setUniqMeta, getUniqMeta,
+
+        cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
+        llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
+        llvmPtrBits, tysToParams, llvmFunSection, padLiveArgs, isFPR,
+
+        strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm,
+        getGlobalPtr, generateExternDecls,
+
+        aliasify, llvmDefLabel
+    ) where
+
+#include "HsVersions.h"
+#include "ghcautoconf.h"
+
+import GhcPrelude
+
+import GHC.Llvm
+import GHC.CmmToLlvm.Regs
+
+import GHC.Cmm.CLabel
+import GHC.Platform.Regs ( activeStgRegs )
+import DynFlags
+import FastString
+import GHC.Cmm              hiding ( succ )
+import GHC.Cmm.Utils (regsOverlap)
+import Outputable as Outp
+import GHC.Platform
+import UniqFM
+import Unique
+import BufWrite   ( BufHandle )
+import UniqSet
+import UniqSupply
+import ErrUtils
+import qualified Stream
+
+import Data.Maybe (fromJust)
+import Control.Monad (ap)
+import Data.Char (isDigit)
+import Data.List (sort, groupBy, intercalate)
+import qualified Data.List.NonEmpty as NE
+
+-- ----------------------------------------------------------------------------
+-- * Some Data Types
+--
+
+type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe RawCmmStatics) (ListGraph LlvmStatement)
+type LlvmBasicBlock = GenBasicBlock LlvmStatement
+
+-- | Global registers live on proc entry
+type LiveGlobalRegs = [GlobalReg]
+
+-- | Unresolved code.
+-- Of the form: (data label, data type, unresolved data)
+type LlvmUnresData = (CLabel, Section, LlvmType, [UnresStatic])
+
+-- | Top level LLVM Data (globals and type aliases)
+type LlvmData = ([LMGlobal], [LlvmType])
+
+-- | An unresolved Label.
+--
+-- Labels are unresolved when we haven't yet determined if they are defined in
+-- the module we are currently compiling, or an external one.
+type UnresLabel  = CmmLit
+type UnresStatic = Either UnresLabel LlvmStatic
+
+-- ----------------------------------------------------------------------------
+-- * Type translations
+--
+
+-- | Translate a basic CmmType to an LlvmType.
+cmmToLlvmType :: CmmType -> LlvmType
+cmmToLlvmType ty | isVecType ty   = LMVector (vecLength ty) (cmmToLlvmType (vecElemType ty))
+                 | isFloatType ty = widthToLlvmFloat $ typeWidth ty
+                 | otherwise      = widthToLlvmInt   $ typeWidth ty
+
+-- | Translate a Cmm Float Width to a LlvmType.
+widthToLlvmFloat :: Width -> LlvmType
+widthToLlvmFloat W32  = LMFloat
+widthToLlvmFloat W64  = LMDouble
+widthToLlvmFloat W128 = LMFloat128
+widthToLlvmFloat w    = panic $ "widthToLlvmFloat: Bad float size: " ++ show w
+
+-- | Translate a Cmm Bit Width to a LlvmType.
+widthToLlvmInt :: Width -> LlvmType
+widthToLlvmInt w = LMInt $ widthInBits w
+
+-- | GHC Call Convention for LLVM
+llvmGhcCC :: DynFlags -> LlvmCallConvention
+llvmGhcCC dflags
+ | platformUnregisterised (targetPlatform dflags) = CC_Ccc
+ | otherwise                                      = CC_Ghc
+
+-- | Llvm Function type for Cmm function
+llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType
+llvmFunTy live = return . LMFunction =<< llvmFunSig' live (fsLit "a") ExternallyVisible
+
+-- | Llvm Function signature
+llvmFunSig :: LiveGlobalRegs ->  CLabel -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
+llvmFunSig live lbl link = do
+  lbl' <- strCLabel_llvm lbl
+  llvmFunSig' live lbl' link
+
+llvmFunSig' :: LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
+llvmFunSig' live lbl link
+  = do let toParams x | isPointer x = (x, [NoAlias, NoCapture])
+                      | otherwise   = (x, [])
+       dflags <- getDynFlags
+       return $ LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs
+                                 (map (toParams . getVarType) (llvmFunArgs dflags live))
+                                 (llvmFunAlign dflags)
+
+-- | Alignment to use for functions
+llvmFunAlign :: DynFlags -> LMAlign
+llvmFunAlign dflags = Just (wORD_SIZE dflags)
+
+-- | Alignment to use for into tables
+llvmInfAlign :: DynFlags -> LMAlign
+llvmInfAlign dflags = Just (wORD_SIZE dflags)
+
+-- | Section to use for a function
+llvmFunSection :: DynFlags -> LMString -> LMSection
+llvmFunSection dflags lbl
+    | gopt Opt_SplitSections dflags = Just (concatFS [fsLit ".text.", lbl])
+    | otherwise                     = Nothing
+
+-- | A Function's arguments
+llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar]
+llvmFunArgs dflags live =
+    map (lmGlobalRegArg dflags) (filter isPassed allRegs)
+    where platform = targetPlatform dflags
+          allRegs = activeStgRegs platform
+          paddedLive = map (\(_,r) -> r) $ padLiveArgs dflags live
+          isLive r = r `elem` alwaysLive || r `elem` paddedLive
+          isPassed r = not (isFPR r) || isLive r
+
+
+isFPR :: GlobalReg -> Bool
+isFPR (FloatReg _)  = True
+isFPR (DoubleReg _) = True
+isFPR (XmmReg _)    = True
+isFPR (YmmReg _)    = True
+isFPR (ZmmReg _)    = True
+isFPR _             = False
+
+sameFPRClass :: GlobalReg -> GlobalReg -> Bool
+sameFPRClass (FloatReg _)  (FloatReg _) = True
+sameFPRClass (DoubleReg _) (DoubleReg _) = True
+sameFPRClass (XmmReg _)    (XmmReg _) = True
+sameFPRClass (YmmReg _)    (YmmReg _) = True
+sameFPRClass (ZmmReg _)    (ZmmReg _) = True
+sameFPRClass _             _          = False
+
+normalizeFPRNum :: GlobalReg -> GlobalReg
+normalizeFPRNum (FloatReg _)  = FloatReg 1
+normalizeFPRNum (DoubleReg _) = DoubleReg 1
+normalizeFPRNum (XmmReg _)    = XmmReg 1
+normalizeFPRNum (YmmReg _)    = YmmReg 1
+normalizeFPRNum (ZmmReg _)    = ZmmReg 1
+normalizeFPRNum _ = error "normalizeFPRNum expected only FPR regs"
+
+getFPRCtor :: GlobalReg -> Int -> GlobalReg
+getFPRCtor (FloatReg _)  = FloatReg
+getFPRCtor (DoubleReg _) = DoubleReg
+getFPRCtor (XmmReg _)    = XmmReg
+getFPRCtor (YmmReg _)    = YmmReg
+getFPRCtor (ZmmReg _)    = ZmmReg
+getFPRCtor _ = error "getFPRCtor expected only FPR regs"
+
+fprRegNum :: GlobalReg -> Int
+fprRegNum (FloatReg i)  = i
+fprRegNum (DoubleReg i) = i
+fprRegNum (XmmReg i)    = i
+fprRegNum (YmmReg i)    = i
+fprRegNum (ZmmReg i)    = i
+fprRegNum _ = error "fprRegNum expected only FPR regs"
+
+-- | Input: dynflags, and the list of live registers
+--
+-- Output: An augmented list of live registers, where padding was
+-- added to the list of registers to ensure the calling convention is
+-- correctly used by LLVM.
+--
+-- Each global reg in the returned list is tagged with a bool, which
+-- indicates whether the global reg was added as padding, or was an original
+-- live register.
+--
+-- That is, True => padding, False => a real, live global register.
+--
+-- Also, the returned list is not sorted in any particular order.
+--
+padLiveArgs :: DynFlags -> LiveGlobalRegs -> [(Bool, GlobalReg)]
+padLiveArgs dflags live =
+      if platformUnregisterised plat
+        then taggedLive -- not using GHC's register convention for platform.
+        else padding ++ taggedLive
+  where
+    taggedLive = map (\x -> (False, x)) live
+    plat = targetPlatform dflags
+
+    fprLive = filter isFPR live
+    padding = concatMap calcPad $ groupBy sharesClass fprLive
+
+    sharesClass :: GlobalReg -> GlobalReg -> Bool
+    sharesClass a b = sameFPRClass a b || overlappingClass
+      where
+        overlappingClass = regsOverlap dflags (norm a) (norm b)
+        norm = CmmGlobal . normalizeFPRNum
+
+    calcPad :: [GlobalReg] -> [(Bool, GlobalReg)]
+    calcPad rs = getFPRPadding (getFPRCtor $ head rs) rs
+
+getFPRPadding :: (Int -> GlobalReg) -> LiveGlobalRegs -> [(Bool, GlobalReg)]
+getFPRPadding paddingCtor live = padding
+    where
+        fprRegNums = sort $ map fprRegNum live
+        (_, padding) = foldl assignSlots (1, []) $ fprRegNums
+
+        assignSlots (i, acc) regNum
+            | i == regNum = -- don't need padding here
+                  (i+1, acc)
+            | i < regNum = let -- add padding for slots i .. regNum-1
+                  numNeeded = regNum-i
+                  acc' = genPad i numNeeded ++ acc
+                in
+                  (regNum+1, acc')
+            | otherwise = error "padLiveArgs -- i > regNum ??"
+
+        genPad start n =
+            take n $ flip map (iterate (+1) start) (\i ->
+                (True, paddingCtor i))
+
+
+-- | Llvm standard fun attributes
+llvmStdFunAttrs :: [LlvmFuncAttr]
+llvmStdFunAttrs = [NoUnwind]
+
+-- | Convert a list of types to a list of function parameters
+-- (each with no parameter attributes)
+tysToParams :: [LlvmType] -> [LlvmParameter]
+tysToParams = map (\ty -> (ty, []))
+
+-- | Pointer width
+llvmPtrBits :: DynFlags -> Int
+llvmPtrBits dflags = widthInBits $ typeWidth $ gcWord dflags
+
+-- ----------------------------------------------------------------------------
+-- * Llvm Version
+--
+
+-- Newtype to avoid using the Eq instance!
+newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int }
+
+parseLlvmVersion :: String -> Maybe LlvmVersion
+parseLlvmVersion =
+    fmap LlvmVersion . NE.nonEmpty . go [] . dropWhile (not . isDigit)
+  where
+    go vs s
+      | null ver_str
+      = reverse vs
+      | '.' : rest' <- rest
+      = go (read ver_str : vs) rest'
+      | otherwise
+      = reverse (read ver_str : vs)
+      where
+        (ver_str, rest) = span isDigit s
+
+-- | The LLVM Version that is currently supported.
+supportedLlvmVersion :: LlvmVersion
+supportedLlvmVersion = LlvmVersion (sUPPORTED_LLVM_VERSION NE.:| [])
+
+llvmVersionSupported :: LlvmVersion -> Bool
+llvmVersionSupported (LlvmVersion v) = NE.head v == sUPPORTED_LLVM_VERSION
+
+llvmVersionStr :: LlvmVersion -> String
+llvmVersionStr = intercalate "." . map show . llvmVersionList
+
+llvmVersionList :: LlvmVersion -> [Int]
+llvmVersionList = NE.toList . llvmVersionNE
+
+-- ----------------------------------------------------------------------------
+-- * Environment Handling
+--
+
+data LlvmEnv = LlvmEnv
+  { envVersion :: LlvmVersion      -- ^ LLVM version
+  , envDynFlags :: DynFlags        -- ^ Dynamic flags
+  , envOutput :: BufHandle         -- ^ Output buffer
+  , envMask :: !Char               -- ^ Mask for creating unique values
+  , envFreshMeta :: MetaId         -- ^ Supply of fresh metadata IDs
+  , envUniqMeta :: UniqFM MetaId   -- ^ Global metadata nodes
+  , envFunMap :: LlvmEnvMap        -- ^ Global functions so far, with type
+  , envAliases :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References]
+  , envUsedVars :: [LlvmVar]       -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@)
+
+    -- the following get cleared for every function (see @withClearVars@)
+  , envVarMap :: LlvmEnvMap        -- ^ Local variables so far, with type
+  , envStackRegs :: [GlobalReg]    -- ^ Non-constant registers (alloca'd in the function prelude)
+  }
+
+type LlvmEnvMap = UniqFM LlvmType
+
+-- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad
+newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) }
+    deriving (Functor)
+
+instance Applicative LlvmM where
+    pure x = LlvmM $ \env -> return (x, env)
+    (<*>) = ap
+
+instance Monad LlvmM where
+    m >>= f  = LlvmM $ \env -> do (x, env') <- runLlvmM m env
+                                  runLlvmM (f x) env'
+
+instance HasDynFlags LlvmM where
+    getDynFlags = LlvmM $ \env -> return (envDynFlags env, env)
+
+instance MonadUnique LlvmM where
+    getUniqueSupplyM = do
+        mask <- getEnv envMask
+        liftIO $! mkSplitUniqSupply mask
+
+    getUniqueM = do
+        mask <- getEnv envMask
+        liftIO $! uniqFromMask mask
+
+-- | Lifting of IO actions. Not exported, as we want to encapsulate IO.
+liftIO :: IO a -> LlvmM a
+liftIO m = LlvmM $ \env -> do x <- m
+                              return (x, env)
+
+-- | Get initial Llvm environment.
+runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> LlvmM a -> IO a
+runLlvm dflags ver out m = do
+    (a, _) <- runLlvmM m env
+    return a
+  where env = LlvmEnv { envFunMap = emptyUFM
+                      , envVarMap = emptyUFM
+                      , envStackRegs = []
+                      , envUsedVars = []
+                      , envAliases = emptyUniqSet
+                      , envVersion = ver
+                      , envDynFlags = dflags
+                      , envOutput = out
+                      , envMask = 'n'
+                      , envFreshMeta = MetaId 0
+                      , envUniqMeta = emptyUFM
+                      }
+
+-- | Get environment (internal)
+getEnv :: (LlvmEnv -> a) -> LlvmM a
+getEnv f = LlvmM (\env -> return (f 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 for a subcomputation
+withClearVars :: LlvmM a -> LlvmM a
+withClearVars m = LlvmM $ \env -> do
+    (x, env') <- runLlvmM m env { envVarMap = emptyUFM, envStackRegs = [] }
+    return (x, env' { envVarMap = emptyUFM, envStackRegs = [] })
+
+-- | Insert variables or functions into the environment.
+varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmM ()
+varInsert s t = modifyEnv $ \env -> env { envVarMap = addToUFM (envVarMap env) s t }
+funInsert s t = modifyEnv $ \env -> env { envFunMap = addToUFM (envFunMap env) s t }
+
+-- | Lookup variables or functions in the environment.
+varLookup, funLookup :: Uniquable key => key -> LlvmM (Maybe LlvmType)
+varLookup s = getEnv (flip lookupUFM s . envVarMap)
+funLookup s = getEnv (flip lookupUFM s . envFunMap)
+
+-- | Set a register as allocated on the stack
+markStackReg :: GlobalReg -> LlvmM ()
+markStackReg r = modifyEnv $ \env -> env { envStackRegs = r : envStackRegs env }
+
+-- | Check whether a register is allocated on the stack
+checkStackReg :: GlobalReg -> LlvmM Bool
+checkStackReg r = getEnv ((elem r) . envStackRegs)
+
+-- | Allocate a new global unnamed metadata identifier
+getMetaUniqueId :: LlvmM MetaId
+getMetaUniqueId = LlvmM $ \env ->
+    return (envFreshMeta env, env { envFreshMeta = succ $ envFreshMeta env })
+
+-- | Get the LLVM version we are generating code for
+getLlvmVer :: LlvmM LlvmVersion
+getLlvmVer = getEnv envVersion
+
+-- | Get the platform we are generating code for
+getDynFlag :: (DynFlags -> a) -> LlvmM a
+getDynFlag f = getEnv (f . envDynFlags)
+
+-- | Get the platform we are generating code for
+getLlvmPlatform :: LlvmM Platform
+getLlvmPlatform = getDynFlag targetPlatform
+
+-- | Dumps the document if the corresponding flag has been set by the user
+dumpIfSetLlvm :: DumpFlag -> String -> DumpFormat -> Outp.SDoc -> LlvmM ()
+dumpIfSetLlvm flag hdr fmt doc = do
+  dflags <- getDynFlags
+  liftIO $ dumpIfSet_dyn dflags flag hdr fmt doc
+
+-- | Prints the given contents to the output handle
+renderLlvm :: Outp.SDoc -> LlvmM ()
+renderLlvm sdoc = do
+
+    -- Write to output
+    dflags <- getDynFlags
+    out <- getEnv envOutput
+    liftIO $ Outp.bufLeftRenderSDoc dflags out
+               (Outp.mkCodeStyle Outp.CStyle) sdoc
+
+    -- Dump, if requested
+    dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" FormatLLVM sdoc
+    return ()
+
+-- | Marks a variable as "used"
+markUsedVar :: LlvmVar -> LlvmM ()
+markUsedVar v = modifyEnv $ \env -> env { envUsedVars = v : envUsedVars env }
+
+-- | Return all variables marked as "used" so far
+getUsedVars :: LlvmM [LlvmVar]
+getUsedVars = getEnv envUsedVars
+
+-- | Saves that at some point we didn't know the type of the label and
+-- generated a reference to a type variable instead
+saveAlias :: LMString -> LlvmM ()
+saveAlias lbl = modifyEnv $ \env -> env { envAliases = addOneToUniqSet (envAliases env) lbl }
+
+-- | Sets metadata node for a given unique
+setUniqMeta :: Unique -> MetaId -> LlvmM ()
+setUniqMeta f m = modifyEnv $ \env -> env { envUniqMeta = addToUFM (envUniqMeta env) f m }
+
+-- | Gets metadata node for given unique
+getUniqMeta :: Unique -> LlvmM (Maybe MetaId)
+getUniqMeta s = getEnv (flip lookupUFM s . envUniqMeta)
+
+-- ----------------------------------------------------------------------------
+-- * Internal functions
+--
+
+-- | Here we pre-initialise some functions that are used internally by GHC
+-- so as to make sure they have the most general type in the case that
+-- user code also uses these functions but with a different type than GHC
+-- internally. (Main offender is treating return type as 'void' instead of
+-- 'void *'). Fixes trac #5486.
+ghcInternalFunctions :: LlvmM ()
+ghcInternalFunctions = do
+    dflags <- getDynFlags
+    mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]
+    mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]
+    mk "memset" i8Ptr [i8Ptr, llvmWord dflags, llvmWord dflags]
+    mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr]
+  where
+    mk n ret args = do
+      let n' = llvmDefLabel $ fsLit n
+          decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret
+                                 FixedArgs (tysToParams args) Nothing
+      renderLlvm $ ppLlvmFunctionDecl decl
+      funInsert n' (LMFunction decl)
+
+-- ----------------------------------------------------------------------------
+-- * Label handling
+--
+
+-- | Pretty print a 'CLabel'.
+strCLabel_llvm :: CLabel -> LlvmM LMString
+strCLabel_llvm lbl = do
+    dflags <- getDynFlags
+    let sdoc = pprCLabel dflags lbl
+        str = Outp.renderWithStyle dflags sdoc (Outp.mkCodeStyle Outp.CStyle)
+    return (fsLit str)
+
+strDisplayName_llvm :: CLabel -> LlvmM LMString
+strDisplayName_llvm lbl = do
+    dflags <- getDynFlags
+    let sdoc = pprCLabel dflags lbl
+        depth = Outp.PartWay 1
+        style = Outp.mkUserStyle dflags Outp.reallyAlwaysQualify depth
+        str = Outp.renderWithStyle dflags sdoc style
+    return (fsLit (dropInfoSuffix str))
+
+dropInfoSuffix :: String -> String
+dropInfoSuffix = go
+  where go "_info"        = []
+        go "_static_info" = []
+        go "_con_info"    = []
+        go (x:xs)         = x:go xs
+        go []             = []
+
+strProcedureName_llvm :: CLabel -> LlvmM LMString
+strProcedureName_llvm lbl = do
+    dflags <- getDynFlags
+    let sdoc = pprCLabel dflags lbl
+        depth = Outp.PartWay 1
+        style = Outp.mkUserStyle dflags Outp.neverQualify depth
+        str = Outp.renderWithStyle dflags sdoc style
+    return (fsLit str)
+
+-- ----------------------------------------------------------------------------
+-- * Global variables / forward references
+--
+
+-- | Create/get a pointer to a global value. Might return an alias if
+-- the value in question hasn't been defined yet. We especially make
+-- no guarantees on the type of the returned pointer.
+getGlobalPtr :: LMString -> LlvmM LlvmVar
+getGlobalPtr llvmLbl = do
+  m_ty <- funLookup llvmLbl
+  let mkGlbVar lbl ty = LMGlobalVar lbl (LMPointer ty) Private Nothing Nothing
+  case m_ty of
+    -- Directly reference if we have seen it already
+    Just ty -> return $ mkGlbVar (llvmDefLabel llvmLbl) ty Global
+    -- Otherwise use a forward alias of it
+    Nothing -> do
+      saveAlias llvmLbl
+      return $ mkGlbVar llvmLbl i8 Alias
+
+-- | Derive the definition label. It has an identified
+-- structure type.
+llvmDefLabel :: LMString -> LMString
+llvmDefLabel = (`appendFS` fsLit "$def")
+
+-- | Generate definitions for aliases forward-referenced by @getGlobalPtr@.
+--
+-- Must be called at a point where we are sure that no new global definitions
+-- will be generated anymore!
+generateExternDecls :: LlvmM ([LMGlobal], [LlvmType])
+generateExternDecls = do
+  delayed <- fmap nonDetEltsUniqSet $ getEnv envAliases
+  -- This is non-deterministic but we do not
+  -- currently support deterministic code-generation.
+  -- See Note [Unique Determinism and code generation]
+  defss <- flip mapM delayed $ \lbl -> do
+    m_ty <- funLookup lbl
+    case m_ty of
+      -- If we have a definition we've already emitted the proper aliases
+      -- when the symbol itself was emitted by @aliasify@
+      Just _ -> return []
+
+      -- If we don't have a definition this is an external symbol and we
+      -- need to emit a declaration
+      Nothing ->
+        let var = LMGlobalVar lbl i8Ptr External Nothing Nothing Global
+        in return [LMGlobal var Nothing]
+
+  -- Reset forward list
+  modifyEnv $ \env -> env { envAliases = emptyUniqSet }
+  return (concat defss, [])
+
+-- | Here we take a global variable definition, rename it with a
+-- @$def@ suffix, and generate the appropriate alias.
+aliasify :: LMGlobal -> LlvmM [LMGlobal]
+-- See note [emit-time elimination of static indirections] in CLabel.
+-- Here we obtain the indirectee's precise type and introduce
+-- fresh aliases to both the precise typed label (lbl$def) and the i8*
+-- typed (regular) label of it with the matching new names.
+aliasify (LMGlobal (LMGlobalVar lbl ty@LMAlias{} link sect align Alias)
+                   (Just orig)) = do
+    let defLbl = llvmDefLabel lbl
+        LMStaticPointer (LMGlobalVar origLbl _ oLnk Nothing Nothing Alias) = orig
+        defOrigLbl = llvmDefLabel origLbl
+        orig' = LMStaticPointer (LMGlobalVar origLbl i8Ptr oLnk Nothing Nothing Alias)
+    origType <- funLookup origLbl
+    let defOrig = LMBitc (LMStaticPointer (LMGlobalVar defOrigLbl
+                                           (pLift $ fromJust origType) oLnk
+                                           Nothing Nothing Alias))
+                         (pLift ty)
+    pure [ LMGlobal (LMGlobalVar defLbl ty link sect align Alias) (Just defOrig)
+         , LMGlobal (LMGlobalVar lbl i8Ptr link sect align Alias) (Just orig')
+         ]
+aliasify (LMGlobal var val) = do
+    let LMGlobalVar lbl ty link sect align const = var
+
+        defLbl = llvmDefLabel lbl
+        defVar = LMGlobalVar defLbl ty Internal sect align const
+
+        defPtrVar = LMGlobalVar defLbl (LMPointer ty) link Nothing Nothing const
+        aliasVar = LMGlobalVar lbl i8Ptr link Nothing Nothing Alias
+        aliasVal = LMBitc (LMStaticPointer defPtrVar) i8Ptr
+
+    -- we need to mark the $def symbols as used so LLVM doesn't forget which
+    -- section they need to go in. This will vanish once we switch away from
+    -- mangling sections for TNTC.
+    markUsedVar defVar
+
+    return [ LMGlobal defVar val
+           , LMGlobal aliasVar (Just aliasVal)
+           ]
+
+-- Note [Llvm Forward References]
+--
+-- The issue here is that LLVM insists on being strongly typed at
+-- every corner, so the first time we mention something, we have to
+-- settle what type we assign to it. That makes things awkward, as Cmm
+-- will often reference things before their definition, and we have no
+-- idea what (LLVM) type it is going to be before that point.
+--
+-- Our work-around is to define "aliases" of a standard type (i8 *) in
+-- these kind of situations, which we later tell LLVM to be either
+-- references to their actual local definitions (involving a cast) or
+-- an external reference. This obviously only works for pointers.
+--
+-- In particular when we encounter a reference to a symbol in a chunk of
+-- C-- there are three possible scenarios,
+--
+--   1. We have already seen a definition for the referenced symbol. This
+--      means we already know its type.
+--
+--   2. We have not yet seen a definition but we will find one later in this
+--      compilation unit. Since we want to be a good consumer of the
+--      C-- streamed to us from upstream, we don't know the type of the
+--      symbol at the time when we must emit the reference.
+--
+--   3. We have not yet seen a definition nor will we find one in this
+--      compilation unit. In this case the reference refers to an
+--      external symbol for which we do not know the type.
+--
+-- Let's consider case (2) for a moment: say we see a reference to
+-- the symbol @fooBar@ for which we have not seen a definition. As we
+-- do not know the symbol's type, we assume it is of type @i8*@ and emit
+-- the appropriate casts in @getSymbolPtr@. Later on, when we
+-- encounter the definition of @fooBar@ we emit it but with a modified
+-- name, @fooBar$def@ (which we'll call the definition symbol), to
+-- since we have already had to assume that the symbol @fooBar@
+-- is of type @i8*@. We then emit @fooBar@ itself as an alias
+-- of @fooBar$def@ with appropriate casts. This all happens in
+-- @aliasify@.
+--
+-- Case (3) is quite similar to (2): References are emitted assuming
+-- the referenced symbol is of type @i8*@. When we arrive at the end of
+-- the compilation unit and realize that the symbol is external, we emit
+-- an LLVM @external global@ declaration for the symbol @fooBar@
+-- (handled in @generateExternDecls@). This takes advantage of the
+-- fact that the aliases produced by @aliasify@ for exported symbols
+-- have external linkage and can therefore be used as normal symbols.
+--
+-- Historical note: As of release 3.5 LLVM does not allow aliases to
+-- refer to declarations. This the reason why aliases are produced at the
+-- point of definition instead of the point of usage, as was previously
+-- done. See #9142 for details.
+--
+-- Finally, case (1) is trivial. As we already have a definition for
+-- and therefore know the type of the referenced symbol, we can do
+-- away with casting the alias to the desired type in @getSymbolPtr@
+-- and instead just emit a reference to the definition symbol directly.
+-- This is the @Just@ case in @getSymbolPtr@.
diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs
new file mode 100644
index 0000000000..33dd82c418
--- /dev/null
+++ b/compiler/GHC/CmmToLlvm/CodeGen.hs
@@ -0,0 +1,1995 @@
+{-# LANGUAGE CPP, GADTs #-}
+{-# OPTIONS_GHC -fno-warn-type-defaults #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+-- ----------------------------------------------------------------------------
+-- | Handle conversion of CmmProc to LLVM code.
+--
+module GHC.CmmToLlvm.CodeGen ( genLlvmProc ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import GHC.Llvm
+import GHC.CmmToLlvm.Base
+import GHC.CmmToLlvm.Regs
+
+import GHC.Cmm.BlockId
+import GHC.Platform.Regs ( activeStgRegs )
+import GHC.Cmm.CLabel
+import GHC.Cmm
+import GHC.Cmm.Ppr as PprCmm
+import GHC.Cmm.Utils
+import GHC.Cmm.Switch
+import GHC.Cmm.Dataflow.Block
+import GHC.Cmm.Dataflow.Graph
+import GHC.Cmm.Dataflow.Collections
+
+import DynFlags
+import FastString
+import ForeignCall
+import Outputable hiding (panic, pprPanic)
+import qualified Outputable
+import GHC.Platform
+import OrdList
+import UniqSupply
+import Unique
+import Util
+
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Writer
+
+import qualified Data.Semigroup as Semigroup
+import Data.List ( nub )
+import Data.Maybe ( catMaybes )
+
+type Atomic = Bool
+type LlvmStatements = OrdList LlvmStatement
+
+data Signage = Signed | Unsigned deriving (Eq, Show)
+
+-- -----------------------------------------------------------------------------
+-- | Top-level of the LLVM proc Code generator
+--
+genLlvmProc :: RawCmmDecl -> LlvmM [LlvmCmmDecl]
+genLlvmProc (CmmProc infos lbl live graph) = do
+    let blocks = toBlockListEntryFirstFalseFallthrough graph
+    (lmblocks, lmdata) <- basicBlocksCodeGen live blocks
+    let info = mapLookup (g_entry graph) infos
+        proc = CmmProc info lbl live (ListGraph lmblocks)
+    return (proc:lmdata)
+
+genLlvmProc _ = panic "genLlvmProc: case that shouldn't reach here!"
+
+-- -----------------------------------------------------------------------------
+-- * Block code generation
+--
+
+-- | Generate code for a list of blocks that make up a complete
+-- procedure. The first block in the list is expected to be the entry
+-- point.
+basicBlocksCodeGen :: LiveGlobalRegs -> [CmmBlock]
+                      -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl])
+basicBlocksCodeGen _    []                     = panic "no entry block!"
+basicBlocksCodeGen live cmmBlocks
+  = do -- Emit the prologue
+       -- N.B. this must be its own block to ensure that the entry block of the
+       -- procedure has no predecessors, as required by the LLVM IR. See #17589
+       -- and #11649.
+       bid <- newBlockId
+       (prologue, prologueTops) <- funPrologue live cmmBlocks
+       let entryBlock = BasicBlock bid (fromOL prologue)
+
+       -- Generate code
+       (blocks, topss) <- fmap unzip $ mapM basicBlockCodeGen cmmBlocks
+
+       -- Compose
+       return (entryBlock : blocks, prologueTops ++ concat topss)
+
+
+-- | Generate code for one block
+basicBlockCodeGen :: CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] )
+basicBlockCodeGen block
+  = do let (_, nodes, tail)  = blockSplit block
+           id = entryLabel block
+       (mid_instrs, top) <- stmtsToInstrs $ blockToList nodes
+       (tail_instrs, top')  <- stmtToInstrs tail
+       let instrs = fromOL (mid_instrs `appOL` tail_instrs)
+       return (BasicBlock id instrs, top' ++ top)
+
+-- -----------------------------------------------------------------------------
+-- * CmmNode code generation
+--
+
+-- A statement conversion return data.
+--   * LlvmStatements: The compiled LLVM statements.
+--   * LlvmCmmDecl: Any global data needed.
+type StmtData = (LlvmStatements, [LlvmCmmDecl])
+
+
+-- | Convert a list of CmmNode's to LlvmStatement's
+stmtsToInstrs :: [CmmNode e x] -> LlvmM StmtData
+stmtsToInstrs stmts
+   = do (instrss, topss) <- fmap unzip $ mapM stmtToInstrs stmts
+        return (concatOL instrss, concat topss)
+
+
+-- | Convert a CmmStmt to a list of LlvmStatement's
+stmtToInstrs :: CmmNode e x -> LlvmM StmtData
+stmtToInstrs stmt = case stmt of
+
+    CmmComment _         -> return (nilOL, []) -- nuke comments
+    CmmTick    _         -> return (nilOL, [])
+    CmmUnwind  {}        -> return (nilOL, [])
+
+    CmmAssign reg src    -> genAssign reg src
+    CmmStore addr src    -> genStore addr src
+
+    CmmBranch id         -> genBranch id
+    CmmCondBranch arg true false likely
+                         -> genCondBranch arg true false likely
+    CmmSwitch arg ids    -> genSwitch arg ids
+
+    -- Foreign Call
+    CmmUnsafeForeignCall target res args
+        -> genCall target res args
+
+    -- Tail call
+    CmmCall { cml_target = arg,
+              cml_args_regs = live } -> genJump arg live
+
+    _ -> panic "Llvm.CodeGen.stmtToInstrs"
+
+-- | Wrapper function to declare an instrinct function by function type
+getInstrinct2 :: LMString -> LlvmType -> LlvmM ExprData
+getInstrinct2 fname fty@(LMFunction funSig) = do
+
+    let fv   = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing Constant
+
+    fn <- funLookup fname
+    tops <- case fn of
+      Just _  ->
+        return []
+      Nothing -> do
+        funInsert fname fty
+        un <- getUniqueM
+        let lbl = mkAsmTempLabel un
+        return [CmmData (Section Data lbl) [([],[fty])]]
+
+    return (fv, nilOL, tops)
+
+getInstrinct2 _ _ = error "getInstrinct2: Non-function type!"
+
+-- | Declares an instrinct function by return and parameter types
+getInstrinct :: LMString -> LlvmType -> [LlvmType] -> LlvmM ExprData
+getInstrinct fname retTy parTys =
+    let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc retTy
+                    FixedArgs (tysToParams parTys) Nothing
+        fty = LMFunction funSig
+    in getInstrinct2 fname fty
+
+-- | Memory barrier instruction for LLVM >= 3.0
+barrier :: LlvmM StmtData
+barrier = do
+    let s = Fence False SyncSeqCst
+    return (unitOL s, [])
+
+-- | Insert a 'barrier', unless the target platform is in the provided list of
+--   exceptions (where no code will be emitted instead).
+barrierUnless :: [Arch] -> LlvmM StmtData
+barrierUnless exs = do
+    platform <- getLlvmPlatform
+    if platformArch platform `elem` exs
+        then return (nilOL, [])
+        else barrier
+
+-- | Foreign Calls
+genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual]
+              -> LlvmM StmtData
+
+-- Barriers need to be handled specially as they are implemented as LLVM
+-- intrinsic functions.
+genCall (PrimTarget MO_ReadBarrier) _ _ =
+    barrierUnless [ArchX86, ArchX86_64, ArchSPARC]
+genCall (PrimTarget MO_WriteBarrier) _ _ = do
+    barrierUnless [ArchX86, ArchX86_64, ArchSPARC]
+
+genCall (PrimTarget MO_Touch) _ _
+ = return (nilOL, [])
+
+genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = runStmtsDecls $ do
+    dstV <- getCmmRegW (CmmLocal dst)
+    let ty = cmmToLlvmType $ localRegType dst
+        width = widthToLlvmFloat w
+    castV <- lift $ mkLocalVar ty
+    ve <- exprToVarW e
+    statement $ Assignment castV $ Cast LM_Uitofp ve width
+    statement $ Store castV dstV
+
+genCall (PrimTarget (MO_UF_Conv _)) [_] args =
+    panic $ "genCall: Too many arguments to MO_UF_Conv. " ++
+    "Can only handle 1, given" ++ show (length args) ++ "."
+
+-- Handle prefetching data
+genCall t@(PrimTarget (MO_Prefetch_Data localityInt)) [] args
+  | 0 <= localityInt && localityInt <= 3 = runStmtsDecls $ do
+    let argTy = [i8Ptr, i32, i32, i32]
+        funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
+                             CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing
+
+    let (_, arg_hints) = foreignTargetHints t
+    let args_hints' = zip args arg_hints
+    argVars <- arg_varsW args_hints' ([], nilOL, [])
+    fptr    <- liftExprData $ getFunPtr funTy t
+    argVars' <- castVarsW Signed $ zip argVars argTy
+
+    let argSuffix = [mkIntLit i32 0, mkIntLit i32 localityInt, mkIntLit i32 1]
+    statement $ Expr $ Call StdCall fptr (argVars' ++ argSuffix) []
+  | otherwise = panic $ "prefetch locality level integer must be between 0 and 3, given: " ++ (show localityInt)
+
+-- Handle PopCnt, Clz, Ctz, and BSwap that need to only convert arg
+-- and return types
+genCall t@(PrimTarget (MO_PopCnt w)) dsts args =
+    genCallSimpleCast w t dsts args
+
+genCall t@(PrimTarget (MO_Pdep w)) dsts args =
+    genCallSimpleCast2 w t dsts args
+genCall t@(PrimTarget (MO_Pext w)) dsts args =
+    genCallSimpleCast2 w t dsts args
+genCall t@(PrimTarget (MO_Clz w)) dsts args =
+    genCallSimpleCast w t dsts args
+genCall t@(PrimTarget (MO_Ctz w)) dsts args =
+    genCallSimpleCast w t dsts args
+genCall t@(PrimTarget (MO_BSwap w)) dsts args =
+    genCallSimpleCast w t dsts args
+genCall t@(PrimTarget (MO_BRev w)) dsts args =
+    genCallSimpleCast w t dsts args
+
+genCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = runStmtsDecls $ do
+    addrVar <- exprToVarW addr
+    nVar <- exprToVarW n
+    let targetTy = widthToLlvmInt width
+        ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy)
+    ptrVar <- doExprW (pLift targetTy) ptrExpr
+    dstVar <- getCmmRegW (CmmLocal dst)
+    let op = case amop of
+               AMO_Add  -> LAO_Add
+               AMO_Sub  -> LAO_Sub
+               AMO_And  -> LAO_And
+               AMO_Nand -> LAO_Nand
+               AMO_Or   -> LAO_Or
+               AMO_Xor  -> LAO_Xor
+    retVar <- doExprW targetTy $ AtomicRMW op ptrVar nVar SyncSeqCst
+    statement $ Store retVar dstVar
+
+genCall (PrimTarget (MO_AtomicRead _)) [dst] [addr] = runStmtsDecls $ do
+    dstV <- getCmmRegW (CmmLocal dst)
+    v1 <- genLoadW True addr (localRegType dst)
+    statement $ Store v1 dstV
+
+genCall (PrimTarget (MO_Cmpxchg _width))
+        [dst] [addr, old, new] = runStmtsDecls $ do
+    addrVar <- exprToVarW addr
+    oldVar <- exprToVarW old
+    newVar <- exprToVarW new
+    let targetTy = getVarType oldVar
+        ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy)
+    ptrVar <- doExprW (pLift targetTy) ptrExpr
+    dstVar <- getCmmRegW (CmmLocal dst)
+    retVar <- doExprW (LMStructU [targetTy,i1])
+              $ CmpXChg ptrVar oldVar newVar SyncSeqCst SyncSeqCst
+    retVar' <- doExprW targetTy $ ExtractV retVar 0
+    statement $ Store retVar' dstVar
+
+genCall (PrimTarget (MO_AtomicWrite _width)) [] [addr, val] = runStmtsDecls $ do
+    addrVar <- exprToVarW addr
+    valVar <- exprToVarW val
+    let ptrTy = pLift $ getVarType valVar
+        ptrExpr = Cast LM_Inttoptr addrVar ptrTy
+    ptrVar <- doExprW ptrTy ptrExpr
+    statement $ Expr $ AtomicRMW LAO_Xchg ptrVar valVar SyncSeqCst
+
+-- Handle memcpy function specifically since llvm's intrinsic version takes
+-- some extra parameters.
+genCall t@(PrimTarget op) [] args
+ | Just align <- machOpMemcpyishAlign op = runStmtsDecls $ do
+    dflags <- getDynFlags
+    let isVolTy = [i1]
+        isVolVal = [mkIntLit i1 0]
+        argTy | MO_Memset _ <- op = [i8Ptr, i8,    llvmWord dflags, i32] ++ isVolTy
+              | otherwise         = [i8Ptr, i8Ptr, llvmWord dflags, i32] ++ isVolTy
+        funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
+                             CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing
+
+    let (_, arg_hints) = foreignTargetHints t
+    let args_hints = zip args arg_hints
+    argVars       <- arg_varsW args_hints ([], nilOL, [])
+    fptr          <- getFunPtrW funTy t
+    argVars' <- castVarsW Signed $ zip argVars argTy
+
+    let alignVal = mkIntLit i32 align
+        arguments = argVars' ++ (alignVal:isVolVal)
+    statement $ Expr $ Call StdCall fptr arguments []
+
+-- We handle MO_U_Mul2 by simply using a 'mul' instruction, but with operands
+-- twice the width (we first zero-extend them), e.g., on 64-bit arch we will
+-- generate 'mul' on 128-bit operands. Then we only need some plumbing to
+-- extract the two 64-bit values out of 128-bit result.
+genCall (PrimTarget (MO_U_Mul2 w)) [dstH, dstL] [lhs, rhs] = runStmtsDecls $ do
+    let width = widthToLlvmInt w
+        bitWidth = widthInBits w
+        width2x = LMInt (bitWidth * 2)
+    -- First zero-extend the operands ('mul' instruction requires the operands
+    -- and the result to be of the same type). Note that we don't use 'castVars'
+    -- because it tries to do LM_Sext.
+    lhsVar <- exprToVarW lhs
+    rhsVar <- exprToVarW rhs
+    lhsExt <- doExprW width2x $ Cast LM_Zext lhsVar width2x
+    rhsExt <- doExprW width2x $ Cast LM_Zext rhsVar width2x
+    -- Do the actual multiplication (note that the result is also 2x width).
+    retV <- doExprW width2x $ LlvmOp LM_MO_Mul lhsExt rhsExt
+    -- Extract the lower bits of the result into retL.
+    retL <- doExprW width $ Cast LM_Trunc retV width
+    -- Now we right-shift the higher bits by width.
+    let widthLlvmLit = LMLitVar $ LMIntLit (fromIntegral bitWidth) width
+    retShifted <- doExprW width2x $ LlvmOp LM_MO_LShr retV widthLlvmLit
+    -- And extract them into retH.
+    retH <- doExprW width $ Cast LM_Trunc retShifted width
+    dstRegL <- getCmmRegW (CmmLocal dstL)
+    dstRegH <- getCmmRegW (CmmLocal dstH)
+    statement $ Store retL dstRegL
+    statement $ Store retH dstRegH
+
+-- MO_U_QuotRem2 is another case we handle by widening the registers to double
+-- the width and use normal LLVM instructions (similarly to the MO_U_Mul2). The
+-- main difference here is that we need to combine two words into one register
+-- and then use both 'udiv' and 'urem' instructions to compute the result.
+genCall (PrimTarget (MO_U_QuotRem2 w))
+        [dstQ, dstR] [lhsH, lhsL, rhs] = runStmtsDecls $ do
+    let width = widthToLlvmInt w
+        bitWidth = widthInBits w
+        width2x = LMInt (bitWidth * 2)
+    -- First zero-extend all parameters to double width.
+    let zeroExtend expr = do
+            var <- exprToVarW expr
+            doExprW width2x $ Cast LM_Zext var width2x
+    lhsExtH <- zeroExtend lhsH
+    lhsExtL <- zeroExtend lhsL
+    rhsExt <- zeroExtend rhs
+    -- Now we combine the first two parameters (that represent the high and low
+    -- bits of the value). So first left-shift the high bits to their position
+    -- and then bit-or them with the low bits.
+    let widthLlvmLit = LMLitVar $ LMIntLit (fromIntegral bitWidth) width
+    lhsExtHShifted <- doExprW width2x $ LlvmOp LM_MO_Shl lhsExtH widthLlvmLit
+    lhsExt <- doExprW width2x $ LlvmOp LM_MO_Or lhsExtHShifted lhsExtL
+    -- Finally, we can call 'udiv' and 'urem' to compute the results.
+    retExtDiv <- doExprW width2x $ LlvmOp LM_MO_UDiv lhsExt rhsExt
+    retExtRem <- doExprW width2x $ LlvmOp LM_MO_URem lhsExt rhsExt
+    -- And since everything is in 2x width, we need to truncate the results and
+    -- then return them.
+    let narrow var = doExprW width $ Cast LM_Trunc var width
+    retDiv <- narrow retExtDiv
+    retRem <- narrow retExtRem
+    dstRegQ <- lift $ getCmmReg (CmmLocal dstQ)
+    dstRegR <- lift $ getCmmReg (CmmLocal dstR)
+    statement $ Store retDiv dstRegQ
+    statement $ Store retRem dstRegR
+
+-- Handle the MO_{Add,Sub}IntC separately. LLVM versions return a record from
+-- which we need to extract the actual values.
+genCall t@(PrimTarget (MO_AddIntC w)) [dstV, dstO] [lhs, rhs] =
+    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
+genCall t@(PrimTarget (MO_SubIntC w)) [dstV, dstO] [lhs, rhs] =
+    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
+
+-- Similar to MO_{Add,Sub}IntC, but MO_Add2 expects the first element of the
+-- return tuple to be the overflow bit and the second element to contain the
+-- actual result of the addition. So we still use genCallWithOverflow but swap
+-- the return registers.
+genCall t@(PrimTarget (MO_Add2 w)) [dstO, dstV] [lhs, rhs] =
+    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
+
+genCall t@(PrimTarget (MO_AddWordC w)) [dstV, dstO] [lhs, rhs] =
+    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
+
+genCall t@(PrimTarget (MO_SubWordC w)) [dstV, dstO] [lhs, rhs] =
+    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
+
+-- Handle all other foreign calls and prim ops.
+genCall target res args = runStmtsDecls $ do
+    dflags <- getDynFlags
+
+    -- parameter types
+    let arg_type (_, AddrHint) = i8Ptr
+        -- cast pointers to i8*. Llvm equivalent of void*
+        arg_type (expr, _) = cmmToLlvmType $ cmmExprType dflags expr
+
+    -- ret type
+    let ret_type [] = LMVoid
+        ret_type [(_, AddrHint)] = i8Ptr
+        ret_type [(reg, _)]      = cmmToLlvmType $ localRegType reg
+        ret_type t = panic $ "genCall: Too many return values! Can only handle"
+                        ++ " 0 or 1, given " ++ show (length t) ++ "."
+
+    -- extract Cmm call convention, and translate to LLVM call convention
+    platform <- lift $ getLlvmPlatform
+    let lmconv = case target of
+            ForeignTarget _ (ForeignConvention conv _ _ _) ->
+              case conv of
+                 StdCallConv  -> case platformArch platform of
+                                 ArchX86    -> CC_X86_Stdcc
+                                 ArchX86_64 -> CC_X86_Stdcc
+                                 _          -> CC_Ccc
+                 CCallConv    -> CC_Ccc
+                 CApiConv     -> CC_Ccc
+                 PrimCallConv       -> panic "GHC.CmmToLlvm.CodeGen.genCall: PrimCallConv"
+                 JavaScriptCallConv -> panic "GHC.CmmToLlvm.CodeGen.genCall: JavaScriptCallConv"
+
+            PrimTarget   _ -> CC_Ccc
+
+    {-
+        CC_Ccc of the possibilities here are a worry with the use of a custom
+        calling convention for passing STG args. In practice the more
+        dangerous combinations (e.g StdCall + llvmGhcCC) don't occur.
+
+        The native code generator only handles StdCall and CCallConv.
+    -}
+
+    -- call attributes
+    let fnAttrs | never_returns = NoReturn : llvmStdFunAttrs
+                | otherwise     = llvmStdFunAttrs
+
+        never_returns = case target of
+             ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns) -> True
+             _ -> False
+
+    -- fun type
+    let (res_hints, arg_hints) = foreignTargetHints target
+    let args_hints = zip args arg_hints
+    let ress_hints = zip res  res_hints
+    let ccTy  = StdCall -- tail calls should be done through CmmJump
+    let retTy = ret_type ress_hints
+    let argTy = tysToParams $ map arg_type args_hints
+    let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
+                             lmconv retTy FixedArgs argTy (llvmFunAlign dflags)
+
+
+    argVars <- arg_varsW args_hints ([], nilOL, [])
+    fptr    <- getFunPtrW funTy target
+
+    let doReturn | ccTy == TailCall  = statement $ Return Nothing
+                 | never_returns     = statement $ Unreachable
+                 | otherwise         = return ()
+
+
+    -- make the actual call
+    case retTy of
+        LMVoid -> do
+            statement $ Expr $ Call ccTy fptr argVars fnAttrs
+
+        _ -> do
+            v1 <- doExprW retTy $ Call ccTy fptr argVars fnAttrs
+            -- get the return register
+            let ret_reg [reg] = reg
+                ret_reg t = panic $ "genCall: Bad number of registers! Can only handle"
+                                ++ " 1, given " ++ show (length t) ++ "."
+            let creg = ret_reg res
+            vreg <- getCmmRegW (CmmLocal creg)
+            if retTy == pLower (getVarType vreg)
+                then do
+                    statement $ Store v1 vreg
+                    doReturn
+                else do
+                    let ty = pLower $ getVarType vreg
+                    let op = case ty of
+                            vt | isPointer vt -> LM_Bitcast
+                               | isInt     vt -> LM_Ptrtoint
+                               | otherwise    ->
+                                   panic $ "genCall: CmmReg bad match for"
+                                        ++ " returned type!"
+
+                    v2 <- doExprW ty $ Cast op v1 ty
+                    statement $ Store v2 vreg
+                    doReturn
+
+-- | Generate a call to an LLVM intrinsic that performs arithmetic operation
+-- with overflow bit (i.e., returns a struct containing the actual result of the
+-- operation and an overflow bit). This function will also extract the overflow
+-- bit and zero-extend it (all the corresponding Cmm PrimOps represent the
+-- overflow "bit" as a usual Int# or Word#).
+genCallWithOverflow
+  :: ForeignTarget -> Width -> [CmmFormal] -> [CmmActual] -> LlvmM StmtData
+genCallWithOverflow t@(PrimTarget op) w [dstV, dstO] [lhs, rhs] = do
+    -- So far this was only tested for the following four CallishMachOps.
+    let valid = op `elem`   [ MO_Add2 w
+                            , MO_AddIntC w
+                            , MO_SubIntC w
+                            , MO_AddWordC w
+                            , MO_SubWordC w
+                            ]
+    MASSERT(valid)
+    let width = widthToLlvmInt w
+    -- This will do most of the work of generating the call to the intrinsic and
+    -- extracting the values from the struct.
+    (value, overflowBit, (stmts, top)) <-
+      genCallExtract t w (lhs, rhs) (width, i1)
+    -- value is i<width>, but overflowBit is i1, so we need to cast (Cmm expects
+    -- both to be i<width>)
+    (overflow, zext) <- doExpr width $ Cast LM_Zext overflowBit width
+    dstRegV <- getCmmReg (CmmLocal dstV)
+    dstRegO <- getCmmReg (CmmLocal dstO)
+    let storeV = Store value dstRegV
+        storeO = Store overflow dstRegO
+    return (stmts `snocOL` zext `snocOL` storeV `snocOL` storeO, top)
+genCallWithOverflow _ _ _ _ =
+    panic "genCallExtract: wrong ForeignTarget or number of arguments"
+
+-- | A helper function for genCallWithOverflow that handles generating the call
+-- to the LLVM intrinsic and extracting the result from the struct to LlvmVars.
+genCallExtract
+    :: ForeignTarget           -- ^ PrimOp
+    -> Width                   -- ^ Width of the operands.
+    -> (CmmActual, CmmActual)  -- ^ Actual arguments.
+    -> (LlvmType, LlvmType)    -- ^ LLVM types of the returned struct.
+    -> LlvmM (LlvmVar, LlvmVar, StmtData)
+genCallExtract target@(PrimTarget op) w (argA, argB) (llvmTypeA, llvmTypeB) = do
+    let width = widthToLlvmInt w
+        argTy = [width, width]
+        retTy = LMStructU [llvmTypeA, llvmTypeB]
+
+    -- Process the arguments.
+    let args_hints = zip [argA, argB] (snd $ foreignTargetHints target)
+    (argsV1, args1, top1) <- arg_vars args_hints ([], nilOL, [])
+    (argsV2, args2) <- castVars Signed $ zip argsV1 argTy
+
+    -- Get the function and make the call.
+    fname <- cmmPrimOpFunctions op
+    (fptr, _, top2) <- getInstrinct fname retTy argTy
+    -- We use StdCall for primops. See also the last case of genCall.
+    (retV, call) <- doExpr retTy $ Call StdCall fptr argsV2 []
+
+    -- This will result in a two element struct, we need to use "extractvalue"
+    -- to get them out of it.
+    (res1, ext1) <- doExpr llvmTypeA (ExtractV retV 0)
+    (res2, ext2) <- doExpr llvmTypeB (ExtractV retV 1)
+
+    let stmts = args1 `appOL` args2 `snocOL` call `snocOL` ext1 `snocOL` ext2
+        tops = top1 ++ top2
+    return (res1, res2, (stmts, tops))
+
+genCallExtract _ _ _ _ =
+    panic "genCallExtract: unsupported ForeignTarget"
+
+-- Handle simple function call that only need simple type casting, of the form:
+--   truncate arg >>= \a -> call(a) >>= zext
+--
+-- since GHC only really has i32 and i64 types and things like Word8 are backed
+-- by an i32 and just present a logical i8 range. So we must handle conversions
+-- from i32 to i8 explicitly as LLVM is strict about types.
+genCallSimpleCast :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual]
+              -> LlvmM StmtData
+genCallSimpleCast w t@(PrimTarget op) [dst] args = do
+    let width = widthToLlvmInt w
+        dstTy = cmmToLlvmType $ localRegType dst
+
+    fname                       <- cmmPrimOpFunctions op
+    (fptr, _, top3)             <- getInstrinct fname width [width]
+
+    dstV                        <- getCmmReg (CmmLocal dst)
+
+    let (_, arg_hints) = foreignTargetHints t
+    let args_hints = zip args arg_hints
+    (argsV, stmts2, top2)       <- arg_vars args_hints ([], nilOL, [])
+    (argsV', stmts4)            <- castVars Signed $ zip argsV [width]
+    (retV, s1)                  <- doExpr width $ Call StdCall fptr argsV' []
+    (retVs', stmts5)            <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)]
+    let retV'                    = singletonPanic "genCallSimpleCast" retVs'
+    let s2                       = Store retV' dstV
+
+    let stmts = stmts2 `appOL` stmts4 `snocOL`
+                s1 `appOL` stmts5 `snocOL` s2
+    return (stmts, top2 ++ top3)
+genCallSimpleCast _ _ dsts _ =
+    panic ("genCallSimpleCast: " ++ show (length dsts) ++ " dsts")
+
+-- Handle simple function call that only need simple type casting, of the form:
+--   truncate arg >>= \a -> call(a) >>= zext
+--
+-- since GHC only really has i32 and i64 types and things like Word8 are backed
+-- by an i32 and just present a logical i8 range. So we must handle conversions
+-- from i32 to i8 explicitly as LLVM is strict about types.
+genCallSimpleCast2 :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual]
+              -> LlvmM StmtData
+genCallSimpleCast2 w t@(PrimTarget op) [dst] args = do
+    let width = widthToLlvmInt w
+        dstTy = cmmToLlvmType $ localRegType dst
+
+    fname                       <- cmmPrimOpFunctions op
+    (fptr, _, top3)             <- getInstrinct fname width (const width <$> args)
+
+    dstV                        <- getCmmReg (CmmLocal dst)
+
+    let (_, arg_hints) = foreignTargetHints t
+    let args_hints = zip args arg_hints
+    (argsV, stmts2, top2)       <- arg_vars args_hints ([], nilOL, [])
+    (argsV', stmts4)            <- castVars Signed $ zip argsV (const width <$> argsV)
+    (retV, s1)                  <- doExpr width $ Call StdCall fptr argsV' []
+    (retVs', stmts5)             <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)]
+    let retV'                    = singletonPanic "genCallSimpleCast2" retVs'
+    let s2                       = Store retV' dstV
+
+    let stmts = stmts2 `appOL` stmts4 `snocOL`
+                s1 `appOL` stmts5 `snocOL` s2
+    return (stmts, top2 ++ top3)
+genCallSimpleCast2 _ _ dsts _ =
+    panic ("genCallSimpleCast2: " ++ show (length dsts) ++ " dsts")
+
+-- | Create a function pointer from a target.
+getFunPtrW :: (LMString -> LlvmType) -> ForeignTarget
+           -> WriterT LlvmAccum LlvmM LlvmVar
+getFunPtrW funTy targ = liftExprData $ getFunPtr funTy targ
+
+-- | Create a function pointer from a target.
+getFunPtr :: (LMString -> LlvmType) -> ForeignTarget
+          -> LlvmM ExprData
+getFunPtr funTy targ = case targ of
+    ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do
+        name <- strCLabel_llvm lbl
+        getHsFunc' name (funTy name)
+
+    ForeignTarget expr _ -> do
+        (v1, stmts, top) <- exprToVar expr
+        dflags <- getDynFlags
+        let fty = funTy $ fsLit "dynamic"
+            cast = case getVarType v1 of
+                ty | isPointer ty -> LM_Bitcast
+                ty | isInt ty     -> LM_Inttoptr
+
+                ty -> panic $ "genCall: Expr is of bad type for function"
+                              ++ " call! (" ++ showSDoc dflags (ppr ty) ++ ")"
+
+        (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
+        return (v2, stmts `snocOL` s1, top)
+
+    PrimTarget mop -> do
+        name <- cmmPrimOpFunctions mop
+        let fty = funTy name
+        getInstrinct2 name fty
+
+-- | Conversion of call arguments.
+arg_varsW :: [(CmmActual, ForeignHint)]
+          -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
+          -> WriterT LlvmAccum LlvmM [LlvmVar]
+arg_varsW xs ys = do
+    (vars, stmts, decls) <- lift $ arg_vars xs ys
+    tell $ LlvmAccum stmts decls
+    return vars
+
+-- | Conversion of call arguments.
+arg_vars :: [(CmmActual, ForeignHint)]
+         -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
+         -> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
+
+arg_vars [] (vars, stmts, tops)
+  = return (vars, stmts, tops)
+
+arg_vars ((e, AddrHint):rest) (vars, stmts, tops)
+  = do (v1, stmts', top') <- exprToVar e
+       dflags <- getDynFlags
+       let op = case getVarType v1 of
+               ty | isPointer ty -> LM_Bitcast
+               ty | isInt ty     -> LM_Inttoptr
+
+               a  -> panic $ "genCall: Can't cast llvmType to i8*! ("
+                           ++ showSDoc dflags (ppr a) ++ ")"
+
+       (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr
+       arg_vars rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1,
+                               tops ++ top')
+
+arg_vars ((e, _):rest) (vars, stmts, tops)
+  = do (v1, stmts', top') <- exprToVar e
+       arg_vars rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top')
+
+
+-- | Cast a collection of LLVM variables to specific types.
+castVarsW :: Signage
+          -> [(LlvmVar, LlvmType)]
+          -> WriterT LlvmAccum LlvmM [LlvmVar]
+castVarsW signage vars = do
+    (vars, stmts) <- lift $ castVars signage vars
+    tell $ LlvmAccum stmts mempty
+    return vars
+
+-- | Cast a collection of LLVM variables to specific types.
+castVars :: Signage -> [(LlvmVar, LlvmType)]
+         -> LlvmM ([LlvmVar], LlvmStatements)
+castVars signage vars = do
+                done <- mapM (uncurry (castVar signage)) vars
+                let (vars', stmts) = unzip done
+                return (vars', toOL stmts)
+
+-- | Cast an LLVM variable to a specific type, panicing if it can't be done.
+castVar :: Signage -> LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement)
+castVar signage v t | getVarType v == t
+            = return (v, Nop)
+
+            | otherwise
+            = do dflags <- getDynFlags
+                 let op = case (getVarType v, t) of
+                      (LMInt n, LMInt m)
+                          -> if n < m then extend else LM_Trunc
+                      (vt, _) | isFloat vt && isFloat t
+                          -> if llvmWidthInBits dflags vt < llvmWidthInBits dflags t
+                                then LM_Fpext else LM_Fptrunc
+                      (vt, _) | isInt vt && isFloat t       -> LM_Sitofp
+                      (vt, _) | isFloat vt && isInt t       -> LM_Fptosi
+                      (vt, _) | isInt vt && isPointer t     -> LM_Inttoptr
+                      (vt, _) | isPointer vt && isInt t     -> LM_Ptrtoint
+                      (vt, _) | isPointer vt && isPointer t -> LM_Bitcast
+                      (vt, _) | isVector vt && isVector t   -> LM_Bitcast
+
+                      (vt, _) -> panic $ "castVars: Can't cast this type ("
+                                  ++ showSDoc dflags (ppr vt) ++ ") to (" ++ showSDoc dflags (ppr t) ++ ")"
+                 doExpr t $ Cast op v t
+    where extend = case signage of
+            Signed      -> LM_Sext
+            Unsigned    -> LM_Zext
+
+
+cmmPrimOpRetValSignage :: CallishMachOp -> Signage
+cmmPrimOpRetValSignage mop = case mop of
+    MO_Pdep _   -> Unsigned
+    MO_Pext _   -> Unsigned
+    _           -> Signed
+
+-- | Decide what C function to use to implement a CallishMachOp
+cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString
+cmmPrimOpFunctions mop = do
+
+  dflags <- getDynFlags
+  let intrinTy1 = "p0i8.p0i8." ++ showSDoc dflags (ppr $ llvmWord dflags)
+      intrinTy2 = "p0i8." ++ showSDoc dflags (ppr $ llvmWord dflags)
+      unsupported = panic ("cmmPrimOpFunctions: " ++ show mop
+                        ++ " not supported here")
+
+  return $ case mop of
+    MO_F32_Exp    -> fsLit "expf"
+    MO_F32_ExpM1  -> fsLit "expm1f"
+    MO_F32_Log    -> fsLit "logf"
+    MO_F32_Log1P  -> fsLit "log1pf"
+    MO_F32_Sqrt   -> fsLit "llvm.sqrt.f32"
+    MO_F32_Fabs   -> fsLit "llvm.fabs.f32"
+    MO_F32_Pwr    -> fsLit "llvm.pow.f32"
+
+    MO_F32_Sin    -> fsLit "llvm.sin.f32"
+    MO_F32_Cos    -> fsLit "llvm.cos.f32"
+    MO_F32_Tan    -> fsLit "tanf"
+
+    MO_F32_Asin   -> fsLit "asinf"
+    MO_F32_Acos   -> fsLit "acosf"
+    MO_F32_Atan   -> fsLit "atanf"
+
+    MO_F32_Sinh   -> fsLit "sinhf"
+    MO_F32_Cosh   -> fsLit "coshf"
+    MO_F32_Tanh   -> fsLit "tanhf"
+
+    MO_F32_Asinh  -> fsLit "asinhf"
+    MO_F32_Acosh  -> fsLit "acoshf"
+    MO_F32_Atanh  -> fsLit "atanhf"
+
+    MO_F64_Exp    -> fsLit "exp"
+    MO_F64_ExpM1  -> fsLit "expm1"
+    MO_F64_Log    -> fsLit "log"
+    MO_F64_Log1P  -> fsLit "log1p"
+    MO_F64_Sqrt   -> fsLit "llvm.sqrt.f64"
+    MO_F64_Fabs   -> fsLit "llvm.fabs.f64"
+    MO_F64_Pwr    -> fsLit "llvm.pow.f64"
+
+    MO_F64_Sin    -> fsLit "llvm.sin.f64"
+    MO_F64_Cos    -> fsLit "llvm.cos.f64"
+    MO_F64_Tan    -> fsLit "tan"
+
+    MO_F64_Asin   -> fsLit "asin"
+    MO_F64_Acos   -> fsLit "acos"
+    MO_F64_Atan   -> fsLit "atan"
+
+    MO_F64_Sinh   -> fsLit "sinh"
+    MO_F64_Cosh   -> fsLit "cosh"
+    MO_F64_Tanh   -> fsLit "tanh"
+
+    MO_F64_Asinh  -> fsLit "asinh"
+    MO_F64_Acosh  -> fsLit "acosh"
+    MO_F64_Atanh  -> fsLit "atanh"
+
+    MO_Memcpy _   -> fsLit $ "llvm.memcpy."  ++ intrinTy1
+    MO_Memmove _  -> fsLit $ "llvm.memmove." ++ intrinTy1
+    MO_Memset _   -> fsLit $ "llvm.memset."  ++ intrinTy2
+    MO_Memcmp _   -> fsLit $ "memcmp"
+
+    (MO_PopCnt w) -> fsLit $ "llvm.ctpop."      ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+    (MO_BSwap w)  -> fsLit $ "llvm.bswap."      ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+    (MO_BRev w)   -> fsLit $ "llvm.bitreverse." ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+    (MO_Clz w)    -> fsLit $ "llvm.ctlz."       ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+    (MO_Ctz w)    -> fsLit $ "llvm.cttz."       ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+
+    (MO_Pdep w)   ->  let w' = showSDoc dflags (ppr $ widthInBits w)
+                      in  if isBmi2Enabled dflags
+                            then fsLit $ "llvm.x86.bmi.pdep."   ++ w'
+                            else fsLit $ "hs_pdep"              ++ w'
+    (MO_Pext w)   ->  let w' = showSDoc dflags (ppr $ widthInBits w)
+                      in  if isBmi2Enabled dflags
+                            then fsLit $ "llvm.x86.bmi.pext."   ++ w'
+                            else fsLit $ "hs_pext"              ++ w'
+
+    (MO_Prefetch_Data _ )-> fsLit "llvm.prefetch"
+
+    MO_AddIntC w    -> fsLit $ "llvm.sadd.with.overflow."
+                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+    MO_SubIntC w    -> fsLit $ "llvm.ssub.with.overflow."
+                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+    MO_Add2 w       -> fsLit $ "llvm.uadd.with.overflow."
+                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+    MO_AddWordC w   -> fsLit $ "llvm.uadd.with.overflow."
+                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+    MO_SubWordC w   -> fsLit $ "llvm.usub.with.overflow."
+                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+
+    MO_S_Mul2    {}  -> unsupported
+    MO_S_QuotRem {}  -> unsupported
+    MO_U_QuotRem {}  -> unsupported
+    MO_U_QuotRem2 {} -> unsupported
+    -- We support MO_U_Mul2 through ordinary LLVM mul instruction, see the
+    -- appropriate case of genCall.
+    MO_U_Mul2 {}     -> unsupported
+    MO_ReadBarrier   -> unsupported
+    MO_WriteBarrier  -> unsupported
+    MO_Touch         -> unsupported
+    MO_UF_Conv _     -> unsupported
+
+    MO_AtomicRead _  -> unsupported
+    MO_AtomicRMW _ _ -> unsupported
+    MO_AtomicWrite _ -> unsupported
+    MO_Cmpxchg _     -> unsupported
+
+-- | Tail function calls
+genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData
+
+-- Call to known function
+genJump (CmmLit (CmmLabel lbl)) live = do
+    (vf, stmts, top) <- getHsFunc live lbl
+    (stgRegs, stgStmts) <- funEpilogue live
+    let s1  = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs
+    let s2  = Return Nothing
+    return (stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top)
+
+
+-- Call to unknown function / address
+genJump expr live = do
+    fty <- llvmFunTy live
+    (vf, stmts, top) <- exprToVar expr
+    dflags <- getDynFlags
+
+    let cast = case getVarType vf of
+         ty | isPointer ty -> LM_Bitcast
+         ty | isInt ty     -> LM_Inttoptr
+
+         ty -> panic $ "genJump: Expr is of bad type for function call! ("
+                     ++ showSDoc dflags (ppr ty) ++ ")"
+
+    (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty)
+    (stgRegs, stgStmts) <- funEpilogue live
+    let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs
+    let s3 = Return Nothing
+    return (stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3,
+            top)
+
+
+-- | CmmAssign operation
+--
+-- We use stack allocated variables for CmmReg. The optimiser will replace
+-- these with registers when possible.
+genAssign :: CmmReg -> CmmExpr -> LlvmM StmtData
+genAssign reg val = do
+    vreg <- getCmmReg reg
+    (vval, stmts2, top2) <- exprToVar val
+    let stmts = stmts2
+
+    let ty = (pLower . getVarType) vreg
+    dflags <- getDynFlags
+    case ty of
+      -- Some registers are pointer types, so need to cast value to pointer
+      LMPointer _ | getVarType vval == llvmWord dflags -> do
+          (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
+          let s2 = Store v vreg
+          return (stmts `snocOL` s1 `snocOL` s2, top2)
+
+      LMVector _ _ -> do
+          (v, s1) <- doExpr ty $ Cast LM_Bitcast vval ty
+          let s2 = Store v vreg
+          return (stmts `snocOL` s1 `snocOL` s2, top2)
+
+      _ -> do
+          let s1 = Store vval vreg
+          return (stmts `snocOL` s1, top2)
+
+
+-- | CmmStore operation
+genStore :: CmmExpr -> CmmExpr -> LlvmM StmtData
+
+-- First we try to detect a few common cases and produce better code for
+-- these then the default case. We are mostly trying to detect Cmm code
+-- like I32[Sp + n] and use 'getelementptr' operations instead of the
+-- generic case that uses casts and pointer arithmetic
+genStore addr@(CmmReg (CmmGlobal r)) val
+    = genStore_fast addr r 0 val
+
+genStore addr@(CmmRegOff (CmmGlobal r) n) val
+    = genStore_fast addr r n val
+
+genStore addr@(CmmMachOp (MO_Add _) [
+                            (CmmReg (CmmGlobal r)),
+                            (CmmLit (CmmInt n _))])
+                val
+    = genStore_fast addr r (fromInteger n) val
+
+genStore addr@(CmmMachOp (MO_Sub _) [
+                            (CmmReg (CmmGlobal r)),
+                            (CmmLit (CmmInt n _))])
+                val
+    = genStore_fast addr r (negate $ fromInteger n) val
+
+-- generic case
+genStore addr val
+    = getTBAAMeta topN >>= genStore_slow addr val
+
+-- | CmmStore operation
+-- This is a special case for storing to a global register pointer
+-- offset such as I32[Sp+8].
+genStore_fast :: CmmExpr -> GlobalReg -> Int -> CmmExpr
+              -> LlvmM StmtData
+genStore_fast addr r n val
+  = do dflags <- getDynFlags
+       (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
+       meta          <- getTBAARegMeta r
+       let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt  `div` 8)
+       case isPointer grt && rem == 0 of
+            True -> do
+                (vval,  stmts, top) <- exprToVar val
+                (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
+                -- We might need a different pointer type, so check
+                case pLower grt == getVarType vval of
+                     -- were fine
+                     True  -> do
+                         let s3 = MetaStmt meta $ Store vval ptr
+                         return (stmts `appOL` s1 `snocOL` s2
+                                 `snocOL` s3, top)
+
+                     -- cast to pointer type needed
+                     False -> do
+                         let ty = (pLift . getVarType) vval
+                         (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty
+                         let s4 = MetaStmt meta $ Store vval ptr'
+                         return (stmts `appOL` s1 `snocOL` s2
+                                 `snocOL` s3 `snocOL` s4, top)
+
+            -- If its a bit type then we use the slow method since
+            -- we can't avoid casting anyway.
+            False -> genStore_slow addr val meta
+
+
+-- | CmmStore operation
+-- Generic case. Uses casts and pointer arithmetic if needed.
+genStore_slow :: CmmExpr -> CmmExpr -> [MetaAnnot] -> LlvmM StmtData
+genStore_slow addr val meta = do
+    (vaddr, stmts1, top1) <- exprToVar addr
+    (vval,  stmts2, top2) <- exprToVar val
+
+    let stmts = stmts1 `appOL` stmts2
+    dflags <- getDynFlags
+    case getVarType vaddr of
+        -- sometimes we need to cast an int to a pointer before storing
+        LMPointer ty@(LMPointer _) | getVarType vval == llvmWord dflags -> do
+            (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
+            let s2 = MetaStmt meta $ Store v vaddr
+            return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
+
+        LMPointer _ -> do
+            let s1 = MetaStmt meta $ Store vval vaddr
+            return (stmts `snocOL` s1, top1 ++ top2)
+
+        i@(LMInt _) | i == llvmWord dflags -> do
+            let vty = pLift $ getVarType vval
+            (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty
+            let s2 = MetaStmt meta $ Store vval vptr
+            return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
+
+        other ->
+            pprPanic "genStore: ptr not right type!"
+                    (PprCmm.pprExpr addr <+> text (
+                        "Size of Ptr: " ++ show (llvmPtrBits dflags) ++
+                        ", Size of var: " ++ show (llvmWidthInBits dflags other) ++
+                        ", Var: " ++ showSDoc dflags (ppr vaddr)))
+
+
+-- | Unconditional branch
+genBranch :: BlockId -> LlvmM StmtData
+genBranch id =
+    let label = blockIdToLlvm id
+    in return (unitOL $ Branch label, [])
+
+
+-- | Conditional branch
+genCondBranch :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> LlvmM StmtData
+genCondBranch cond idT idF likely = do
+    let labelT = blockIdToLlvm idT
+    let labelF = blockIdToLlvm idF
+    -- See Note [Literals and branch conditions].
+    (vc, stmts1, top1) <- exprToVarOpt i1Option cond
+    if getVarType vc == i1
+        then do
+            (vc', (stmts2, top2)) <- case likely of
+              Just b -> genExpectLit (if b then 1 else 0) i1  vc
+              _      -> pure (vc, (nilOL, []))
+            let s1 = BranchIf vc' labelT labelF
+            return (stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2)
+        else do
+            dflags <- getDynFlags
+            panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppr vc) ++ ")"
+
+
+-- | Generate call to llvm.expect.x intrinsic. Assigning result to a new var.
+genExpectLit :: Integer -> LlvmType -> LlvmVar -> LlvmM (LlvmVar, StmtData)
+genExpectLit expLit expTy var = do
+  dflags <- getDynFlags
+
+  let
+    lit = LMLitVar $ LMIntLit expLit expTy
+
+    llvmExpectName
+      | isInt expTy = fsLit $ "llvm.expect." ++ showSDoc dflags (ppr expTy)
+      | otherwise   = panic $ "genExpectedLit: Type not an int!"
+
+  (llvmExpect, stmts, top) <-
+    getInstrinct llvmExpectName expTy [expTy, expTy]
+  (var', call) <- doExpr expTy $ Call StdCall llvmExpect [var, lit] []
+  return (var', (stmts `snocOL` call, top))
+
+{- Note [Literals and branch conditions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+It is important that whenever we generate branch conditions for
+literals like '1', they are properly narrowed to an LLVM expression of
+type 'i1' (for bools.) Otherwise, nobody is happy. So when we convert
+a CmmExpr to an LLVM expression for a branch conditional, exprToVarOpt
+must be certain to return a properly narrowed type. genLit is
+responsible for this, in the case of literal integers.
+
+Often, we won't see direct statements like:
+
+    if(1) {
+      ...
+    } else {
+      ...
+    }
+
+at this point in the pipeline, because the Glorious Code Generator
+will do trivial branch elimination in the sinking pass (among others,)
+which will eliminate the expression entirely.
+
+However, it's certainly possible and reasonable for this to occur in
+hand-written C-- code. Consider something like:
+
+    #if !defined(SOME_CONDITIONAL)
+    #define CHECK_THING(x) 1
+    #else
+    #define CHECK_THING(x) some_operation((x))
+    #endif
+
+    f() {
+
+      if (CHECK_THING(xyz)) {
+        ...
+      } else {
+        ...
+      }
+
+    }
+
+In such an instance, CHECK_THING might result in an *expression* in
+one case, and a *literal* in the other, depending on what in
+particular was #define'd. So we must be sure to properly narrow the
+literal in this case to i1 as it won't be eliminated beforehand.
+
+For a real example of this, see ./rts/StgStdThunks.cmm
+
+-}
+
+
+
+-- | Switch branch
+genSwitch :: CmmExpr -> SwitchTargets -> LlvmM StmtData
+genSwitch cond ids = do
+    (vc, stmts, top) <- exprToVar cond
+    let ty = getVarType vc
+
+    let labels = [ (mkIntLit ty ix, blockIdToLlvm b)
+                 | (ix, b) <- switchTargetsCases ids ]
+    -- out of range is undefined, so let's just branch to first label
+    let defLbl | Just l <- switchTargetsDefault ids = blockIdToLlvm l
+               | otherwise                          = snd (head labels)
+
+    let s1 = Switch vc defLbl labels
+    return $ (stmts `snocOL` s1, top)
+
+
+-- -----------------------------------------------------------------------------
+-- * CmmExpr code generation
+--
+
+-- | An expression conversion return data:
+--   * LlvmVar: The var holding the result of the expression
+--   * LlvmStatements: Any statements needed to evaluate the expression
+--   * LlvmCmmDecl: Any global data needed for this expression
+type ExprData = (LlvmVar, LlvmStatements, [LlvmCmmDecl])
+
+-- | Values which can be passed to 'exprToVar' to configure its
+-- behaviour in certain circumstances.
+--
+-- Currently just used for determining if a comparison should return
+-- a boolean (i1) or a word. See Note [Literals and branch conditions].
+newtype EOption = EOption { i1Expected :: Bool }
+-- XXX: EOption is an ugly and inefficient solution to this problem.
+
+-- | i1 type expected (condition scrutinee).
+i1Option :: EOption
+i1Option = EOption True
+
+-- | Word type expected (usual).
+wordOption :: EOption
+wordOption = EOption False
+
+-- | Convert a CmmExpr to a list of LlvmStatements with the result of the
+-- expression being stored in the returned LlvmVar.
+exprToVar :: CmmExpr -> LlvmM ExprData
+exprToVar = exprToVarOpt wordOption
+
+exprToVarOpt :: EOption -> CmmExpr -> LlvmM ExprData
+exprToVarOpt opt e = case e of
+
+    CmmLit lit
+        -> genLit opt lit
+
+    CmmLoad e' ty
+        -> genLoad False e' ty
+
+    -- Cmmreg in expression is the value, so must load. If you want actual
+    -- reg pointer, call getCmmReg directly.
+    CmmReg r -> do
+        (v1, ty, s1) <- getCmmRegVal r
+        case isPointer ty of
+             True  -> do
+                 -- Cmm wants the value, so pointer types must be cast to ints
+                 dflags <- getDynFlags
+                 (v2, s2) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint v1 (llvmWord dflags)
+                 return (v2, s1 `snocOL` s2, [])
+
+             False -> return (v1, s1, [])
+
+    CmmMachOp op exprs
+        -> genMachOp opt op exprs
+
+    CmmRegOff r i
+        -> do dflags <- getDynFlags
+              exprToVar $ expandCmmReg dflags (r, i)
+
+    CmmStackSlot _ _
+        -> panic "exprToVar: CmmStackSlot not supported!"
+
+
+-- | Handle CmmMachOp expressions
+genMachOp :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
+
+-- Unary Machop
+genMachOp _ op [x] = case op of
+
+    MO_Not w ->
+        let all1 = mkIntLit (widthToLlvmInt w) (-1)
+        in negate (widthToLlvmInt w) all1 LM_MO_Xor
+
+    MO_S_Neg w ->
+        let all0 = mkIntLit (widthToLlvmInt w) 0
+        in negate (widthToLlvmInt w) all0 LM_MO_Sub
+
+    MO_F_Neg w ->
+        let all0 = LMLitVar $ LMFloatLit (-0) (widthToLlvmFloat w)
+        in negate (widthToLlvmFloat w) all0 LM_MO_FSub
+
+    MO_SF_Conv _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp
+    MO_FS_Conv _ w -> fiConv (widthToLlvmInt w) LM_Fptosi
+
+    MO_SS_Conv from to
+        -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Sext
+
+    MO_UU_Conv from to
+        -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext
+
+    MO_XX_Conv from to
+        -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext
+
+    MO_FF_Conv from to
+        -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext
+
+    MO_VS_Neg len w ->
+        let ty    = widthToLlvmInt w
+            vecty = LMVector len ty
+            all0  = LMIntLit (-0) ty
+            all0s = LMLitVar $ LMVectorLit (replicate len all0)
+        in negateVec vecty all0s LM_MO_Sub
+
+    MO_VF_Neg len w ->
+        let ty    = widthToLlvmFloat w
+            vecty = LMVector len ty
+            all0  = LMFloatLit (-0) ty
+            all0s = LMLitVar $ LMVectorLit (replicate len all0)
+        in negateVec vecty all0s LM_MO_FSub
+
+    MO_AlignmentCheck _ _ -> panic "-falignment-sanitisation is not supported by -fllvm"
+
+    -- Handle unsupported cases explicitly so we get a warning
+    -- of missing case when new MachOps added
+    MO_Add _          -> panicOp
+    MO_Mul _          -> panicOp
+    MO_Sub _          -> panicOp
+    MO_S_MulMayOflo _ -> panicOp
+    MO_S_Quot _       -> panicOp
+    MO_S_Rem _        -> panicOp
+    MO_U_MulMayOflo _ -> panicOp
+    MO_U_Quot _       -> panicOp
+    MO_U_Rem _        -> panicOp
+
+    MO_Eq  _          -> panicOp
+    MO_Ne  _          -> panicOp
+    MO_S_Ge _         -> panicOp
+    MO_S_Gt _         -> panicOp
+    MO_S_Le _         -> panicOp
+    MO_S_Lt _         -> panicOp
+    MO_U_Ge _         -> panicOp
+    MO_U_Gt _         -> panicOp
+    MO_U_Le _         -> panicOp
+    MO_U_Lt _         -> panicOp
+
+    MO_F_Add        _ -> panicOp
+    MO_F_Sub        _ -> panicOp
+    MO_F_Mul        _ -> panicOp
+    MO_F_Quot       _ -> panicOp
+    MO_F_Eq         _ -> panicOp
+    MO_F_Ne         _ -> panicOp
+    MO_F_Ge         _ -> panicOp
+    MO_F_Gt         _ -> panicOp
+    MO_F_Le         _ -> panicOp
+    MO_F_Lt         _ -> panicOp
+
+    MO_And          _ -> panicOp
+    MO_Or           _ -> panicOp
+    MO_Xor          _ -> panicOp
+    MO_Shl          _ -> panicOp
+    MO_U_Shr        _ -> panicOp
+    MO_S_Shr        _ -> panicOp
+
+    MO_V_Insert   _ _ -> panicOp
+    MO_V_Extract  _ _ -> panicOp
+
+    MO_V_Add      _ _ -> panicOp
+    MO_V_Sub      _ _ -> panicOp
+    MO_V_Mul      _ _ -> panicOp
+
+    MO_VS_Quot    _ _ -> panicOp
+    MO_VS_Rem     _ _ -> panicOp
+
+    MO_VU_Quot    _ _ -> panicOp
+    MO_VU_Rem     _ _ -> panicOp
+
+    MO_VF_Insert  _ _ -> panicOp
+    MO_VF_Extract _ _ -> panicOp
+
+    MO_VF_Add     _ _ -> panicOp
+    MO_VF_Sub     _ _ -> panicOp
+    MO_VF_Mul     _ _ -> panicOp
+    MO_VF_Quot    _ _ -> panicOp
+
+    where
+        negate ty v2 negOp = do
+            (vx, stmts, top) <- exprToVar x
+            (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx
+            return (v1, stmts `snocOL` s1, top)
+
+        negateVec ty v2 negOp = do
+            (vx, stmts1, top) <- exprToVar x
+            (vxs', stmts2) <- castVars Signed [(vx, ty)]
+            let vx' = singletonPanic "genMachOp: negateVec" vxs'
+            (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx'
+            return (v1, stmts1 `appOL` stmts2 `snocOL` s1, top)
+
+        fiConv ty convOp = do
+            (vx, stmts, top) <- exprToVar x
+            (v1, s1) <- doExpr ty $ Cast convOp vx ty
+            return (v1, stmts `snocOL` s1, top)
+
+        sameConv from ty reduce expand = do
+            x'@(vx, stmts, top) <- exprToVar x
+            let sameConv' op = do
+                    (v1, s1) <- doExpr ty $ Cast op vx ty
+                    return (v1, stmts `snocOL` s1, top)
+            dflags <- getDynFlags
+            let toWidth = llvmWidthInBits dflags ty
+            -- LLVM doesn't like trying to convert to same width, so
+            -- need to check for that as we do get Cmm code doing it.
+            case widthInBits from  of
+                 w | w < toWidth -> sameConv' expand
+                 w | w > toWidth -> sameConv' reduce
+                 _w              -> return x'
+
+        panicOp = panic $ "LLVM.CodeGen.genMachOp: non unary op encountered"
+                       ++ "with one argument! (" ++ show op ++ ")"
+
+-- Handle GlobalRegs pointers
+genMachOp opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
+    = genMachOp_fast opt o r (fromInteger n) e
+
+genMachOp opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
+    = genMachOp_fast opt o r (negate . fromInteger $ n) e
+
+-- Generic case
+genMachOp opt op e = genMachOp_slow opt op e
+
+
+-- | Handle CmmMachOp expressions
+-- This is a specialised method that handles Global register manipulations like
+-- 'Sp - 16', using the getelementptr instruction.
+genMachOp_fast :: EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr]
+               -> LlvmM ExprData
+genMachOp_fast opt op r n e
+  = do (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
+       dflags <- getDynFlags
+       let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt  `div` 8)
+       case isPointer grt && rem == 0 of
+            True -> do
+                (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
+                (var, s3) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint ptr (llvmWord dflags)
+                return (var, s1 `snocOL` s2 `snocOL` s3, [])
+
+            False -> genMachOp_slow opt op e
+
+
+-- | Handle CmmMachOp expressions
+-- This handles all the cases not handle by the specialised genMachOp_fast.
+genMachOp_slow :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
+
+-- Element extraction
+genMachOp_slow _ (MO_V_Extract l w) [val, idx] = runExprData $ do
+    vval <- exprToVarW val
+    vidx <- exprToVarW idx
+    vval' <- singletonPanic "genMachOp_slow" <$>
+             castVarsW Signed [(vval, LMVector l ty)]
+    doExprW ty $ Extract vval' vidx
+  where
+    ty = widthToLlvmInt w
+
+genMachOp_slow _ (MO_VF_Extract l w) [val, idx] = runExprData $ do
+    vval <- exprToVarW val
+    vidx <- exprToVarW idx
+    vval' <- singletonPanic "genMachOp_slow" <$>
+             castVarsW Signed [(vval, LMVector l ty)]
+    doExprW ty $ Extract vval' vidx
+  where
+    ty = widthToLlvmFloat w
+
+-- Element insertion
+genMachOp_slow _ (MO_V_Insert l w) [val, elt, idx] = runExprData $ do
+    vval <- exprToVarW val
+    velt <- exprToVarW elt
+    vidx <- exprToVarW idx
+    vval' <- singletonPanic "genMachOp_slow" <$>
+             castVarsW Signed [(vval, ty)]
+    doExprW ty $ Insert vval' velt vidx
+  where
+    ty = LMVector l (widthToLlvmInt w)
+
+genMachOp_slow _ (MO_VF_Insert l w) [val, elt, idx] = runExprData $ do
+    vval <- exprToVarW val
+    velt <- exprToVarW elt
+    vidx <- exprToVarW idx
+    vval' <- singletonPanic "genMachOp_slow" <$>
+             castVarsW Signed [(vval, ty)]
+    doExprW ty $ Insert vval' velt vidx
+  where
+    ty = LMVector l (widthToLlvmFloat w)
+
+-- Binary MachOp
+genMachOp_slow opt op [x, y] = case op of
+
+    MO_Eq _   -> genBinComp opt LM_CMP_Eq
+    MO_Ne _   -> genBinComp opt LM_CMP_Ne
+
+    MO_S_Gt _ -> genBinComp opt LM_CMP_Sgt
+    MO_S_Ge _ -> genBinComp opt LM_CMP_Sge
+    MO_S_Lt _ -> genBinComp opt LM_CMP_Slt
+    MO_S_Le _ -> genBinComp opt LM_CMP_Sle
+
+    MO_U_Gt _ -> genBinComp opt LM_CMP_Ugt
+    MO_U_Ge _ -> genBinComp opt LM_CMP_Uge
+    MO_U_Lt _ -> genBinComp opt LM_CMP_Ult
+    MO_U_Le _ -> genBinComp opt LM_CMP_Ule
+
+    MO_Add _ -> genBinMach LM_MO_Add
+    MO_Sub _ -> genBinMach LM_MO_Sub
+    MO_Mul _ -> genBinMach LM_MO_Mul
+
+    MO_U_MulMayOflo _ -> panic "genMachOp: MO_U_MulMayOflo unsupported!"
+
+    MO_S_MulMayOflo w -> isSMulOK w x y
+
+    MO_S_Quot _ -> genBinMach LM_MO_SDiv
+    MO_S_Rem  _ -> genBinMach LM_MO_SRem
+
+    MO_U_Quot _ -> genBinMach LM_MO_UDiv
+    MO_U_Rem  _ -> genBinMach LM_MO_URem
+
+    MO_F_Eq _ -> genBinComp opt LM_CMP_Feq
+    MO_F_Ne _ -> genBinComp opt LM_CMP_Fne
+    MO_F_Gt _ -> genBinComp opt LM_CMP_Fgt
+    MO_F_Ge _ -> genBinComp opt LM_CMP_Fge
+    MO_F_Lt _ -> genBinComp opt LM_CMP_Flt
+    MO_F_Le _ -> genBinComp opt LM_CMP_Fle
+
+    MO_F_Add  _ -> genBinMach LM_MO_FAdd
+    MO_F_Sub  _ -> genBinMach LM_MO_FSub
+    MO_F_Mul  _ -> genBinMach LM_MO_FMul
+    MO_F_Quot _ -> genBinMach LM_MO_FDiv
+
+    MO_And _   -> genBinMach LM_MO_And
+    MO_Or  _   -> genBinMach LM_MO_Or
+    MO_Xor _   -> genBinMach LM_MO_Xor
+    MO_Shl _   -> genBinMach LM_MO_Shl
+    MO_U_Shr _ -> genBinMach LM_MO_LShr
+    MO_S_Shr _ -> genBinMach LM_MO_AShr
+
+    MO_V_Add l w   -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Add
+    MO_V_Sub l w   -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Sub
+    MO_V_Mul l w   -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Mul
+
+    MO_VS_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SDiv
+    MO_VS_Rem  l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SRem
+
+    MO_VU_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_UDiv
+    MO_VU_Rem  l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_URem
+
+    MO_VF_Add  l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FAdd
+    MO_VF_Sub  l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FSub
+    MO_VF_Mul  l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FMul
+    MO_VF_Quot l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FDiv
+
+    MO_Not _       -> panicOp
+    MO_S_Neg _     -> panicOp
+    MO_F_Neg _     -> panicOp
+
+    MO_SF_Conv _ _ -> panicOp
+    MO_FS_Conv _ _ -> panicOp
+    MO_SS_Conv _ _ -> panicOp
+    MO_UU_Conv _ _ -> panicOp
+    MO_XX_Conv _ _ -> panicOp
+    MO_FF_Conv _ _ -> panicOp
+
+    MO_V_Insert  {} -> panicOp
+    MO_V_Extract {} -> panicOp
+
+    MO_VS_Neg {} -> panicOp
+
+    MO_VF_Insert  {} -> panicOp
+    MO_VF_Extract {} -> panicOp
+
+    MO_VF_Neg {} -> panicOp
+
+    MO_AlignmentCheck {} -> panicOp
+
+    where
+        binLlvmOp ty binOp = runExprData $ do
+            vx <- exprToVarW x
+            vy <- exprToVarW y
+            if getVarType vx == getVarType vy
+                then do
+                    doExprW (ty vx) $ binOp vx vy
+
+                else do
+                    -- Error. Continue anyway so we can debug the generated ll file.
+                    dflags <- getDynFlags
+                    let style = mkCodeStyle CStyle
+                        toString doc = renderWithStyle dflags doc style
+                        cmmToStr = (lines . toString . PprCmm.pprExpr)
+                    statement $ Comment $ map fsLit $ cmmToStr x
+                    statement $ Comment $ map fsLit $ cmmToStr y
+                    doExprW (ty vx) $ binOp vx vy
+
+        binCastLlvmOp ty binOp = runExprData $ do
+            vx <- exprToVarW x
+            vy <- exprToVarW y
+            vxy' <- castVarsW Signed [(vx, ty), (vy, ty)]
+            case vxy' of
+              [vx',vy'] -> doExprW ty $ binOp vx' vy'
+              _         -> panic "genMachOp_slow: binCastLlvmOp"
+
+        -- | Need to use EOption here as Cmm expects word size results from
+        -- comparisons while LLVM return i1. Need to extend to llvmWord type
+        -- if expected. See Note [Literals and branch conditions].
+        genBinComp opt cmp = do
+            ed@(v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp)
+            dflags <- getDynFlags
+            if getVarType v1 == i1
+                then case i1Expected opt of
+                    True  -> return ed
+                    False -> do
+                        let w_ = llvmWord dflags
+                        (v2, s1) <- doExpr w_ $ Cast LM_Zext v1 w_
+                        return (v2, stmts `snocOL` s1, top)
+                else
+                    panic $ "genBinComp: Compare returned type other then i1! "
+                        ++ (showSDoc dflags $ ppr $ getVarType v1)
+
+        genBinMach op = binLlvmOp getVarType (LlvmOp op)
+
+        genCastBinMach ty op = binCastLlvmOp ty (LlvmOp op)
+
+        -- | Detect if overflow will occur in signed multiply of the two
+        -- CmmExpr's. This is the LLVM assembly equivalent of the NCG
+        -- implementation. Its much longer due to type information/safety.
+        -- This should actually compile to only about 3 asm instructions.
+        isSMulOK :: Width -> CmmExpr -> CmmExpr -> LlvmM ExprData
+        isSMulOK _ x y = runExprData $ do
+            vx <- exprToVarW x
+            vy <- exprToVarW y
+
+            dflags <- getDynFlags
+            let word  = getVarType vx
+            let word2 = LMInt $ 2 * (llvmWidthInBits dflags $ getVarType vx)
+            let shift = llvmWidthInBits dflags word
+            let shift1 = toIWord dflags (shift - 1)
+            let shift2 = toIWord dflags shift
+
+            if isInt word
+                then do
+                    x1     <- doExprW word2 $ Cast LM_Sext vx word2
+                    y1     <- doExprW word2 $ Cast LM_Sext vy word2
+                    r1     <- doExprW word2 $ LlvmOp LM_MO_Mul x1 y1
+                    rlow1  <- doExprW word $ Cast LM_Trunc r1 word
+                    rlow2  <- doExprW word $ LlvmOp LM_MO_AShr rlow1 shift1
+                    rhigh1 <- doExprW word2 $ LlvmOp LM_MO_AShr r1 shift2
+                    rhigh2 <- doExprW word $ Cast LM_Trunc rhigh1 word
+                    doExprW word $ LlvmOp LM_MO_Sub rlow2 rhigh2
+
+                else
+                    panic $ "isSMulOK: Not bit type! (" ++ showSDoc dflags (ppr word) ++ ")"
+
+        panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encountered"
+                       ++ "with two arguments! (" ++ show op ++ ")"
+
+-- More than two expression, invalid!
+genMachOp_slow _ _ _ = panic "genMachOp: More than 2 expressions in MachOp!"
+
+
+-- | Handle CmmLoad expression.
+genLoad :: Atomic -> CmmExpr -> CmmType -> LlvmM ExprData
+
+-- First we try to detect a few common cases and produce better code for
+-- these then the default case. We are mostly trying to detect Cmm code
+-- like I32[Sp + n] and use 'getelementptr' operations instead of the
+-- generic case that uses casts and pointer arithmetic
+genLoad atomic e@(CmmReg (CmmGlobal r)) ty
+    = genLoad_fast atomic e r 0 ty
+
+genLoad atomic e@(CmmRegOff (CmmGlobal r) n) ty
+    = genLoad_fast atomic e r n ty
+
+genLoad atomic e@(CmmMachOp (MO_Add _) [
+                            (CmmReg (CmmGlobal r)),
+                            (CmmLit (CmmInt n _))])
+                ty
+    = genLoad_fast atomic e r (fromInteger n) ty
+
+genLoad atomic e@(CmmMachOp (MO_Sub _) [
+                            (CmmReg (CmmGlobal r)),
+                            (CmmLit (CmmInt n _))])
+                ty
+    = genLoad_fast atomic e r (negate $ fromInteger n) ty
+
+-- generic case
+genLoad atomic e ty
+    = getTBAAMeta topN >>= genLoad_slow atomic e ty
+
+-- | Handle CmmLoad expression.
+-- This is a special case for loading from a global register pointer
+-- offset such as I32[Sp+8].
+genLoad_fast :: Atomic -> CmmExpr -> GlobalReg -> Int -> CmmType
+             -> LlvmM ExprData
+genLoad_fast atomic e r n ty = do
+    dflags <- getDynFlags
+    (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
+    meta          <- getTBAARegMeta r
+    let ty'      = cmmToLlvmType ty
+        (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt  `div` 8)
+    case isPointer grt && rem == 0 of
+            True  -> do
+                (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
+                -- We might need a different pointer type, so check
+                case grt == ty' of
+                     -- were fine
+                     True -> do
+                         (var, s3) <- doExpr ty' (MExpr meta $ loadInstr ptr)
+                         return (var, s1 `snocOL` s2 `snocOL` s3,
+                                     [])
+
+                     -- cast to pointer type needed
+                     False -> do
+                         let pty = pLift ty'
+                         (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty
+                         (var, s4) <- doExpr ty' (MExpr meta $ loadInstr ptr')
+                         return (var, s1 `snocOL` s2 `snocOL` s3
+                                    `snocOL` s4, [])
+
+            -- If its a bit type then we use the slow method since
+            -- we can't avoid casting anyway.
+            False -> genLoad_slow atomic  e ty meta
+  where
+    loadInstr ptr | atomic    = ALoad SyncSeqCst False ptr
+                  | otherwise = Load ptr
+
+-- | Handle Cmm load expression.
+-- Generic case. Uses casts and pointer arithmetic if needed.
+genLoad_slow :: Atomic -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData
+genLoad_slow atomic e ty meta = runExprData $ do
+    iptr <- exprToVarW e
+    dflags <- getDynFlags
+    case getVarType iptr of
+         LMPointer _ -> do
+                    doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr iptr)
+
+         i@(LMInt _) | i == llvmWord dflags -> do
+                    let pty = LMPointer $ cmmToLlvmType ty
+                    ptr <- doExprW pty $ Cast LM_Inttoptr iptr pty
+                    doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr ptr)
+
+         other -> do pprPanic "exprToVar: CmmLoad expression is not right type!"
+                        (PprCmm.pprExpr e <+> text (
+                            "Size of Ptr: " ++ show (llvmPtrBits dflags) ++
+                            ", Size of var: " ++ show (llvmWidthInBits dflags other) ++
+                            ", Var: " ++ showSDoc dflags (ppr iptr)))
+  where
+    loadInstr ptr | atomic    = ALoad SyncSeqCst False ptr
+                  | otherwise = Load ptr
+
+
+-- | Handle CmmReg expression. This will return a pointer to the stack
+-- location of the register. Throws an error if it isn't allocated on
+-- the stack.
+getCmmReg :: CmmReg -> LlvmM LlvmVar
+getCmmReg (CmmLocal (LocalReg un _))
+  = do exists <- varLookup un
+       dflags <- getDynFlags
+       case exists of
+         Just ety -> return (LMLocalVar un $ pLift ety)
+         Nothing  -> panic $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr un) ++ " was not allocated!"
+           -- This should never happen, as every local variable should
+           -- have been assigned a value at some point, triggering
+           -- "funPrologue" to allocate it on the stack.
+
+getCmmReg (CmmGlobal g)
+  = do onStack <- checkStackReg g
+       dflags <- getDynFlags
+       if onStack
+         then return (lmGlobalRegVar dflags g)
+         else panic $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr g) ++ " not stack-allocated!"
+
+-- | Return the value of a given register, as well as its type. Might
+-- need to be load from stack.
+getCmmRegVal :: CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements)
+getCmmRegVal reg =
+  case reg of
+    CmmGlobal g -> do
+      onStack <- checkStackReg g
+      dflags <- getDynFlags
+      if onStack then loadFromStack else do
+        let r = lmGlobalRegArg dflags g
+        return (r, getVarType r, nilOL)
+    _ -> loadFromStack
+ where loadFromStack = do
+         ptr <- getCmmReg reg
+         let ty = pLower $ getVarType ptr
+         (v, s) <- doExpr ty (Load ptr)
+         return (v, ty, unitOL s)
+
+-- | Allocate a local CmmReg on the stack
+allocReg :: CmmReg -> (LlvmVar, LlvmStatements)
+allocReg (CmmLocal (LocalReg un ty))
+  = let ty' = cmmToLlvmType ty
+        var = LMLocalVar un (LMPointer ty')
+        alc = Alloca ty' 1
+    in (var, unitOL $ Assignment var alc)
+
+allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should"
+                    ++ " have been handled elsewhere!"
+
+
+-- | Generate code for a literal
+genLit :: EOption -> CmmLit -> LlvmM ExprData
+genLit opt (CmmInt i w)
+  -- See Note [Literals and branch conditions].
+  = let width | i1Expected opt = i1
+              | otherwise      = LMInt (widthInBits w)
+        -- comm  = Comment [ fsLit $ "EOption: " ++ show opt
+        --                 , fsLit $ "Width  : " ++ show w
+        --                 , fsLit $ "Width' : " ++ show (widthInBits w)
+        --                 ]
+    in return (mkIntLit width i, nilOL, [])
+
+genLit _ (CmmFloat r w)
+  = return (LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w),
+              nilOL, [])
+
+genLit opt (CmmVec ls)
+  = do llvmLits <- mapM toLlvmLit ls
+       return (LMLitVar $ LMVectorLit llvmLits, nilOL, [])
+  where
+    toLlvmLit :: CmmLit -> LlvmM LlvmLit
+    toLlvmLit lit = do
+        (llvmLitVar, _, _) <- genLit opt lit
+        case llvmLitVar of
+          LMLitVar llvmLit -> return llvmLit
+          _ -> panic "genLit"
+
+genLit _ cmm@(CmmLabel l)
+  = do var <- getGlobalPtr =<< strCLabel_llvm l
+       dflags <- getDynFlags
+       let lmty = cmmToLlvmType $ cmmLitType dflags cmm
+       (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags)
+       return (v1, unitOL s1, [])
+
+genLit opt (CmmLabelOff label off) = do
+    dflags <- getDynFlags
+    (vlbl, stmts, stat) <- genLit opt (CmmLabel label)
+    let voff = toIWord dflags off
+    (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff
+    return (v1, stmts `snocOL` s1, stat)
+
+genLit opt (CmmLabelDiffOff l1 l2 off w) = do
+    dflags <- getDynFlags
+    (vl1, stmts1, stat1) <- genLit opt (CmmLabel l1)
+    (vl2, stmts2, stat2) <- genLit opt (CmmLabel l2)
+    let voff = toIWord dflags off
+    let ty1 = getVarType vl1
+    let ty2 = getVarType vl2
+    if (isInt ty1) && (isInt ty2)
+       && (llvmWidthInBits dflags ty1 == llvmWidthInBits dflags ty2)
+       then do
+            (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2
+            (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff
+            let ty = widthToLlvmInt w
+            let stmts = stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2
+            if w /= wordWidth dflags
+              then do
+                (v3, s3) <- doExpr ty $ Cast LM_Trunc v2 ty
+                return (v3, stmts `snocOL` s3, stat1 ++ stat2)
+              else
+                return (v2, stmts, stat1 ++ stat2)
+        else
+            panic "genLit: CmmLabelDiffOff encountered with different label ty!"
+
+genLit opt (CmmBlock b)
+  = genLit opt (CmmLabel $ infoTblLbl b)
+
+genLit _ CmmHighStackMark
+  = panic "genStaticLit - CmmHighStackMark unsupported!"
+
+
+-- -----------------------------------------------------------------------------
+-- * Misc
+--
+
+-- | Find CmmRegs that get assigned and allocate them on the stack
+--
+-- Any register that gets written needs to be allocated on the
+-- stack. This avoids having to map a CmmReg to an equivalent SSA form
+-- and avoids having to deal with Phi node insertion.  This is also
+-- the approach recommended by LLVM developers.
+--
+-- On the other hand, this is unnecessarily verbose if the register in
+-- question is never written. Therefore we skip it where we can to
+-- save a few lines in the output and hopefully speed compilation up a
+-- bit.
+funPrologue :: LiveGlobalRegs -> [CmmBlock] -> LlvmM StmtData
+funPrologue live cmmBlocks = do
+
+  let getAssignedRegs :: CmmNode O O -> [CmmReg]
+      getAssignedRegs (CmmAssign reg _)  = [reg]
+      getAssignedRegs (CmmUnsafeForeignCall _ rs _) = map CmmLocal rs
+      getAssignedRegs _                  = []
+      getRegsBlock (_, body, _)          = concatMap getAssignedRegs $ blockToList body
+      assignedRegs = nub $ concatMap (getRegsBlock . blockSplit) cmmBlocks
+      isLive r     = r `elem` alwaysLive || r `elem` live
+
+  dflags <- getDynFlags
+  stmtss <- flip mapM assignedRegs $ \reg ->
+    case reg of
+      CmmLocal (LocalReg un _) -> do
+        let (newv, stmts) = allocReg reg
+        varInsert un (pLower $ getVarType newv)
+        return stmts
+      CmmGlobal r -> do
+        let reg   = lmGlobalRegVar dflags r
+            arg   = lmGlobalRegArg dflags r
+            ty    = (pLower . getVarType) reg
+            trash = LMLitVar $ LMUndefLit ty
+            rval  = if isLive r then arg else trash
+            alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1
+        markStackReg r
+        return $ toOL [alloc, Store rval reg]
+
+  return (concatOL stmtss `snocOL` jumpToEntry, [])
+  where
+    entryBlk : _ = cmmBlocks
+    jumpToEntry = Branch $ blockIdToLlvm (entryLabel entryBlk)
+
+-- | Function epilogue. Load STG variables to use as argument for call.
+-- STG Liveness optimisation done here.
+funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements)
+funEpilogue live = do
+    dflags <- getDynFlags
+
+    -- the bool indicates whether the register is padding.
+    let alwaysNeeded = map (\r -> (False, r)) alwaysLive
+        livePadded = alwaysNeeded ++ padLiveArgs dflags live
+
+    -- Set to value or "undef" depending on whether the register is
+    -- actually live
+    let loadExpr r = do
+          (v, _, s) <- getCmmRegVal (CmmGlobal r)
+          return (Just $ v, s)
+        loadUndef r = do
+          let ty = (pLower . getVarType $ lmGlobalRegVar dflags r)
+          return (Just $ LMLitVar $ LMUndefLit ty, nilOL)
+    platform <- getDynFlag targetPlatform
+    let allRegs = activeStgRegs platform
+    loads <- flip mapM allRegs $ \r -> case () of
+      _ | (False, r) `elem` livePadded
+                             -> loadExpr r   -- if r is not padding, load it
+        | not (isFPR r) || (True, r) `elem` livePadded
+                             -> loadUndef r
+        | otherwise          -> return (Nothing, nilOL)
+
+    let (vars, stmts) = unzip loads
+    return (catMaybes vars, concatOL stmts)
+
+-- | Get a function pointer to the CLabel specified.
+--
+-- This is for Haskell functions, function type is assumed, so doesn't work
+-- with foreign functions.
+getHsFunc :: LiveGlobalRegs -> CLabel -> LlvmM ExprData
+getHsFunc live lbl
+  = do fty <- llvmFunTy live
+       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
+mkLocalVar ty = do
+    un <- getUniqueM
+    return $ LMLocalVar un ty
+
+
+-- | Execute an expression, assigning result to a var
+doExpr :: LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
+doExpr ty expr = do
+    v <- mkLocalVar ty
+    return (v, Assignment v expr)
+
+
+-- | Expand CmmRegOff
+expandCmmReg :: DynFlags -> (CmmReg, Int) -> CmmExpr
+expandCmmReg dflags (reg, off)
+  = let width = typeWidth (cmmRegType dflags reg)
+        voff  = CmmLit $ CmmInt (fromIntegral off) width
+    in CmmMachOp (MO_Add width) [CmmReg reg, voff]
+
+
+-- | Convert a block id into a appropriate Llvm label
+blockIdToLlvm :: BlockId -> LlvmVar
+blockIdToLlvm bid = LMLocalVar (getUnique bid) LMLabel
+
+-- | Create Llvm int Literal
+mkIntLit :: Integral a => LlvmType -> a -> LlvmVar
+mkIntLit ty i = LMLitVar $ LMIntLit (toInteger i) ty
+
+-- | Convert int type to a LLvmVar of word or i32 size
+toI32 :: Integral a => a -> LlvmVar
+toI32 = mkIntLit i32
+
+toIWord :: Integral a => DynFlags -> a -> LlvmVar
+toIWord dflags = mkIntLit (llvmWord dflags)
+
+
+-- | Error functions
+panic :: String -> a
+panic s = Outputable.panic $ "GHC.CmmToLlvm.CodeGen." ++ s
+
+pprPanic :: String -> SDoc -> a
+pprPanic s d = Outputable.pprPanic ("GHC.CmmToLlvm.CodeGen." ++ s) d
+
+
+-- | Returns TBAA meta data by unique
+getTBAAMeta :: Unique -> LlvmM [MetaAnnot]
+getTBAAMeta u = do
+    mi <- getUniqMeta u
+    return [MetaAnnot tbaa (MetaNode i) | let Just i = mi]
+
+-- | Returns TBAA meta data for given register
+getTBAARegMeta :: GlobalReg -> LlvmM [MetaAnnot]
+getTBAARegMeta = getTBAAMeta . getTBAA
+
+
+-- | A more convenient way of accumulating LLVM statements and declarations.
+data LlvmAccum = LlvmAccum LlvmStatements [LlvmCmmDecl]
+
+instance Semigroup LlvmAccum where
+  LlvmAccum stmtsA declsA <> LlvmAccum stmtsB declsB =
+        LlvmAccum (stmtsA Semigroup.<> stmtsB) (declsA Semigroup.<> declsB)
+
+instance Monoid LlvmAccum where
+    mempty = LlvmAccum nilOL []
+    mappend = (Semigroup.<>)
+
+liftExprData :: LlvmM ExprData -> WriterT LlvmAccum LlvmM LlvmVar
+liftExprData action = do
+    (var, stmts, decls) <- lift action
+    tell $ LlvmAccum stmts decls
+    return var
+
+statement :: LlvmStatement -> WriterT LlvmAccum LlvmM ()
+statement stmt = tell $ LlvmAccum (unitOL stmt) []
+
+doExprW :: LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
+doExprW a b = do
+    (var, stmt) <- lift $ doExpr a b
+    statement stmt
+    return var
+
+exprToVarW :: CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
+exprToVarW = liftExprData . exprToVar
+
+runExprData :: WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData
+runExprData action = do
+    (var, LlvmAccum stmts decls) <- runWriterT action
+    return (var, stmts, decls)
+
+runStmtsDecls :: WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl])
+runStmtsDecls action = do
+    LlvmAccum stmts decls <- execWriterT action
+    return (stmts, decls)
+
+getCmmRegW :: CmmReg -> WriterT LlvmAccum LlvmM LlvmVar
+getCmmRegW = lift . getCmmReg
+
+genLoadW :: Atomic -> CmmExpr -> CmmType -> WriterT LlvmAccum LlvmM LlvmVar
+genLoadW atomic e ty = liftExprData $ genLoad atomic e ty
+
+-- | Return element of single-element list; 'panic' if list is not a single-element list
+singletonPanic :: String -> [a] -> a
+singletonPanic _ [x] = x
+singletonPanic s _ = panic s
diff --git a/compiler/GHC/CmmToLlvm/Data.hs b/compiler/GHC/CmmToLlvm/Data.hs
new file mode 100644
index 0000000000..b20c9bd360
--- /dev/null
+++ b/compiler/GHC/CmmToLlvm/Data.hs
@@ -0,0 +1,196 @@
+{-# LANGUAGE CPP #-}
+-- ----------------------------------------------------------------------------
+-- | Handle conversion of CmmData to LLVM code.
+--
+
+module GHC.CmmToLlvm.Data (
+        genLlvmData, genData
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import GHC.Llvm
+import GHC.CmmToLlvm.Base
+
+import GHC.Cmm.BlockId
+import GHC.Cmm.CLabel
+import GHC.Cmm
+import DynFlags
+import GHC.Platform
+
+import FastString
+import Outputable
+import qualified Data.ByteString as BS
+
+-- ----------------------------------------------------------------------------
+-- * Constants
+--
+
+-- | The string appended to a variable name to create its structure type alias
+structStr :: LMString
+structStr = fsLit "_struct"
+
+-- | The LLVM visibility of the label
+linkage :: CLabel -> LlvmLinkageType
+linkage lbl = if externallyVisibleCLabel lbl
+              then ExternallyVisible else Internal
+
+-- ----------------------------------------------------------------------------
+-- * Top level
+--
+
+-- | Pass a CmmStatic section to an equivalent Llvm code.
+genLlvmData :: (Section, RawCmmStatics) -> LlvmM LlvmData
+-- See note [emit-time elimination of static indirections] in CLabel.
+genLlvmData (_, RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
+  | lbl == mkIndStaticInfoLabel
+  , let labelInd (CmmLabelOff l _) = Just l
+        labelInd (CmmLabel l) = Just l
+        labelInd _ = Nothing
+  , Just ind' <- labelInd ind
+  , alias `mayRedirectTo` ind' = do
+    label <- strCLabel_llvm alias
+    label' <- strCLabel_llvm ind'
+    let link     = linkage alias
+        link'    = linkage ind'
+        -- the LLVM type we give the alias is an empty struct type
+        -- but it doesn't really matter, as the pointer is only
+        -- used for (bit/int)casting.
+        tyAlias  = LMAlias (label `appendFS` structStr, LMStructU [])
+
+        aliasDef = LMGlobalVar label tyAlias link Nothing Nothing Alias
+        -- we don't know the type of the indirectee here
+        indType  = panic "will be filled by 'aliasify', later"
+        orig     = LMStaticPointer $ LMGlobalVar label' indType link' Nothing Nothing Alias
+
+    pure ([LMGlobal aliasDef $ Just orig], [tyAlias])
+
+genLlvmData (sec, RawCmmStatics lbl xs) = do
+    label <- strCLabel_llvm lbl
+    static <- mapM genData xs
+    lmsec <- llvmSection sec
+    platform <- getLlvmPlatform
+    let types   = map getStatType static
+
+        strucTy = LMStruct types
+        tyAlias = LMAlias (label `appendFS` structStr, strucTy)
+
+        struct         = Just $ LMStaticStruc static tyAlias
+        link           = linkage lbl
+        align          = case sec of
+                            Section CString _ -> if (platformArch platform == ArchS390X)
+                                                    then Just 2 else Just 1
+                            _                 -> Nothing
+        const          = if isSecConstant sec then Constant else Global
+        varDef         = LMGlobalVar label tyAlias link lmsec align const
+        globDef        = LMGlobal varDef struct
+
+    return ([globDef], [tyAlias])
+
+-- | Format the section type part of a Cmm Section
+llvmSectionType :: Platform -> SectionType -> FastString
+llvmSectionType p t = case t of
+    Text                    -> fsLit ".text"
+    ReadOnlyData            -> case platformOS p of
+                                 OSMinGW32 -> fsLit ".rdata"
+                                 _         -> fsLit ".rodata"
+    RelocatableReadOnlyData -> case platformOS p of
+                                 OSMinGW32 -> fsLit ".rdata$rel.ro"
+                                 _         -> fsLit ".data.rel.ro"
+    ReadOnlyData16          -> case platformOS p of
+                                 OSMinGW32 -> fsLit ".rdata$cst16"
+                                 _         -> fsLit ".rodata.cst16"
+    Data                    -> fsLit ".data"
+    UninitialisedData       -> fsLit ".bss"
+    CString                 -> case platformOS p of
+                                 OSMinGW32 -> fsLit ".rdata$str"
+                                 _         -> fsLit ".rodata.str"
+    (OtherSection _)        -> panic "llvmSectionType: unknown section type"
+
+-- | Format a Cmm Section into a LLVM section name
+llvmSection :: Section -> LlvmM LMSection
+llvmSection (Section t suffix) = do
+  dflags <- getDynFlags
+  let splitSect = gopt Opt_SplitSections dflags
+      platform  = targetPlatform dflags
+  if not splitSect
+  then return Nothing
+  else do
+    lmsuffix <- strCLabel_llvm suffix
+    let result sep = Just (concatFS [llvmSectionType platform t
+                                    , fsLit sep, lmsuffix])
+    case platformOS platform of
+      OSMinGW32 -> return (result "$")
+      _         -> return (result ".")
+
+-- ----------------------------------------------------------------------------
+-- * Generate static data
+--
+
+-- | Handle static data
+genData :: CmmStatic -> LlvmM LlvmStatic
+
+genData (CmmString str) = do
+    let v  = map (\x -> LMStaticLit $ LMIntLit (fromIntegral x) i8)
+                 (BS.unpack str)
+        ve = v ++ [LMStaticLit $ LMIntLit 0 i8]
+    return $ LMStaticArray ve (LMArray (length ve) i8)
+
+genData (CmmUninitialised bytes)
+    = return $ LMUninitType (LMArray bytes i8)
+
+genData (CmmStaticLit lit)
+    = genStaticLit lit
+
+-- | Generate Llvm code for a static literal.
+--
+-- Will either generate the code or leave it unresolved if it is a 'CLabel'
+-- which isn't yet known.
+genStaticLit :: CmmLit -> LlvmM LlvmStatic
+genStaticLit (CmmInt i w)
+    = return $ LMStaticLit (LMIntLit i (LMInt $ widthInBits w))
+
+genStaticLit (CmmFloat r w)
+    = return $ LMStaticLit (LMFloatLit (fromRational r) (widthToLlvmFloat w))
+
+genStaticLit (CmmVec ls)
+    = do sls <- mapM toLlvmLit ls
+         return $ LMStaticLit (LMVectorLit sls)
+  where
+    toLlvmLit :: CmmLit -> LlvmM LlvmLit
+    toLlvmLit lit = do
+      slit <- genStaticLit lit
+      case slit of
+        LMStaticLit llvmLit -> return llvmLit
+        _ -> panic "genStaticLit"
+
+-- Leave unresolved, will fix later
+genStaticLit cmm@(CmmLabel l) = do
+    var <- getGlobalPtr =<< strCLabel_llvm l
+    dflags <- getDynFlags
+    let ptr = LMStaticPointer var
+        lmty = cmmToLlvmType $ cmmLitType dflags cmm
+    return $ LMPtoI ptr lmty
+
+genStaticLit (CmmLabelOff label off) = do
+    dflags <- getDynFlags
+    var <- genStaticLit (CmmLabel label)
+    let offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags)
+    return $ LMAdd var offset
+
+genStaticLit (CmmLabelDiffOff l1 l2 off w) = do
+    dflags <- getDynFlags
+    var1 <- genStaticLit (CmmLabel l1)
+    var2 <- genStaticLit (CmmLabel l2)
+    let var
+          | w == wordWidth dflags = LMSub var1 var2
+          | otherwise = LMTrunc (LMSub var1 var2) (widthToLlvmInt w)
+        offset = LMStaticLit $ LMIntLit (toInteger off) (LMInt $ widthInBits w)
+    return $ LMAdd var offset
+
+genStaticLit (CmmBlock b) = genStaticLit $ CmmLabel $ infoTblLbl b
+
+genStaticLit (CmmHighStackMark)
+    = panic "genStaticLit: CmmHighStackMark unsupported!"
diff --git a/compiler/GHC/CmmToLlvm/Mangler.hs b/compiler/GHC/CmmToLlvm/Mangler.hs
new file mode 100644
index 0000000000..1cdad2009f
--- /dev/null
+++ b/compiler/GHC/CmmToLlvm/Mangler.hs
@@ -0,0 +1,129 @@
+-- -----------------------------------------------------------------------------
+-- | GHC LLVM Mangler
+--
+-- This script processes the assembly produced by LLVM, rewriting all symbols
+-- of type @function to @object. This keeps them from going through the PLT,
+-- which would be bad due to tables-next-to-code. On x86_64,
+-- it also rewrites AVX instructions that require alignment to their
+-- unaligned counterparts, since the stack is only 16-byte aligned but these
+-- instructions require 32-byte alignment.
+--
+
+module GHC.CmmToLlvm.Mangler ( llvmFixupAsm ) where
+
+import GhcPrelude
+
+import DynFlags ( DynFlags, targetPlatform )
+import GHC.Platform ( platformArch, Arch(..) )
+import ErrUtils ( withTiming )
+import Outputable ( text )
+
+import Control.Exception
+import qualified Data.ByteString.Char8 as B
+import System.IO
+
+-- | Read in assembly file and process
+llvmFixupAsm :: DynFlags -> FilePath -> FilePath -> IO ()
+llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-}
+    withTiming dflags (text "LLVM Mangler") id $
+    withBinaryFile f1 ReadMode $ \r -> withBinaryFile f2 WriteMode $ \w -> do
+        go r w
+        hClose r
+        hClose w
+        return ()
+  where
+    go :: Handle -> Handle -> IO ()
+    go r w = do
+      e_l <- try $ B.hGetLine r ::IO (Either IOError B.ByteString)
+      let writeline a = B.hPutStrLn w (rewriteLine dflags rewrites a) >> go r w
+      case e_l of
+        Right l -> writeline l
+        Left _  -> return ()
+
+-- | These are the rewrites that the mangler will perform
+rewrites :: [Rewrite]
+rewrites = [rewriteSymType, rewriteAVX]
+
+type Rewrite = DynFlags -> B.ByteString -> Maybe B.ByteString
+
+-- | Rewrite a line of assembly source with the given rewrites,
+-- taking the first rewrite that applies.
+rewriteLine :: DynFlags -> [Rewrite] -> B.ByteString -> B.ByteString
+rewriteLine dflags rewrites l
+  -- We disable .subsections_via_symbols on darwin and ios, as the llvm code
+  -- gen uses prefix data for the info table.  This however does not prevent
+  -- llvm from generating .subsections_via_symbols, which in turn with
+  -- -dead_strip, strips the info tables, and therefore breaks ghc.
+  | isSubsectionsViaSymbols l =
+    (B.pack "## no .subsection_via_symbols for ghc. We need our info tables!")
+  | otherwise =
+    case firstJust $ map (\rewrite -> rewrite dflags rest) rewrites of
+      Nothing        -> l
+      Just rewritten -> B.concat $ [symbol, B.pack "\t", rewritten]
+  where
+    isSubsectionsViaSymbols = B.isPrefixOf (B.pack ".subsections_via_symbols")
+
+    (symbol, rest) = splitLine l
+
+    firstJust :: [Maybe a] -> Maybe a
+    firstJust (Just x:_) = Just x
+    firstJust []         = Nothing
+    firstJust (_:rest)   = firstJust rest
+
+-- | This rewrites @.type@ annotations of function symbols to @%object@.
+-- This is done as the linker can relocate @%functions@ through the
+-- Procedure Linking Table (PLT). This is bad since we expect that the
+-- info table will appear directly before the symbol's location. In the
+-- case that the PLT is used, this will be not an info table but instead
+-- some random PLT garbage.
+rewriteSymType :: Rewrite
+rewriteSymType _ l
+  | isType l  = Just $ rewrite '@' $ rewrite '%' l
+  | otherwise = Nothing
+  where
+    isType = B.isPrefixOf (B.pack ".type")
+
+    rewrite :: Char -> B.ByteString -> B.ByteString
+    rewrite prefix = replaceOnce funcType objType
+      where
+        funcType = prefix `B.cons` B.pack "function"
+        objType  = prefix `B.cons` B.pack "object"
+
+-- | This rewrites aligned AVX instructions to their unaligned counterparts on
+-- x86-64. This is necessary because the stack is not adequately aligned for
+-- aligned AVX spills, so LLVM would emit code that adjusts the stack pointer
+-- and disable tail call optimization. Both would be catastrophic here so GHC
+-- tells LLVM that the stack is 32-byte aligned (even though it isn't) and then
+-- rewrites the instructions in the mangler.
+rewriteAVX :: Rewrite
+rewriteAVX dflags s
+  | not isX86_64 = Nothing
+  | isVmovdqa s  = Just $ replaceOnce (B.pack "vmovdqa") (B.pack "vmovdqu") s
+  | isVmovap s   = Just $ replaceOnce (B.pack "vmovap") (B.pack "vmovup") s
+  | otherwise    = Nothing
+  where
+    isX86_64 = platformArch (targetPlatform dflags) == ArchX86_64
+    isVmovdqa = B.isPrefixOf (B.pack "vmovdqa")
+    isVmovap = B.isPrefixOf (B.pack "vmovap")
+
+-- | @replaceOnce match replace bs@ replaces the first occurrence of the
+-- substring @match@ in @bs@ with @replace@.
+replaceOnce :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString
+replaceOnce matchBS replaceOnceBS = loop
+  where
+    loop :: B.ByteString -> B.ByteString
+    loop cts =
+        case B.breakSubstring matchBS cts of
+          (hd,tl) | B.null tl -> hd
+                  | otherwise -> hd `B.append` replaceOnceBS `B.append`
+                                 B.drop (B.length matchBS) tl
+
+-- | This function splits a line of assembly code into the label and the
+-- rest of the code.
+splitLine :: B.ByteString -> (B.ByteString, B.ByteString)
+splitLine l = (symbol, B.dropWhile isSpace rest)
+  where
+    isSpace ' ' = True
+    isSpace '\t' = True
+    isSpace _ = False
+    (symbol, rest) = B.span (not . isSpace) l
diff --git a/compiler/GHC/CmmToLlvm/Ppr.hs b/compiler/GHC/CmmToLlvm/Ppr.hs
new file mode 100644
index 0000000000..45a8285ec6
--- /dev/null
+++ b/compiler/GHC/CmmToLlvm/Ppr.hs
@@ -0,0 +1,100 @@
+{-# LANGUAGE CPP #-}
+
+-- ----------------------------------------------------------------------------
+-- | Pretty print helpers for the LLVM Code generator.
+--
+module GHC.CmmToLlvm.Ppr (
+        pprLlvmCmmDecl, pprLlvmData, infoSection
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import GHC.Llvm
+import GHC.CmmToLlvm.Base
+import GHC.CmmToLlvm.Data
+
+import GHC.Cmm.CLabel
+import GHC.Cmm
+
+import FastString
+import Outputable
+import Unique
+
+-- ----------------------------------------------------------------------------
+-- * Top level
+--
+
+-- | Pretty print LLVM data code
+pprLlvmData :: LlvmData -> SDoc
+pprLlvmData (globals, types) =
+    let ppLlvmTys (LMAlias    a) = ppLlvmAlias a
+        ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f
+        ppLlvmTys _other         = empty
+
+        types'   = vcat $ map ppLlvmTys types
+        globals' = ppLlvmGlobals globals
+    in types' $+$ globals'
+
+
+-- | Pretty print LLVM code
+pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar])
+pprLlvmCmmDecl (CmmData _ lmdata)
+  = return (vcat $ map pprLlvmData lmdata, [])
+
+pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
+  = do let lbl = case mb_info of
+                     Nothing -> entry_lbl
+                     Just (RawCmmStatics info_lbl _) -> info_lbl
+           link = if externallyVisibleCLabel lbl
+                      then ExternallyVisible
+                      else Internal
+           lmblocks = map (\(BasicBlock id stmts) ->
+                                LlvmBlock (getUnique id) stmts) blks
+
+       funDec <- llvmFunSig live lbl link
+       dflags <- getDynFlags
+       let buildArg = fsLit . showSDoc dflags . ppPlainName
+           funArgs = map buildArg (llvmFunArgs dflags live)
+           funSect = llvmFunSection dflags (decName funDec)
+
+       -- generate the info table
+       prefix <- case mb_info of
+                     Nothing -> return Nothing
+                     Just (RawCmmStatics _ statics) -> do
+                       infoStatics <- mapM genData statics
+                       let infoTy = LMStruct $ map getStatType infoStatics
+                       return $ Just $ LMStaticStruc infoStatics infoTy
+
+
+       let fun = LlvmFunction funDec funArgs llvmStdFunAttrs funSect
+                              prefix lmblocks
+           name = decName $ funcDecl fun
+           defName = llvmDefLabel name
+           funcDecl' = (funcDecl fun) { decName = defName }
+           fun' = fun { funcDecl = funcDecl' }
+           funTy = LMFunction funcDecl'
+           funVar = LMGlobalVar name
+                                (LMPointer funTy)
+                                link
+                                Nothing
+                                Nothing
+                                Alias
+           defVar = LMGlobalVar defName
+                                (LMPointer funTy)
+                                (funcLinkage funcDecl')
+                                (funcSect fun)
+                                (funcAlign funcDecl')
+                                Alias
+           alias = LMGlobal funVar
+                            (Just $ LMBitc (LMStaticPointer defVar)
+                                           i8Ptr)
+
+       return (ppLlvmGlobal alias $+$ ppLlvmFunction fun', [])
+
+
+-- | The section we are putting info tables and their entry code into, should
+-- be unique since we process the assembly pattern matching this.
+infoSection :: String
+infoSection = "X98A__STRIP,__me"
diff --git a/compiler/GHC/CmmToLlvm/Regs.hs b/compiler/GHC/CmmToLlvm/Regs.hs
new file mode 100644
index 0000000000..60c27c8f44
--- /dev/null
+++ b/compiler/GHC/CmmToLlvm/Regs.hs
@@ -0,0 +1,136 @@
+{-# LANGUAGE CPP #-}
+
+--------------------------------------------------------------------------------
+-- | Deal with Cmm registers
+--
+
+module GHC.CmmToLlvm.Regs (
+        lmGlobalRegArg, lmGlobalRegVar, alwaysLive,
+        stgTBAA, baseN, stackN, heapN, rxN, topN, tbaa, getTBAA
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import GHC.Llvm
+
+import GHC.Cmm.Expr
+import DynFlags
+import FastString
+import Outputable ( panic )
+import Unique
+
+-- | Get the LlvmVar function variable storing the real register
+lmGlobalRegVar :: DynFlags -> GlobalReg -> LlvmVar
+lmGlobalRegVar dflags = pVarLift . lmGlobalReg dflags "_Var"
+
+-- | Get the LlvmVar function argument storing the real register
+lmGlobalRegArg :: DynFlags -> GlobalReg -> LlvmVar
+lmGlobalRegArg dflags = lmGlobalReg dflags "_Arg"
+
+{- Need to make sure the names here can't conflict with the unique generated
+   names. Uniques generated names containing only base62 chars. So using say
+   the '_' char guarantees this.
+-}
+lmGlobalReg :: DynFlags -> String -> GlobalReg -> LlvmVar
+lmGlobalReg dflags suf reg
+  = case reg of
+        BaseReg        -> ptrGlobal $ "Base" ++ suf
+        Sp             -> ptrGlobal $ "Sp" ++ suf
+        Hp             -> ptrGlobal $ "Hp" ++ suf
+        VanillaReg 1 _ -> wordGlobal $ "R1" ++ suf
+        VanillaReg 2 _ -> wordGlobal $ "R2" ++ suf
+        VanillaReg 3 _ -> wordGlobal $ "R3" ++ suf
+        VanillaReg 4 _ -> wordGlobal $ "R4" ++ suf
+        VanillaReg 5 _ -> wordGlobal $ "R5" ++ suf
+        VanillaReg 6 _ -> wordGlobal $ "R6" ++ suf
+        VanillaReg 7 _ -> wordGlobal $ "R7" ++ suf
+        VanillaReg 8 _ -> wordGlobal $ "R8" ++ suf
+        SpLim          -> wordGlobal $ "SpLim" ++ suf
+        FloatReg 1     -> floatGlobal $"F1" ++ suf
+        FloatReg 2     -> floatGlobal $"F2" ++ suf
+        FloatReg 3     -> floatGlobal $"F3" ++ suf
+        FloatReg 4     -> floatGlobal $"F4" ++ suf
+        FloatReg 5     -> floatGlobal $"F5" ++ suf
+        FloatReg 6     -> floatGlobal $"F6" ++ suf
+        DoubleReg 1    -> doubleGlobal $ "D1" ++ suf
+        DoubleReg 2    -> doubleGlobal $ "D2" ++ suf
+        DoubleReg 3    -> doubleGlobal $ "D3" ++ suf
+        DoubleReg 4    -> doubleGlobal $ "D4" ++ suf
+        DoubleReg 5    -> doubleGlobal $ "D5" ++ suf
+        DoubleReg 6    -> doubleGlobal $ "D6" ++ suf
+        XmmReg 1       -> xmmGlobal $ "XMM1" ++ suf
+        XmmReg 2       -> xmmGlobal $ "XMM2" ++ suf
+        XmmReg 3       -> xmmGlobal $ "XMM3" ++ suf
+        XmmReg 4       -> xmmGlobal $ "XMM4" ++ suf
+        XmmReg 5       -> xmmGlobal $ "XMM5" ++ suf
+        XmmReg 6       -> xmmGlobal $ "XMM6" ++ suf
+        YmmReg 1       -> ymmGlobal $ "YMM1" ++ suf
+        YmmReg 2       -> ymmGlobal $ "YMM2" ++ suf
+        YmmReg 3       -> ymmGlobal $ "YMM3" ++ suf
+        YmmReg 4       -> ymmGlobal $ "YMM4" ++ suf
+        YmmReg 5       -> ymmGlobal $ "YMM5" ++ suf
+        YmmReg 6       -> ymmGlobal $ "YMM6" ++ suf
+        ZmmReg 1       -> zmmGlobal $ "ZMM1" ++ suf
+        ZmmReg 2       -> zmmGlobal $ "ZMM2" ++ suf
+        ZmmReg 3       -> zmmGlobal $ "ZMM3" ++ suf
+        ZmmReg 4       -> zmmGlobal $ "ZMM4" ++ suf
+        ZmmReg 5       -> zmmGlobal $ "ZMM5" ++ suf
+        ZmmReg 6       -> zmmGlobal $ "ZMM6" ++ suf
+        MachSp         -> wordGlobal $ "MachSp" ++ suf
+        _other         -> panic $ "GHC.CmmToLlvm.Reg: GlobalReg (" ++ (show reg)
+                                ++ ") not supported!"
+        -- LongReg, HpLim, CCSS, CurrentTSO, CurrentNusery, HpAlloc
+        -- EagerBlackholeInfo, GCEnter1, GCFun, BaseReg, PicBaseReg
+    where
+        wordGlobal   name = LMNLocalVar (fsLit name) (llvmWord dflags)
+        ptrGlobal    name = LMNLocalVar (fsLit name) (llvmWordPtr dflags)
+        floatGlobal  name = LMNLocalVar (fsLit name) LMFloat
+        doubleGlobal name = LMNLocalVar (fsLit name) LMDouble
+        xmmGlobal    name = LMNLocalVar (fsLit name) (LMVector 4 (LMInt 32))
+        ymmGlobal    name = LMNLocalVar (fsLit name) (LMVector 8 (LMInt 32))
+        zmmGlobal    name = LMNLocalVar (fsLit name) (LMVector 16 (LMInt 32))
+
+-- | A list of STG Registers that should always be considered alive
+alwaysLive :: [GlobalReg]
+alwaysLive = [BaseReg, Sp, Hp, SpLim, HpLim, node]
+
+-- | STG Type Based Alias Analysis hierarchy
+stgTBAA :: [(Unique, LMString, Maybe Unique)]
+stgTBAA
+  = [ (rootN,  fsLit "root",   Nothing)
+    , (topN,   fsLit "top",   Just rootN)
+    , (stackN, fsLit "stack", Just topN)
+    , (heapN,  fsLit "heap",  Just topN)
+    , (rxN,    fsLit "rx",    Just heapN)
+    , (baseN,  fsLit "base",  Just topN)
+    -- FIX: Not 100% sure if this hierarchy is complete.  I think the big thing
+    -- is Sp is never aliased, so might want to change the hierarchy to have Sp
+    -- on its own branch that is never aliased (e.g never use top as a TBAA
+    -- node).
+    ]
+
+-- | Id values
+-- The `rootN` node is the root (there can be more than one) of the TBAA
+-- hierarchy and as of LLVM 4.0 should *only* be referenced by other nodes. It
+-- should never occur in any LLVM instruction statement.
+rootN, topN, stackN, heapN, rxN, baseN :: Unique
+rootN  = getUnique (fsLit "GHC.CmmToLlvm.Regs.rootN")
+topN   = getUnique (fsLit "GHC.CmmToLlvm.Regs.topN")
+stackN = getUnique (fsLit "GHC.CmmToLlvm.Regs.stackN")
+heapN  = getUnique (fsLit "GHC.CmmToLlvm.Regs.heapN")
+rxN    = getUnique (fsLit "GHC.CmmToLlvm.Regs.rxN")
+baseN  = getUnique (fsLit "GHC.CmmToLlvm.Regs.baseN")
+
+-- | The TBAA metadata identifier
+tbaa :: LMString
+tbaa = fsLit "tbaa"
+
+-- | Get the correct TBAA metadata information for this register type
+getTBAA :: GlobalReg -> Unique
+getTBAA BaseReg          = baseN
+getTBAA Sp               = stackN
+getTBAA Hp               = heapN
+getTBAA (VanillaReg _ _) = rxN
+getTBAA _                = topN