Permalink
Browse files

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

  • Loading branch information...
igfoo committed Aug 8, 2012
2 parents c2a532a + 1edad87 commit 415598b232f6664fb4da8321f5f578405af245de
@@ -22,7 +22,6 @@ import Constants
import qualified Data.List as L
import DynFlags
import Outputable
-import Platform
-- Calculate the 'GlobalReg' or stack locations for function call
-- parameters as used by the Cmm calling convention.
@@ -111,34 +110,19 @@ type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs.
-- We take these register supplies from the *real* registers, i.e. those
-- that are guaranteed to map to machine registers.
-vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: DynFlags -> [Int]
-vanillaRegNos dflags
- | platformUnregisterised (targetPlatform dflags) = []
- | otherwise = regList mAX_Real_Vanilla_REG
-floatRegNos dflags
- | platformUnregisterised (targetPlatform dflags) = []
- | otherwise = regList mAX_Real_Float_REG
-doubleRegNos dflags
- | platformUnregisterised (targetPlatform dflags) = []
- | otherwise = regList mAX_Real_Double_REG
-longRegNos dflags
- | platformUnregisterised (targetPlatform dflags) = []
- | otherwise = regList mAX_Real_Long_REG
-
---
getRegsWithoutNode, getRegsWithNode :: DynFlags -> AvailRegs
-getRegsWithoutNode dflags =
- (filter (\r -> r VGcPtr /= node) intRegs,
- map FloatReg (floatRegNos dflags),
- map DoubleReg (doubleRegNos dflags),
- map LongReg (longRegNos dflags))
- where intRegs = map VanillaReg (vanillaRegNos dflags)
-getRegsWithNode dflags =
- (intRegs,
- map FloatReg (floatRegNos dflags),
- map DoubleReg (doubleRegNos dflags),
- map LongReg (longRegNos dflags))
- where intRegs = map VanillaReg (vanillaRegNos dflags)
+getRegsWithoutNode _dflags =
+ ( filter (\r -> r VGcPtr /= node) realVanillaRegs
+ , realFloatRegs
+ , realDoubleRegs
+ , realLongRegs )
+
+-- getRegsWithNode uses R1/node even if it isn't a register
+getRegsWithNode _dflags =
+ ( if null realVanillaRegs then [VanillaReg 1] else realVanillaRegs
+ , realFloatRegs
+ , realDoubleRegs
+ , realLongRegs )
allFloatRegs, allDoubleRegs, allLongRegs :: [GlobalReg]
allVanillaRegs :: [VGcPtr -> GlobalReg]
@@ -148,6 +132,14 @@ allFloatRegs = map FloatReg $ regList mAX_Float_REG
allDoubleRegs = map DoubleReg $ regList mAX_Double_REG
allLongRegs = map LongReg $ regList mAX_Long_REG
+realFloatRegs, realDoubleRegs, realLongRegs :: [GlobalReg]
+realVanillaRegs :: [VGcPtr -> GlobalReg]
+
+realVanillaRegs = map VanillaReg $ regList mAX_Real_Vanilla_REG
+realFloatRegs = map FloatReg $ regList mAX_Real_Float_REG
+realDoubleRegs = map DoubleReg $ regList mAX_Real_Double_REG
+realLongRegs = map LongReg $ regList mAX_Real_Long_REG
+
regList :: Int -> [Int]
regList n = [1 .. n]
View
@@ -345,9 +345,11 @@ instance Eq GlobalReg where
SpLim == SpLim = True
Hp == Hp = True
HpLim == HpLim = True
+ CCCS == CCCS = True
CurrentTSO == CurrentTSO = True
CurrentNursery == CurrentNursery = True
HpAlloc == HpAlloc = True
+ EagerBlackholeInfo == EagerBlackholeInfo = True
GCEnter1 == GCEnter1 = True
GCFun == GCFun = True
BaseReg == BaseReg = True
@@ -26,8 +26,6 @@ import Util
import DynFlags
import FastString
import Outputable
-import Data.Map (Map)
-import qualified Data.Map as Map
import qualified Data.Set as Set
import Control.Monad.Fix
import Data.Array as Array
@@ -485,12 +483,11 @@ spOffsetForCall current_sp cont_stack args
fixupStack :: StackMap -> StackMap -> [CmmNode O O]
fixupStack old_stack new_stack = concatMap move new_locs
where
- old_map :: Map LocalReg ByteOff
- old_map = Map.fromList (stackSlotRegs old_stack)
+ old_map = sm_regs old_stack
new_locs = stackSlotRegs new_stack
move (r,n)
- | Just m <- Map.lookup r old_map, n == m = []
+ | Just (_,m) <- lookupUFM old_map r, n == m = []
| otherwise = [CmmStore (CmmStackSlot Old n)
(CmmReg (CmmLocal r))]
View
@@ -13,6 +13,7 @@ module CmmLint (
import Hoopl
import Cmm
import CmmUtils
+import CmmLive
import PprCmm ()
import BlockId
import FastString
@@ -53,7 +54,10 @@ lintCmmDecl (CmmData {})
lintCmmGraph :: CmmGraph -> CmmLint ()
-lintCmmGraph g = mapM_ (lintCmmBlock labels) blocks
+lintCmmGraph g = cmmLiveness g `seq` mapM_ (lintCmmBlock labels) blocks
+ -- cmmLiveness throws an error if there are registers
+ -- live on entry to the graph (i.e. undefined
+ -- variables)
where
blocks = toBlockList g
labels = setFromList (map entryLabel blocks)
@@ -274,12 +274,6 @@ maybeInvertComparison op
MO_S_Gt r -> Just (MO_S_Le r)
MO_S_Le r -> Just (MO_S_Gt r)
MO_S_Ge r -> Just (MO_S_Lt r)
- MO_F_Eq r -> Just (MO_F_Ne r)
- MO_F_Ne r -> Just (MO_F_Eq r)
- MO_F_Ge r -> Just (MO_F_Le r)
- MO_F_Le r -> Just (MO_F_Ge r)
- MO_F_Gt r -> Just (MO_F_Lt r)
- MO_F_Lt r -> Just (MO_F_Gt r)
_other -> Nothing
-- ----------------------------------------------------------------------------
View
@@ -167,6 +167,7 @@ mkComment _ = nilOL
---------- Assignment and store
mkAssign :: CmmReg -> CmmExpr -> CmmAGraph
+mkAssign l (CmmReg r) | l == r = mkNop
mkAssign l r = mkMiddle $ CmmAssign l r
mkStore :: CmmExpr -> CmmExpr -> CmmAGraph
@@ -104,7 +104,8 @@ cgBind :: StgBinding -> FCode ()
cgBind (StgNonRec name rhs)
= do { ((info, init), body) <- getCodeR $ cgRhs name rhs
; addBindC (cg_id info) info
- ; emit (init <*> body) }
+ ; emit (body <*> init) }
+ -- init cannot be used in body, so slightly better to sink it eagerly
cgBind (StgRec pairs)
= do { ((new_binds, inits), body) <- getCodeR $ fixC (\ new_binds_inits ->
@@ -311,11 +312,11 @@ mkRhsClosure _ bndr cc _ fvs upd_flag args body
; emit (mkComment $ mkFastString "calling allocDynClosure")
; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)
; let info_tbl = mkCmmInfo closure_info
- ; (tmp, init) <- allocDynClosure info_tbl lf_info use_cc blame_cc
+ ; hp_plus_n <- allocDynClosure info_tbl lf_info use_cc blame_cc
(map toVarArg fv_details)
-- RETURN
- ; regIdInfo bndr lf_info tmp init }
+ ; regIdInfo bndr lf_info hp_plus_n }
-- Use with care; if used inappropriately, it could break invariants.
stripNV :: NonVoid a -> a
@@ -349,11 +350,11 @@ cgStdThunk bndr _cc _bndr_info _body lf_info payload
-- BUILD THE OBJECT
; let info_tbl = mkCmmInfo closure_info
- ; (tmp, init) <- allocDynClosure info_tbl lf_info
+ ; hp_plus_n <- allocDynClosure info_tbl lf_info
use_cc blame_cc payload_w_offsets
-- RETURN
- ; regIdInfo bndr lf_info tmp init }
+ ; regIdInfo bndr lf_info hp_plus_n }
mkClosureLFInfo :: Id -- The binder
-> TopLevelFlag -- True of top level
@@ -394,16 +395,16 @@ closureCodeBody :: Bool -- whether this is a top-level binding
argSatisfactionCheck (by calling fetchAndReschedule).
There info if Node points to closure is available. -- HWL -}
-closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
- | length args == 0 -- No args i.e. thunk
+closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details
+ | arity == 0 -- No args i.e. thunk
= emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $
\(_, node, _) -> thunkCode cl_info fv_details cc node arity body
where
lf_info = closureLFInfo cl_info
info_tbl = mkCmmInfo cl_info
-closureCodeBody top_lvl bndr cl_info _cc args arity body fv_details
- = ASSERT( length args > 0 )
+closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
+ = -- Note: args may be [], if all args are Void
do { -- Allocate the global ticky counter,
-- and establish the ticky-counter
-- label for this block
@@ -417,7 +418,7 @@ closureCodeBody top_lvl bndr cl_info _cc args arity body fv_details
-- Emit the main entry code
; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args $
- \(offset, node, arg_regs) -> do
+ \(_offset, node, arg_regs) -> do
-- Emit slow-entry code (for entering a closure through a PAP)
{ mkSlowEntryCode cl_info arg_regs
@@ -426,11 +427,15 @@ closureCodeBody top_lvl bndr cl_info _cc args arity body fv_details
node_points = nodeMustPointToIt dflags lf_info
node' = if node_points then Just node else Nothing
; tickyEnterFun cl_info
+ ; enterCostCentreFun cc
+ (CmmMachOp mo_wordSub
+ [ CmmReg nodeReg
+ , CmmLit (mkIntCLit (funTag cl_info)) ])
; whenC node_points (ldvEnterClosure cl_info)
; granYield arg_regs node_points
-- Main payload
- ; entryHeapCheck cl_info offset node' arity arg_regs $ do
+ ; entryHeapCheck cl_info node' arity arg_regs $ do
{ fv_bindings <- mapM bind_fv fv_details
-- Load free vars out of closure *after*
-- heap check, to reduce live vars over check
@@ -463,7 +468,6 @@ mkSlowEntryCode :: ClosureInfo -> [LocalReg] -> FCode ()
-- If this function doesn't have a specialised ArgDescr, we need
-- to generate the function's arg bitmap and slow-entry code.
-- Here, we emit the slow-entry code.
-mkSlowEntryCode _ [] = panic "entering a closure with no arguments?"
mkSlowEntryCode cl_info arg_regs -- function closure is already in `Node'
| Just (_, ArgGen _) <- closureFunInfo cl_info
= do dflags <- getDynFlags
@@ -489,7 +493,7 @@ thunkCode cl_info fv_details _cc node arity body
; granThunk node_points
-- Heap overflow check
- ; entryHeapCheck cl_info 0 node' arity [] $ do
+ ; entryHeapCheck cl_info node' arity [] $ do
{ -- Overwrite with black hole if necessary
-- but *after* the heap-overflow check
; whenC (blackHoleOnEntry cl_info && node_points)
@@ -574,16 +578,15 @@ setupUpdate closure_info node body
lbl | bh = mkBHUpdInfoLabel
| otherwise = mkUpdInfoLabel
- pushUpdateFrame [CmmReg (CmmLocal node), mkLblExpr lbl] body
+ pushUpdateFrame lbl (CmmReg (CmmLocal node)) body
| otherwise -- A static closure
= do { tickyUpdateBhCaf closure_info
; if closureUpdReqd closure_info
then do -- Blackhole the (updatable) CAF:
- { upd_closure <- link_caf True
- ; pushUpdateFrame [upd_closure,
- mkLblExpr mkBHUpdInfoLabel] body }
+ { upd_closure <- link_caf node True
+ ; pushUpdateFrame mkBHUpdInfoLabel upd_closure body }
else do {tickyUpdateFrameOmitted; body}
}
@@ -593,16 +596,21 @@ setupUpdate closure_info node body
-- Push the update frame on the stack in the Entry area,
-- leaving room for the return address that is already
-- at the old end of the area.
-pushUpdateFrame :: [CmmExpr] -> FCode () -> FCode ()
-pushUpdateFrame es body
- = do -- [EZY] I'm not sure if we need to special-case for BH too
+--
+pushUpdateFrame :: CLabel -> CmmExpr -> FCode () -> FCode ()
+pushUpdateFrame lbl updatee body
+ = do
updfr <- getUpdFrameOff
- offset <- foldM push updfr es
- withUpdFrameOff offset body
- where push off e =
- do emitStore (CmmStackSlot Old base) e
- return base
- where base = off + widthInBytes (cmmExprWidth e)
+ dflags <- getDynFlags
+ let
+ hdr = fixedHdrSize dflags * wORD_SIZE
+ frame = updfr + hdr + sIZEOF_StgUpdateFrame_NoHdr
+ off_updatee = hdr + oFFSET_StgUpdateFrame_updatee
+ --
+ emitStore (CmmStackSlot Old frame) (mkLblExpr lbl)
+ emitStore (CmmStackSlot Old (frame - off_updatee)) updatee
+ initUpdFrameProf frame
+ withUpdFrameOff frame body
-----------------------------------------------------------------------------
-- Entering a CAF
@@ -637,15 +645,16 @@ pushUpdateFrame es body
-- be closer together, and the compiler wouldn't need to know
-- about off_indirectee etc.
-link_caf :: Bool -- True <=> updatable, False <=> single-entry
+link_caf :: LocalReg -- pointer to the closure
+ -> Bool -- True <=> updatable, False <=> single-entry
-> FCode CmmExpr -- Returns amode for closure to be updated
-- To update a CAF we must allocate a black hole, link the CAF onto the
-- CAF list, then update the CAF to point to the fresh black hole.
-- This function returns the address of the black hole, so it can be
-- updated with the new value when available. The reason for all of this
-- is that we only want to update dynamic heap objects, not static ones,
-- so that generational GC is easier.
-link_caf _is_upd = do
+link_caf node _is_upd = do
{ dflags <- getDynFlags
-- Alloc black hole specifying CC_HDR(Node) as the cost centre
; let use_cc = costCentreFrom (CmmReg nodeReg)
@@ -668,9 +677,9 @@ link_caf _is_upd = do
; ret <- newTemp bWord
; emitRtsCallGen [(ret,NoHint)] rtsPackageId (fsLit "newCAF")
[ (CmmReg (CmmGlobal BaseReg), AddrHint),
- (CmmReg nodeReg, AddrHint),
+ (CmmReg (CmmLocal node), AddrHint),
(hp_rel, AddrHint) ]
- (Just [node]) False
+ False
-- node is live, so save it.
-- see Note [atomic CAF entry] in rts/sm/Storage.c
@@ -680,7 +689,7 @@ link_caf _is_upd = do
-- re-enter R1. Doing this directly is slightly dodgy; we're
-- assuming lots of things, like the stack pointer hasn't
-- moved since we entered the CAF.
- (let target = entryCode dflags (closureInfoPtr (CmmReg nodeReg)) in
+ (let target = entryCode dflags (closureInfoPtr (CmmReg (CmmLocal node))) in
mkJump dflags target [] updfr)
; return hp_rel }
@@ -210,9 +210,9 @@ buildDynCon' dflags _ binder ccs con args
-- No void args in args_w_offsets
nonptr_wds = tot_wds - ptr_wds
info_tbl = mkDataConInfoTable dflags con False ptr_wds nonptr_wds
- ; (tmp, init) <- allocDynClosure info_tbl lf_info
+ ; hp_plus_n <- allocDynClosure info_tbl lf_info
use_cc blame_cc args_w_offsets
- ; regIdInfo binder lf_info tmp init }
+ ; regIdInfo binder lf_info hp_plus_n }
where
lf_info = mkConLFInfo con
@@ -44,7 +44,7 @@ import CLabel
import BlockId
import CmmExpr
import CmmUtils
-import MkGraph (CmmAGraph, mkAssign, (<*>))
+import MkGraph (CmmAGraph, mkAssign)
import FastString
import Id
import VarEnv
@@ -103,13 +103,12 @@ lneIdInfo id regs
-- register, and store a plain register in the CgIdInfo. We allocate
-- a new register in order to keep single-assignment and help out the
-- inliner. -- EZY
-regIdInfo :: Id -> LambdaFormInfo -> LocalReg -> CmmAGraph -> FCode (CgIdInfo, CmmAGraph)
-regIdInfo id lf_info reg init
- = do { reg' <- newTemp (localRegType reg)
- ; let init' = init <*> mkAssign (CmmLocal reg')
- (addDynTag (CmmReg (CmmLocal reg))
- (lfDynTag lf_info))
- ; return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg')), init') }
+regIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> FCode (CgIdInfo, CmmAGraph)
+regIdInfo id lf_info expr
+ = do { reg <- newTemp (cmmExprType expr)
+ ; let init = mkAssign (CmmLocal reg)
+ (addDynTag expr (lfDynTag lf_info))
+ ; return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), init) }
idInfoToAmode :: CgIdInfo -> CmmExpr
-- Returns a CmmExpr for the *tagged* pointer
@@ -432,8 +432,8 @@ cgCase scrut bndr alt_type alts
-----------------
maybeSaveCostCentre :: Bool -> FCode (Maybe LocalReg)
maybeSaveCostCentre simple_scrut
- | simple_scrut = saveCurrentCostCentre
- | otherwise = return Nothing
+ | simple_scrut = return Nothing
+ | otherwise = saveCurrentCostCentre
-----------------
Oops, something went wrong.

0 comments on commit 415598b

Please sign in to comment.