Merge branch 'master' of ssh://darcs.haskell.org/srv/darcs/ghc

4 files changed, 66 insertions, 51 deletions

diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index 86fab77ad9..849e40d203 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -7,6 +7,7 @@
 module LlvmCodeGen.Base (
 
         LlvmCmmDecl, LlvmBasicBlock,
+        LiveGlobalRegs,
         LlvmUnresData, LlvmData, UnresLabel, UnresStatic,
 
         LlvmVersion, defaultLlvmVersion, minSupportLlvmVersion,
@@ -46,6 +47,9 @@ import Unique
 type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe CmmStatics) (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])
@@ -88,29 +92,29 @@ llvmGhcCC dflags
  | otherwise                                      = CC_Ncc 10
 
 -- | Llvm Function type for Cmm function
-llvmFunTy :: DynFlags -> LlvmType
-llvmFunTy dflags = LMFunction $ llvmFunSig' dflags (fsLit "a") ExternallyVisible
+llvmFunTy :: DynFlags -> LiveGlobalRegs -> LlvmType
+llvmFunTy dflags live = LMFunction $ llvmFunSig' dflags live (fsLit "a") ExternallyVisible
 
 -- | Llvm Function signature
-llvmFunSig :: LlvmEnv -> CLabel -> LlvmLinkageType -> LlvmFunctionDecl
-llvmFunSig env lbl link
-    = llvmFunSig' (getDflags env) (strCLabel_llvm env lbl) link
+llvmFunSig :: LlvmEnv -> LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LlvmFunctionDecl
+llvmFunSig env live lbl link
+    = llvmFunSig' (getDflags env) live (strCLabel_llvm env lbl) link
 
-llvmFunSig' :: DynFlags -> LMString -> LlvmLinkageType -> LlvmFunctionDecl
-llvmFunSig' dflags lbl link
+llvmFunSig' :: DynFlags -> LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmFunctionDecl
+llvmFunSig' dflags live lbl link
   = let toParams x | isPointer x = (x, [NoAlias, NoCapture])
                    | otherwise   = (x, [])
     in LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs
-                        (map (toParams . getVarType) (llvmFunArgs dflags))
+                        (map (toParams . getVarType) (llvmFunArgs dflags live))
                         (llvmFunAlign dflags)
 
 -- | Create a Haskell function in LLVM.
-mkLlvmFunc :: LlvmEnv -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks
+mkLlvmFunc :: LlvmEnv -> LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks
            -> LlvmFunction
-mkLlvmFunc env lbl link sec blks
+mkLlvmFunc env live lbl link sec blks
   = let dflags = getDflags env
-        funDec = llvmFunSig env lbl link
-        funArgs = map (fsLit . getPlainName) (llvmFunArgs dflags)
+        funDec = llvmFunSig env live lbl link
+        funArgs = map (fsLit . getPlainName) (llvmFunArgs dflags live)
     in LlvmFunction funDec funArgs llvmStdFunAttrs sec blks
 
 -- | Alignment to use for functions
@@ -122,9 +126,15 @@ llvmInfAlign :: DynFlags -> LMAlign
 llvmInfAlign dflags = Just (wORD_SIZE dflags)
 
 -- | A Function's arguments
-llvmFunArgs :: DynFlags -> [LlvmVar]
-llvmFunArgs dflags = map (lmGlobalRegArg dflags) (activeStgRegs platform)
+llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar]
+llvmFunArgs dflags live =
+    map (lmGlobalRegArg dflags) (filter isPassed (activeStgRegs platform))
     where platform = targetPlatform dflags
+          isLive r = not (isFloat r) || r `elem` alwaysLive || r `elem` live
+          isPassed r = not (isFloat r) || isLive r
+          isFloat (FloatReg _)  = True
+          isFloat (DoubleReg _) = True
+          isFloat _             = False
 
 -- | Llvm standard fun attributes
 llvmStdFunAttrs :: [LlvmFuncAttr]
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 73cd98f63a..d62fbf4397 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -37,10 +37,10 @@ type LlvmStatements = OrdList LlvmStatement
 -- | Top-level of the LLVM proc Code generator
 --
 genLlvmProc :: LlvmEnv -> RawCmmDecl -> UniqSM (LlvmEnv, [LlvmCmmDecl])
-genLlvmProc env proc0@(CmmProc _ lbl (ListGraph blocks)) = do
-    (env', lmblocks, lmdata) <- basicBlocksCodeGen env blocks ([], [])
+genLlvmProc env proc0@(CmmProc _ lbl live (ListGraph blocks)) = do
+    (env', lmblocks, lmdata) <- basicBlocksCodeGen env live blocks ([], [])
     let info = topInfoTable proc0
-        proc = CmmProc info lbl (ListGraph lmblocks)
+        proc = CmmProc info lbl live (ListGraph lmblocks)
     return (env', proc:lmdata)
 
 genLlvmProc _ _ = panic "genLlvmProc: case that shouldn't reach here!"
@@ -51,22 +51,23 @@ genLlvmProc _ _ = panic "genLlvmProc: case that shouldn't reach here!"
 
 -- | Generate code for a list of blocks that make up a complete procedure.
 basicBlocksCodeGen :: LlvmEnv
+                   -> LiveGlobalRegs
                    -> [CmmBasicBlock]
                    -> ( [LlvmBasicBlock] , [LlvmCmmDecl] )
                    -> UniqSM (LlvmEnv, [LlvmBasicBlock] , [LlvmCmmDecl] )
-basicBlocksCodeGen env ([]) (blocks, tops)
+basicBlocksCodeGen env live ([]) (blocks, tops)
   = do let dflags = getDflags env
        let (blocks', allocs) = mapAndUnzip dominateAllocs blocks
        let allocs' = concat allocs
        let ((BasicBlock id fstmts):rblks) = blocks'
-       let fblocks = (BasicBlock id $ funPrologue dflags ++ allocs' ++ fstmts):rblks
+       let fblocks = (BasicBlock id $ funPrologue dflags live ++ allocs' ++ fstmts):rblks
        return (env, fblocks, tops)
 
-basicBlocksCodeGen env (block:blocks) (lblocks', ltops')
+basicBlocksCodeGen env live (block:blocks) (lblocks', ltops')
   = do (env', lb, lt) <- basicBlockCodeGen env block
        let lblocks = lblocks' ++ lb
        let ltops   = ltops' ++ lt
-       basicBlocksCodeGen env' blocks (lblocks, ltops)
+       basicBlocksCodeGen env' live blocks (lblocks, ltops)
 
 
 -- | Allocations need to be extracted so they can be moved to the entry
@@ -510,11 +511,11 @@ cmmPrimOpFunctions env mop
                           ++ " not supported here")
 
 -- | Tail function calls
-genJump :: LlvmEnv -> CmmExpr -> Maybe [GlobalReg] -> UniqSM StmtData
+genJump :: LlvmEnv -> CmmExpr -> [GlobalReg] -> UniqSM StmtData
 
 -- Call to known function
 genJump env (CmmLit (CmmLabel lbl)) live = do
-    (env', vf, stmts, top) <- getHsFunc env lbl
+    (env', vf, stmts, top) <- getHsFunc env live lbl
     (stgRegs, stgStmts) <- funEpilogue env live
     let s1  = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs
     let s2  = Return Nothing
@@ -523,7 +524,7 @@ genJump env (CmmLit (CmmLabel lbl)) live = do
 
 -- Call to unknown function / address
 genJump env expr live = do
-    let fty = llvmFunTy (getDflags env)
+    let fty = llvmFunTy (getDflags env) live
     (env', vf, stmts, top) <- exprToVar env expr
 
     let cast = case getVarType vf of
@@ -1246,29 +1247,40 @@ genLit _ CmmHighStackMark
 --
 
 -- | Function prologue. Load STG arguments into variables for function.
-funPrologue :: DynFlags -> [LlvmStatement]
-funPrologue dflags = concat $ map getReg $ activeStgRegs platform
+funPrologue :: DynFlags -> LiveGlobalRegs -> [LlvmStatement]
+funPrologue dflags live = concat $ map getReg $ activeStgRegs platform
     where platform = targetPlatform dflags
+          isLive r = r `elem` alwaysLive || r `elem` live
           getReg rr =
             let reg   = lmGlobalRegVar dflags rr
                 arg   = lmGlobalRegArg dflags rr
+                ty    = (pLower . getVarType) reg
+                trash = LMLitVar $ LMUndefLit ty
                 alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1
-            in [alloc, Store arg reg]
+            in 
+              if isLive rr
+              then [alloc, Store arg reg]
+              else [alloc, Store trash reg]
 
 
 -- | Function epilogue. Load STG variables to use as argument for call.
 -- STG Liveness optimisation done here.
-funEpilogue :: LlvmEnv -> Maybe [GlobalReg] -> UniqSM ([LlvmVar], LlvmStatements)
+funEpilogue :: LlvmEnv -> LiveGlobalRegs -> UniqSM ([LlvmVar], LlvmStatements)
 
 -- Have information and liveness optimisation is enabled
-funEpilogue env (Just live) | gopt Opt_RegLiveness dflags = do
-    loads <- mapM loadExpr (activeStgRegs platform)
+funEpilogue env live = do
+    loads <- mapM loadExpr (filter isPassed (activeStgRegs platform))
     let (vars, stmts) = unzip loads
     return (vars, concatOL stmts)
   where
     dflags = getDflags env
     platform = targetPlatform dflags
-    loadExpr r | r `elem` alwaysLive || r `elem` live = do
+    isLive r = r `elem` alwaysLive || r `elem` live
+    isPassed r = not (isFloat r) || isLive r
+    isFloat (FloatReg _)  = True
+    isFloat (DoubleReg _) = True
+    isFloat _             = False
+    loadExpr r | isLive r = do
         let reg  = lmGlobalRegVar dflags r
         (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg
         return (v, unitOL s)
@@ -1276,19 +1288,6 @@ funEpilogue env (Just live) | gopt Opt_RegLiveness dflags = do
         let ty = (pLower . getVarType $ lmGlobalRegVar dflags r)
         return (LMLitVar $ LMUndefLit ty, unitOL Nop)
 
--- don't do liveness optimisation
-funEpilogue env _ = do
-    loads <- mapM loadExpr (activeStgRegs platform)
-    let (vars, stmts) = unzip loads
-    return (vars, concatOL stmts)
-  where
-    dflags = getDflags env
-    platform = targetPlatform dflags
-    loadExpr r = do
-        let reg  = lmGlobalRegVar dflags r
-        (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg
-        return (v, unitOL s)
-
 
 -- | A serries of statements to trash all the STG registers.
 --
@@ -1317,8 +1316,8 @@ trashStmts dflags = concatOL $ map trashReg $ activeStgRegs platform
 --
 -- This is for Haskell functions, function type is assumed, so doesn't work
 -- with foreign functions.
-getHsFunc :: LlvmEnv -> CLabel -> UniqSM ExprData
-getHsFunc env lbl
+getHsFunc :: LlvmEnv -> LiveGlobalRegs -> CLabel -> UniqSM ExprData
+getHsFunc env live lbl
   = let dflags = getDflags env
         fn = strCLabel_llvm env lbl
         ty    = funLookup fn env
@@ -1332,13 +1331,13 @@ getHsFunc env lbl
         Just ty' -> do
             let fun = LMGlobalVar fn (pLift ty') ExternallyVisible
                             Nothing Nothing False
-            (v1, s1) <- doExpr (pLift (llvmFunTy dflags)) $
-                            Cast LM_Bitcast fun (pLift (llvmFunTy dflags))
+            (v1, s1) <- doExpr (pLift (llvmFunTy dflags live)) $
+                            Cast LM_Bitcast fun (pLift (llvmFunTy dflags live))
             return (env, v1, unitOL s1, [])
 
         -- label not in module, create external reference
         Nothing  -> do
-            let ty' = LMFunction $ llvmFunSig env lbl ExternallyVisible
+            let ty' = LMFunction $ llvmFunSig env live lbl ExternallyVisible
             let fun = LMGlobalVar fn ty' ExternallyVisible Nothing Nothing False
             let top = CmmData Data [([],[ty'])]
             let env' = funInsert fn ty' env
diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
index c791e85a52..73632f5fd4 100644
--- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
@@ -83,7 +83,7 @@ pprLlvmCmmDecl :: LlvmEnv -> Int -> LlvmCmmDecl -> (SDoc, [LlvmVar])
 pprLlvmCmmDecl _ _ (CmmData _ lmdata)
   = (vcat $ map pprLlvmData lmdata, [])
 
-pprLlvmCmmDecl env count (CmmProc mb_info entry_lbl (ListGraph blks))
+pprLlvmCmmDecl env count (CmmProc mb_info entry_lbl live (ListGraph blks))
   = let (idoc, ivar) = case mb_info of
                         Nothing -> (empty, [])
                         Just (Statics info_lbl dat)
@@ -98,7 +98,7 @@ pprLlvmCmmDecl env count (CmmProc mb_info entry_lbl (ListGraph blks))
                       else Internal
             lmblocks = map (\(BasicBlock id stmts) ->
                                 LlvmBlock (getUnique id) stmts) blks
-            fun = mkLlvmFunc env lbl' link  sec' lmblocks
+            fun = mkLlvmFunc env live lbl' link  sec' lmblocks
         in ppLlvmFunction fun
     ), ivar)
 
diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs
index 49c900d5e0..e6cfcb2e18 100644
--- a/compiler/llvmGen/LlvmCodeGen/Regs.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs
@@ -47,8 +47,14 @@ lmGlobalReg dflags suf reg
         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
         _other         -> panic $ "LlvmCodeGen.Reg: GlobalReg (" ++ (show reg)
                                 ++ ") not supported!"
         -- LongReg, HpLim, CCSS, CurrentTSO, CurrentNusery, HpAlloc