[commit: ghc] wip/kavon-nosplit-llvm: fixed up funPrologue and doReturnTo, though the latter produces verbose LLVM right now (6aab359)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/kavon-nosplit-llvm
Link       : http://ghc.haskell.org/trac/ghc/changeset/6aab3593333693d57ea38fe5fd58a4b7253adf67/ghc

>---------------------------------------------------------------

commit 6aab3593333693d57ea38fe5fd58a4b7253adf67
Author: Kavon Farvardin <kavon at farvard.in>
Date:   Thu May 18 15:08:13 2017 +0100

    fixed up funPrologue and doReturnTo, though the latter produces verbose LLVM right now


>---------------------------------------------------------------

6aab3593333693d57ea38fe5fd58a4b7253adf67
 compiler/llvmGen/LlvmCodeGen/Base.hs    | 17 +++++++---
 compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 59 ++++++++++++++++++---------------
 2 files changed, 44 insertions(+), 32 deletions(-)

diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index 7369cdb..ac49c0c 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -26,7 +26,7 @@ module LlvmCodeGen.Base (
 
         cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
         llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
-        llvmPtrBits, tysToParams, llvmFunSection,
+        llvmPtrBits, tysToParams, llvmFunSection, llvmStdConv,
 
         strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm,
         getGlobalPtr, generateExternDecls,
@@ -145,10 +145,11 @@ 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 (activeStgRegs platform))
+-- | The full set of Cmm registers passed to a function, in the correct order,
+--   given the live argument registers. This is used for both call and return.
+llvmStdConv :: DynFlags -> LiveGlobalRegs -> [GlobalReg]
+llvmStdConv dflags live = 
+    filter isPassed (activeStgRegs platform)
     where platform = targetPlatform dflags
           isLive r = not (isSSE r) || r `elem` alwaysLive || r `elem` live
           isPassed r = not (isSSE r) || isLive r
@@ -159,6 +160,12 @@ llvmFunArgs dflags live =
           isSSE (ZmmReg _)    = True
           isSSE _             = False
 
+-- | A Function's arguments
+llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar]
+llvmFunArgs dflags live =
+    map (lmGlobalRegArg dflags) (llvmStdConv dflags live)
+    
+
 -- | Llvm standard fun attributes
 llvmStdFunAttrs :: [LlvmFuncAttr]
 llvmStdFunAttrs = [NoUnwind]
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index aa0baef..13f7258 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -40,7 +40,7 @@ import qualified Data.Semigroup as Semigroup
 #endif
 import Data.List ( nub )
 import Data.Maybe ( catMaybes )
-import Control.Monad ( foldM, filterM )
+import Control.Monad ( foldM )
 
 type Atomic = Bool
 type LlvmStatements = OrdList LlvmStatement
@@ -818,29 +818,30 @@ genNativeCall _ expr live = do
             
             
 doReturnTo :: ContInfo -> LlvmVar -> LlvmM LlvmStatements
-doReturnTo (retl, _, retRegs) llRetV = do
-    -- find the struct fields corresponding to each live register 
-    -- according to the return convention.
-    platform <- getDynFlag targetPlatform
-    let regOrder = activeStgRegs platform
-        needsUpdate r = do
-             hasAlloca <- checkStackReg r
-             return (hasAlloca && (r `elem` alwaysLive || r `elem` retRegs))
-    
-    -- liveRegs is ordered by the return convention.
-    liveRegs <- filterM needsUpdate regOrder
-        
-        -- for each reg, we will add to the stms an extract
-        -- from llRetV, followed by a store to the alloca backing the reg
-    let extract (i, stms) reg = do
-            regAlloca <- getCmmReg $ CmmGlobal reg
-            let (LMPointer ty) = getVarType regAlloca
-            (newVal, s1) <- doExpr ty $ ExtractV llRetV i
-            let s2 = Store newVal regAlloca
-            return (i+1, stms `snocOL` s1 `snocOL` s2)
-    
-    -- update the allocas that correspond to the regs
-    (_, updateStms) <- foldM extract (0, nilOL) liveRegs
+doReturnTo (retl, _, retArgs) llRetV = do
+    dflags <- getDynFlags
+    let 
+        -- TODO(kavon): seems retRegs includes all of the Rx registers
+        -- even if they are not live. LLVM will clean that up but it'd be nice if
+        -- we could avoid emitting those extracts by slimming down the retRegs list.
+        
+        -- retRegs is a subset of allRegs, with the _same relative ordering_
+        retRegs = llvmStdConv dflags retArgs
+        allRegs = activeStgRegs $ targetPlatform dflags
+        
+        extract (z@(_, [], _)) _ = return z -- no more slots needed
+        extract (i, x:xs, stms) reg
+            | x /= reg = -- skip if x doesn't go in this slot
+                return (i+1, x:xs, stms) 
+            | otherwise = do
+                regAlloca <- getCmmReg $ CmmGlobal reg
+                let (LMPointer ty) = getVarType regAlloca
+                (newVal, s1) <- doExpr ty $ ExtractV llRetV i
+                let s2 = Store newVal regAlloca
+                return (i+1, xs, stms `snocOL` s1 `snocOL` s2)
+    
+    -- update the allocas that correspond to the retRegs
+    (_, [], updateStms) <- foldM extract (0, retRegs, nilOL) allRegs
     let br = Branch $ blockIdToLlvm retl
     return (updateStms `snocOL` br)
 
@@ -1753,7 +1754,7 @@ genLit _ CmmHighStackMark
 -- once we're done.
 funPrologue :: LiveGlobalRegs -> [CmmBlock] -> LlvmM StmtData
 funPrologue live cmmBlocks = do
-
+  dflags <- getDynFlags
   trash <- getTrashRegs
   let getAssignedRegs :: CmmNode O O -> [CmmReg]
       getAssignedRegs (CmmAssign reg _)  = [reg]
@@ -1762,10 +1763,14 @@ funPrologue live cmmBlocks = do
       getAssignedRegs (CmmUnsafeForeignCall _ rs _) = map CmmGlobal trash ++ map CmmLocal rs
       getAssignedRegs _                  = []
       getRegsBlock (_, body, _)          = concatMap getAssignedRegs $ blockToList body
-      assignedRegs = nub $ concatMap (getRegsBlock . blockSplit) cmmBlocks
+      
+      -- because we emit non-tail calls, the pinned registers such as the BasePtr is
+      -- returned and we need to use an alloca for it. -kavon
+      conventionRegs = map CmmGlobal $ llvmStdConv dflags live
+      
+      assignedRegs = nub $ concatMap (getRegsBlock . blockSplit) cmmBlocks ++ conventionRegs
       isLive r     = r `elem` alwaysLive || r `elem` live
   
-  dflags <- getDynFlags
   stmtss <- flip mapM assignedRegs $ \reg ->
     case reg of
       CmmLocal (LocalReg un _) -> do