diff options
| -rw-r--r-- | compiler/codeGen/StgCmm.hs | 16 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmBind.hs | 8 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmClosure.hs | 493 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmCon.hs | 2 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmEnv.hs | 22 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmExpr.hs | 2 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmExtCode.hs | 44 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmHeap.hs | 2 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmLayout.hs | 157 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmMonad.hs | 156 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmPrim.hs | 14 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmProf.hs | 27 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmTicky.hs | 5 |
13 files changed, 467 insertions, 481 deletions
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 6098e615ae..57b0cdaf89 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -50,12 +50,12 @@ import Control.Monad (when,void) import Util codeGen :: DynFlags - -> Module - -> [TyCon] - -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. - -> [StgBinding] -- Bindings to convert - -> HpcInfo - -> Stream IO CmmGroup () -- Output as a stream, so codegen can + -> Module + -> [TyCon] + -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. + -> [StgBinding] -- Bindings to convert + -> HpcInfo + -> Stream IO CmmGroup () -- Output as a stream, so codegen can -- be interleaved with output codeGen dflags this_mod data_tycons @@ -178,13 +178,13 @@ cgTopRhs rec bndr (StgRhsClosure cc bi fvs upd_flag _srt args body) module in the program, and we don't want to require that this name has the version and way info appended to it. -We initialise the module tree by keeping a work-stack, +We initialise the module tree by keeping a work-stack, * pointed to by Sp * that grows downward * Sp points to the last occupied slot -} -mkModuleInit +mkModuleInit :: CollectedCCs -- cost centre info -> Module -> HpcInfo diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 0344f24992..7cac6ad263 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -106,7 +106,7 @@ cgTopRhsClosure rec id ccs _ upd_flag args body caffy = idCafInfo id info_tbl = mkCmmInfo closure_info -- XXX short-cut closure_rep = mkStaticClosureFields dflags info_tbl ccs caffy [] - + -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY) ; emitDataLits closure_label closure_rep ; let fv_details :: [(NonVoid Id, VirtualHpOffset)] @@ -115,7 +115,7 @@ cgTopRhsClosure rec id ccs _ upd_flag args body -- Don't drop the non-void args until the closure info has been made ; forkClosureBody (closureCodeBody True id closure_info ccs (nonVoidIds args) (length args) body fv_details) - + ; return () } unLit (CmmLit l) = l @@ -582,7 +582,7 @@ emitBlackHoleCode node = do -- Eager blackholing is normally disabled, but can be turned on with -- -feager-blackholing. When it is on, we replace the info pointer -- of the thunk with stg_EAGER_BLACKHOLE_info on entry. - + -- If we wanted to do eager blackholing with slop filling, we'd need -- to do it at the *end* of a basic block, otherwise we overwrite -- the free variables in the thunk that we still need. We have a @@ -593,7 +593,7 @@ emitBlackHoleCode node = do -- on. But it didn't work, and it wasn't strictly necessary to bring -- back minimal ticky-ticky, so now EAGER_BLACKHOLING is -- unconditionally disabled. -- krc 1/2007 - + -- Note the eager-blackholing check is here rather than in blackHoleOnEntry, -- because emitBlackHoleCode is called from CmmParse. diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index c8911553d8..611a570d70 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- -- Stg to C-- code generation: --- +-- -- The types LambdaFormInfo -- ClosureInfo -- @@ -10,25 +10,19 @@ ----------------------------------------------------------------------------- {-# LANGUAGE RecordWildCards #-} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details module StgCmmClosure ( DynTag, tagForCon, isSmallFamily, - ConTagZ, dataConTagZ, + ConTagZ, dataConTagZ, idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps, - argPrimRep, + argPrimRep, -- * LambdaFormInfo LambdaFormInfo, -- Abstract - StandardFormInfo, -- ...ditto... - mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo, - mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape, + StandardFormInfo, -- ...ditto... + mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo, + mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape, mkLFBlackHole, lfDynTag, maybeIsLFCon, isLFThunk, isLFReEntrant, lfUpdatable, @@ -39,7 +33,7 @@ module StgCmmClosure ( isKnownFun, funTag, tagForArity, -- * ClosureInfo - ClosureInfo, + ClosureInfo, mkClosureInfo, mkCmmInfo, @@ -91,7 +85,7 @@ import DynFlags import Util ----------------------------------------------------------------------------- --- Representations +-- Representations ----------------------------------------------------------------------------- -- Why are these here? @@ -119,7 +113,7 @@ isGcPtrRep _ = False ----------------------------------------------------------------------------- --- LambdaFormInfo +-- LambdaFormInfo ----------------------------------------------------------------------------- -- Information about an identifier, from the code generator's point of @@ -128,81 +122,81 @@ isGcPtrRep _ = False -- tail call or return that identifier. data LambdaFormInfo - = LFReEntrant -- Reentrant closure (a function) - TopLevelFlag -- True if top level - !RepArity -- Arity. Invariant: always > 0 - !Bool -- True <=> no fvs - ArgDescr -- Argument descriptor (should really be in ClosureInfo) - - | LFThunk -- Thunk (zero arity) - TopLevelFlag - !Bool -- True <=> no free vars - !Bool -- True <=> updatable (i.e., *not* single-entry) - StandardFormInfo - !Bool -- True <=> *might* be a function type - - | LFCon -- A saturated constructor application - DataCon -- The constructor - - | LFUnknown -- Used for function arguments and imported things. - -- We know nothing about this closure. - -- Treat like updatable "LFThunk"... - -- Imported things which we *do* know something about use - -- one of the other LF constructors (eg LFReEntrant for - -- known functions) - !Bool -- True <=> *might* be a function type - -- The False case is good when we want to enter it, - -- because then we know the entry code will do - -- For a function, the entry code is the fast entry point - - | LFUnLifted -- A value of unboxed type; - -- always a value, needs evaluation - - | LFLetNoEscape -- See LetNoEscape module for precise description - - | LFBlackHole -- Used for the closures allocated to hold the result - -- of a CAF. We want the target of the update frame to - -- be in the heap, so we make a black hole to hold it. + = LFReEntrant -- Reentrant closure (a function) + TopLevelFlag -- True if top level + !RepArity -- Arity. Invariant: always > 0 + !Bool -- True <=> no fvs + ArgDescr -- Argument descriptor (should really be in ClosureInfo) + + | LFThunk -- Thunk (zero arity) + TopLevelFlag + !Bool -- True <=> no free vars + !Bool -- True <=> updatable (i.e., *not* single-entry) + StandardFormInfo + !Bool -- True <=> *might* be a function type + + | LFCon -- A saturated constructor application + DataCon -- The constructor + + | LFUnknown -- Used for function arguments and imported things. + -- We know nothing about this closure. + -- Treat like updatable "LFThunk"... + -- Imported things which we *do* know something about use + -- one of the other LF constructors (eg LFReEntrant for + -- known functions) + !Bool -- True <=> *might* be a function type + -- The False case is good when we want to enter it, + -- because then we know the entry code will do + -- For a function, the entry code is the fast entry point + + | LFUnLifted -- A value of unboxed type; + -- always a value, needs evaluation + + | LFLetNoEscape -- See LetNoEscape module for precise description + + | LFBlackHole -- Used for the closures allocated to hold the result + -- of a CAF. We want the target of the update frame to + -- be in the heap, so we make a black hole to hold it. -- XXX we can very nearly get rid of this, but -- allocDynClosure needs a LambdaFormInfo ------------------------- --- StandardFormInfo tells whether this thunk has one of +-- StandardFormInfo tells whether this thunk has one of -- a small number of standard forms data StandardFormInfo = NonStandardThunk - -- The usual case: not of the standard forms + -- The usual case: not of the standard forms | SelectorThunk - -- A SelectorThunk is of form - -- case x of - -- con a1,..,an -> ak - -- and the constructor is from a single-constr type. - WordOff -- 0-origin offset of ak within the "goods" of - -- constructor (Recall that the a1,...,an may be laid - -- out in the heap in a non-obvious order.) - - | ApThunk - -- An ApThunk is of form - -- x1 ... xn - -- The code for the thunk just pushes x2..xn on the stack and enters x1. - -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled - -- in the RTS to save space. - RepArity -- Arity, n + -- A SelectorThunk is of form + -- case x of + -- con a1,..,an -> ak + -- and the constructor is from a single-constr type. + WordOff -- 0-origin offset of ak within the "goods" of + -- constructor (Recall that the a1,...,an may be laid + -- out in the heap in a non-obvious order.) + + | ApThunk + -- An ApThunk is of form + -- x1 ... xn + -- The code for the thunk just pushes x2..xn on the stack and enters x1. + -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled + -- in the RTS to save space. + RepArity -- Arity, n ------------------------------------------------------ --- Building LambdaFormInfo +-- Building LambdaFormInfo ------------------------------------------------------ mkLFArgument :: Id -> LambdaFormInfo -mkLFArgument id - | isUnLiftedType ty = LFUnLifted +mkLFArgument id + | isUnLiftedType ty = LFUnLifted | might_be_a_function ty = LFUnknown True - | otherwise = LFUnknown False + | otherwise = LFUnknown False where ty = idType id @@ -211,23 +205,23 @@ mkLFLetNoEscape :: LambdaFormInfo mkLFLetNoEscape = LFLetNoEscape ------------- -mkLFReEntrant :: TopLevelFlag -- True of top level - -> [Id] -- Free vars - -> [Id] -- Args - -> ArgDescr -- Argument descriptor - -> LambdaFormInfo +mkLFReEntrant :: TopLevelFlag -- True of top level + -> [Id] -- Free vars + -> [Id] -- Args + -> ArgDescr -- Argument descriptor + -> LambdaFormInfo -mkLFReEntrant top fvs args arg_descr +mkLFReEntrant top fvs args arg_descr = LFReEntrant top (length args) (null fvs) arg_descr ------------- mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo mkLFThunk thunk_ty top fvs upd_flag = ASSERT( not (isUpdatable upd_flag) || not (isUnLiftedType thunk_ty) ) - LFThunk top (null fvs) - (isUpdatable upd_flag) - NonStandardThunk - (might_be_a_function thunk_ty) + LFThunk top (null fvs) + (isUpdatable upd_flag) + NonStandardThunk + (might_be_a_function thunk_ty) -------------- might_be_a_function :: Type -> Bool @@ -248,23 +242,23 @@ mkConLFInfo con = LFCon con ------------- mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo mkSelectorLFInfo id offset updatable - = LFThunk NotTopLevel False updatable (SelectorThunk offset) - (might_be_a_function (idType id)) + = LFThunk NotTopLevel False updatable (SelectorThunk offset) + (might_be_a_function (idType id)) ------------- mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo mkApLFInfo id upd_flag arity = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity) - (might_be_a_function (idType id)) + (might_be_a_function (idType id)) ------------- mkLFImported :: Id -> LambdaFormInfo mkLFImported id | Just con <- isDataConWorkId_maybe id , isNullaryRepDataCon con - = LFCon con -- An imported nullary constructor - -- We assume that the constructor is evaluated so that - -- the id really does point directly to the constructor + = LFCon con -- An imported nullary constructor + -- We assume that the constructor is evaluated so that + -- the id really does point directly to the constructor | arity > 0 = LFReEntrant TopLevel arity True (panic "arg_descr") @@ -279,25 +273,26 @@ mkLFBlackHole :: LambdaFormInfo mkLFBlackHole = LFBlackHole ----------------------------------------------------- --- Dynamic pointer tagging +-- Dynamic pointer tagging ----------------------------------------------------- -type ConTagZ = Int -- A *zero-indexed* contructor tag - -type DynTag = Int -- The tag on a *pointer* - -- (from the dynamic-tagging paper) +type ConTagZ = Int -- A *zero-indexed* contructor tag -{- Note [Data constructor dynamic tags] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The family size of a data type (the number of constructors -or the arity of a function) can be either: - * small, if the family size < 2**tag_bits - * big, otherwise. +type DynTag = Int -- The tag on a *pointer* + -- (from the dynamic-tagging paper) -Small families can have the constructor tag in the tag bits. -Big families only use the tag value 1 to represent evaluatedness. -We don't have very many tag bits: for example, we have 2 bits on -x86-32 and 3 bits on x86-64. -} +-- Note [Data constructor dynamic tags] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- The family size of a data type (the number of constructors +-- or the arity of a function) can be either: +-- * small, if the family size < 2**tag_bits +-- * big, otherwise. +-- +-- Small families can have the constructor tag in the tag bits. +-- Big families only use the tag value 1 to represent evaluatedness. +-- We don't have very many tag bits: for example, we have 2 bits on +-- x86-32 and 3 bits on x86-64. isSmallFamily :: DynFlags -> Int -> Bool isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags @@ -329,7 +324,7 @@ lfDynTag _ _other = 0 ----------------------------------------------------------------------------- --- Observing LambdaFormInfo +-- Observing LambdaFormInfo ----------------------------------------------------------------------------- ------------- @@ -341,9 +336,9 @@ maybeIsLFCon _ = Nothing isLFThunk :: LambdaFormInfo -> Bool isLFThunk (LFThunk {}) = True isLFThunk LFBlackHole = True - -- return True for a blackhole: this function is used to determine - -- whether to use the thunk header in SMP mode, and a blackhole - -- must have one. + -- return True for a blackhole: this function is used to determine + -- whether to use the thunk header in SMP mode, and a blackhole + -- must have one. isLFThunk _ = False isLFReEntrant :: LambdaFormInfo -> Bool @@ -351,7 +346,7 @@ isLFReEntrant (LFReEntrant {}) = True isLFReEntrant _ = False ----------------------------------------------------------------------------- --- Choosing SM reps +-- Choosing SM reps ----------------------------------------------------------------------------- lfClosureType :: LambdaFormInfo -> ClosureTypeInfo @@ -371,55 +366,55 @@ thunkClosureType _ = Thunk -- to FUN_STATIC in this case. ----------------------------------------------------------------------------- --- nodeMustPointToIt +-- nodeMustPointToIt ----------------------------------------------------------------------------- nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool -- If nodeMustPointToIt is true, then the entry convention for --- this closure has R1 (the "Node" register) pointing to the +-- this closure has R1 (the "Node" register) pointing to the -- closure itself --- the "self" argument nodeMustPointToIt _ (LFReEntrant top _ no_fvs _) = not no_fvs -- Certainly if it has fvs we need to point to it || isNotTopLevel top -- See Note [GC recovery] - -- For lex_profiling we also access the cost centre for a - -- non-inherited (i.e. non-top-level) function. - -- The isNotTopLevel test above ensures this is ok. + -- For lex_profiling we also access the cost centre for a + -- non-inherited (i.e. non-top-level) function. + -- The isNotTopLevel test above ensures this is ok. nodeMustPointToIt dflags (LFThunk top no_fvs updatable NonStandardThunk _) = not no_fvs -- Self parameter || isNotTopLevel top -- Note [GC recovery] || updatable -- Need to push update frame || gopt Opt_SccProfilingOn dflags - -- For the non-updatable (single-entry case): - -- - -- True if has fvs (in which case we need access to them, and we - -- should black-hole it) - -- or profiling (in which case we need to recover the cost centre - -- from inside it) ToDo: do we need this even for + -- For the non-updatable (single-entry case): + -- + -- True if has fvs (in which case we need access to them, and we + -- should black-hole it) + -- or profiling (in which case we need to recover the cost centre + -- from inside it) ToDo: do we need this even for -- top-level thunks? If not, -- isNotTopLevel subsumes this -nodeMustPointToIt _ (LFThunk {}) -- Node must point to a standard-form thunk - = True +nodeMustPointToIt _ (LFThunk {}) -- Node must point to a standard-form thunk + = True nodeMustPointToIt _ (LFCon _) = True - -- Strictly speaking, the above two don't need Node to point - -- to it if the arity = 0. But this is a *really* unlikely - -- situation. If we know it's nil (say) and we are entering - -- it. Eg: let x = [] in x then we will certainly have inlined - -- x, since nil is a simple atom. So we gain little by not - -- having Node point to known zero-arity things. On the other - -- hand, we do lose something; Patrick's code for figuring out - -- when something has been updated but not entered relies on - -- having Node point to the result of an update. SLPJ - -- 27/11/92. + -- Strictly speaking, the above two don't need Node to point + -- to it if the arity = 0. But this is a *really* unlikely + -- situation. If we know it's nil (say) and we are entering + -- it. Eg: let x = [] in x then we will certainly have inlined + -- x, since nil is a simple atom. So we gain little by not + -- having Node point to known zero-arity things. On the other + -- hand, we do lose something; Patrick's code for figuring out + -- when something has been updated but not entered relies on + -- having Node point to the result of an update. SLPJ + -- 27/11/92. nodeMustPointToIt _ (LFUnknown _) = True nodeMustPointToIt _ LFUnLifted = False nodeMustPointToIt _ LFBlackHole = True -- BH entry may require Node to point -nodeMustPointToIt _ LFLetNoEscape = False +nodeMustPointToIt _ LFLetNoEscape = False {- Note [GC recovery] ~~~~~~~~~~~~~~~~~~~~~ @@ -427,7 +422,7 @@ If we a have a local let-binding (function or thunk) let f = <body> in ... AND <body> allocates, then the heap-overflow check needs to know how to re-start the evaluation. It uses the "self" pointer to do this. -So even if there are no free variables in <body>, we still make +So even if there are no free variables in <body>, we still make nodeMustPointToIt be True for non-top-level bindings. Why do any such bindings exist? After all, let-floating should have @@ -435,75 +430,73 @@ floated them out. Well, a clever optimiser might leave one there to avoid a space leak, deliberately recomputing a thunk. Also (and this really does happen occasionally) let-floating may make a function f smaller so it can be inlined, so now (f True) may generate a local no-fv closure. -This actually happened during bootsrapping GHC itself, with f=mkRdrFunBind +This actually happened during bootsrapping GHC itself, with f=mkRdrFunBind in TcGenDeriv.) -} ----------------------------------------------------------------------------- --- getCallMethod +-- getCallMethod ----------------------------------------------------------------------------- {- The entry conventions depend on the type of closure being entered, whether or not it has free variables, and whether we're running sequentially or in parallel. -Closure Node Argument Enter -Characteristics Par Req'd Passing Via +Closure Node Argument Enter +Characteristics Par Req'd Passing Via ------------------------------------------------------------------------------- -Unknown & no & yes & stack & node -Known fun (>1 arg), no fvs & no & no & registers & fast entry (enough args) - & slow entry (otherwise) -Known fun (>1 arg), fvs & no & yes & registers & fast entry (enough args) -0 arg, no fvs \r,\s & no & no & n/a & direct entry -0 arg, no fvs \u & no & yes & n/a & node -0 arg, fvs \r,\s & no & yes & n/a & direct entry -0 arg, fvs \u & no & yes & n/a & node - -Unknown & yes & yes & stack & node -Known fun (>1 arg), no fvs & yes & no & registers & fast entry (enough args) - & slow entry (otherwise) -Known fun (>1 arg), fvs & yes & yes & registers & node -0 arg, no fvs \r,\s & yes & no & n/a & direct entry -0 arg, no fvs \u & yes & yes & n/a & node -0 arg, fvs \r,\s & yes & yes & n/a & node -0 arg, fvs \u & yes & yes & n/a & node -\end{tabular} +Unknown & no & yes & stack & node +Known fun (>1 arg), no fvs & no & no & registers & fast entry (enough args) + & slow entry (otherwise) +Known fun (>1 arg), fvs & no & yes & registers & fast entry (enough args) +0 arg, no fvs \r,\s & no & no & n/a & direct entry +0 arg, no fvs \u & no & yes & n/a & node +0 arg, fvs \r,\s & no & yes & n/a & direct entry +0 arg, fvs \u & no & yes & n/a & node +Unknown & yes & yes & stack & node +Known fun (>1 arg), no fvs & yes & no & registers & fast entry (enough args) + & slow entry (otherwise) +Known fun (>1 arg), fvs & yes & yes & registers & node +0 arg, no fvs \r,\s & yes & no & n/a & direct entry +0 arg, no fvs \u & yes & yes & n/a & node +0 arg, fvs \r,\s & yes & yes & n/a & node +0 arg, fvs \u & yes & yes & n/a & node When black-holing, single-entry closures could also be entered via node (rather than directly) to catch double-entry. -} data CallMethod - = EnterIt -- No args, not a function + = EnterIt -- No args, not a function - | JumpToIt -- A join point + | JumpToIt -- A join point - | ReturnIt -- It's a value (function, unboxed value, - -- or constructor), so just return it. + | ReturnIt -- It's a value (function, unboxed value, + -- or constructor), so just return it. - | SlowCall -- Unknown fun, or known fun with - -- too few args. + | SlowCall -- Unknown fun, or known fun with + -- too few args. - | DirectEntry -- Jump directly, with args in regs - CLabel -- The code label - RepArity -- Its arity + | DirectEntry -- Jump directly, with args in regs + CLabel -- The code label + RepArity -- Its arity getCallMethod :: DynFlags -> Name -- Function being applied -> CafInfo -- Can it refer to CAF's? - -> LambdaFormInfo -- Its info - -> RepArity -- Number of available arguments - -> CallMethod + -> LambdaFormInfo -- Its info + -> RepArity -- Number of available arguments + -> CallMethod getCallMethod dflags _name _ lf_info _n_args | nodeMustPointToIt dflags lf_info && gopt Opt_Parallel dflags - = -- If we're parallel, then we must always enter via node. - -- The reason is that the closure may have been - -- fetched since we allocated it. + = -- If we're parallel, then we must always enter via node. + -- The reason is that the closure may have been + -- fetched since we allocated it. EnterIt getCallMethod dflags name caf (LFReEntrant _ arity _ _) n_args | n_args == 0 = ASSERT( arity /= 0 ) - ReturnIt -- No args at all - | n_args < arity = SlowCall -- Not enough args + ReturnIt -- No args at all + | n_args < arity = SlowCall -- Not enough args | otherwise = DirectEntry (enterIdLabel dflags name caf) arity getCallMethod _ _name _ LFUnLifted n_args @@ -513,17 +506,17 @@ getCallMethod _ _name _ (LFCon _) n_args = ASSERT( n_args == 0 ) ReturnIt getCallMethod dflags name caf (LFThunk _ _ updatable std_form_info is_fun) n_args - | is_fun -- it *might* be a function, so we must "call" it (which is always safe) - = SlowCall -- We cannot just enter it [in eval/apply, the entry code - -- is the fast-entry code] + | is_fun -- it *might* be a function, so we must "call" it (which is always safe) + = SlowCall -- We cannot just enter it [in eval/apply, the entry code + -- is the fast-entry code] -- Since is_fun is False, we are *definitely* looking at a data value | updatable || gopt Opt_Ticky dflags -- to catch double entry {- OLD: || opt_SMP - I decided to remove this, because in SMP mode it doesn't matter - if we enter the same thunk multiple times, so the optimisation - of jumping directly to the entry code is still valid. --SDM - -} + I decided to remove this, because in SMP mode it doesn't matter + if we enter the same thunk multiple times, so the optimisation + of jumping directly to the entry code is still valid. --SDM + -} = EnterIt -- We used to have ASSERT( n_args == 0 ), but actually it is -- possible for the optimiser to generate @@ -532,7 +525,7 @@ getCallMethod dflags name caf (LFThunk _ _ updatable std_form_info is_fun) n_arg -- This happens as a result of the case-of-error transformation -- So the right thing to do is just to enter the thing - | otherwise -- Jump direct to code for single-entry thunks + | otherwise -- Jump direct to code for single-entry thunks = ASSERT( n_args == 0 ) DirectEntry (thunkEntryLabel dflags name caf std_form_info updatable) 0 @@ -544,20 +537,20 @@ getCallMethod _ name _ (LFUnknown False) n_args EnterIt -- Not a function getCallMethod _ _name _ LFBlackHole _n_args - = SlowCall -- Presumably the black hole has by now - -- been updated, but we don't know with - -- what, so we slow call it + = SlowCall -- Presumably the black hole has by now + -- been updated, but we don't know with + -- what, so we slow call it getCallMethod _ _name _ LFLetNoEscape _n_args = JumpToIt isKnownFun :: LambdaFormInfo -> Bool isKnownFun (LFReEntrant _ _ _ _) = True -isKnownFun LFLetNoEscape = True +isKnownFun LFLetNoEscape = True isKnownFun _ = False ----------------------------------------------------------------------------- --- staticClosureRequired +-- staticClosureRequired ----------------------------------------------------------------------------- {- staticClosureRequired is never called (hence commented out) @@ -580,16 +573,16 @@ have closure, info table, and entry code.] * Fast-entry code ALWAYS NEEDED * Slow-entry code - Needed iff (a) we have any un-saturated calls to the function - OR (b) the function is passed as an arg - OR (c) we're in the parallel world and the function has free vars - [Reason: in parallel world, we always enter functions - with free vars via the closure.] + Needed iff (a) we have any un-saturated calls to the function + OR (b) the function is passed as an arg + OR (c) we're in the parallel world and the function has free vars + [Reason: in parallel world, we always enter functions + with free vars via the closure.] * The function closure - Needed iff (a) we have any un-saturated calls to the function - OR (b) the function is passed as an arg - OR (c) if the function has free vars (ie not top level) + Needed iff (a) we have any un-saturated calls to the function + OR (b) the function is passed as an arg + OR (c) if the function has free vars (ie not top level) Why case (a) here? Because if the arg-satis check fails, UpdatePAP stuffs a pointer to the function closure in the PAP. @@ -599,9 +592,9 @@ have closure, info table, and entry code.] [NB: these conditions imply that we might need the closure without the slow-entry code. Here's how. - f x y = let g w = ...x..y..w... - in - ...(g t)... + f x y = let g w = ...x..y..w... + in + ...(g t)... Here we need a closure for g which contains x and y, but since the calls are all saturated we just jump to the @@ -609,35 +602,35 @@ have closure, info table, and entry code.] * Standard info table - Needed iff (a) we have any un-saturated calls to the function - OR (b) the function is passed as an arg - OR (c) the function has free vars (ie not top level) - - NB. In the sequential world, (c) is only required so that the function closure has - an info table to point to, to keep the storage manager happy. - If (c) alone is true we could fake up an info table by choosing - one of a standard family of info tables, whose entry code just - bombs out. - - [NB In the parallel world (c) is needed regardless because - we enter functions with free vars via the closure.] - - If (c) is retained, then we'll sometimes generate an info table - (for storage mgr purposes) without slow-entry code. Then we need - to use an error label in the info table to substitute for the absent - slow entry code. + Needed iff (a) we have any un-saturated calls to the function + OR (b) the function is passed as an arg + OR (c) the function has free vars (ie not top level) + + NB. In the sequential world, (c) is only required so that the function closure has + an info table to point to, to keep the storage manager happy. + If (c) alone is true we could fake up an info table by choosing + one of a standard family of info tables, whose entry code just + bombs out. + + [NB In the parallel world (c) is needed regardless because + we enter functions with free vars via the closure.] + + If (c) is retained, then we'll sometimes generate an info table + (for storage mgr purposes) without slow-entry code. Then we need + to use an error label in the info table to substitute for the absent + slow entry code. -} staticClosureRequired - :: Name - -> StgBinderInfo - -> LambdaFormInfo - -> Bool + :: Name + -> StgBinderInfo + -> LambdaFormInfo + -> Bool staticClosureRequired binder bndr_info - (LFReEntrant top_level _ _ _) -- It's a function + (LFReEntrant top_level _ _ _) -- It's a function = ASSERT( isTopLevel top_level ) - -- Assumption: it's a top-level, no-free-var binding - not (satCallsOnly bndr_info) + -- Assumption: it's a top-level, no-free-var binding + not (satCallsOnly bndr_info) staticClosureRequired binder other_binder_info other_lf_info = True -} @@ -660,7 +653,7 @@ staticClosureRequired binder other_binder_info other_lf_info = True a) to construct the info table itself, and build other things related to the binding (e.g. slow entry points for a function) b) to allocate a closure containing that info pointer (i.e. - it knows the info table label) + it knows the info table label) -} data ClosureInfo @@ -689,22 +682,22 @@ mkCmmInfo ClosureInfo {..} -------------------------------------- --- Building ClosureInfos +-- Building ClosureInfos -------------------------------------- mkClosureInfo :: DynFlags - -> Bool -- Is static - -> Id - -> LambdaFormInfo - -> Int -> Int -- Total and pointer words + -> Bool -- Is static + -> Id + -> LambdaFormInfo + -> Int -> Int -- Total and pointer words -> String -- String descriptor - -> ClosureInfo + -> ClosureInfo mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr - = ClosureInfo { closureName = name, - closureLFInfo = lf_info, - closureInfoLabel = info_lbl, -- These three fields are - closureSMRep = sm_rep, -- (almost) an info table - closureProf = prof } -- (we don't have an SRT yet) + = ClosureInfo { closureName = name + , closureLFInfo = lf_info + , closureInfoLabel = info_lbl -- These three fields are + , closureSMRep = sm_rep -- (almost) an info table + , closureProf = prof } -- (we don't have an SRT yet) where name = idName id sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info) @@ -729,8 +722,8 @@ mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr -- -- -- Previously, eager blackholing was enabled when ticky-ticky --- was on. But it didn't work, and it wasn't strictly necessary --- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING +-- was on. But it didn't work, and it wasn't strictly necessary +-- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING -- is unconditionally disabled. -- krc 1/2007 -- Static closures are never themselves black-holed. @@ -738,12 +731,12 @@ mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr blackHoleOnEntry :: ClosureInfo -> Bool blackHoleOnEntry cl_info | isStaticRep (closureSMRep cl_info) - = False -- Never black-hole a static closure + = False -- Never black-hole a static closure | otherwise = case closureLFInfo cl_info of - LFReEntrant _ _ _ _ -> False - LFLetNoEscape -> False + LFReEntrant _ _ _ _ -> False + LFLetNoEscape -> False LFThunk _ _no_fvs _updatable _ _ -> True _other -> panic "blackHoleOnEntry" -- Should never happen @@ -755,9 +748,9 @@ closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info lfUpdatable :: LambdaFormInfo -> Bool lfUpdatable (LFThunk _ _ upd _ _) = upd -lfUpdatable LFBlackHole = True - -- Black-hole closures are allocated to receive the results of an - -- alg case with a named default... so they need to be updated. +lfUpdatable LFBlackHole = True + -- Black-hole closures are allocated to receive the results of an + -- alg case with a named default... so they need to be updated. lfUpdatable _ = False closureSingleEntry :: ClosureInfo -> Bool @@ -784,7 +777,7 @@ isToplevClosure (ClosureInfo { closureLFInfo = lf_info }) = case lf_info of LFReEntrant TopLevel _ _ _ -> True LFThunk TopLevel _ _ _ _ -> True - _other -> False + _other -> False -------------------------------------- -- Label generation @@ -806,17 +799,17 @@ mkClosureInfoTableLabel id lf_info = case lf_info of LFBlackHole -> mkCAFBlackHoleInfoTableLabel - LFThunk _ _ upd_flag (SelectorThunk offset) _ + LFThunk _ _ upd_flag (SelectorThunk offset) _ -> mkSelectorInfoLabel upd_flag offset - LFThunk _ _ upd_flag (ApThunk arity) _ + LFThunk _ _ upd_flag (ApThunk arity) _ -> mkApInfoTableLabel upd_flag arity LFThunk{} -> std_mk_lbl name cafs LFReEntrant{} -> std_mk_lbl name cafs _other -> panic "closureInfoTableLabel" - where + where name = idName id std_mk_lbl | is_local = mkLocalInfoTableLabel @@ -881,16 +874,16 @@ getTyDescription :: Type -> String getTyDescription ty = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) -> case tau_ty of - TyVarTy _ -> "*" - AppTy fun _ -> getTyDescription fun - FunTy _ res -> '-' : '>' : fun_result res - TyConApp tycon _ -> getOccString tycon + TyVarTy _ -> "*" + AppTy fun _ -> getTyDescription fun + FunTy _ res -> '-' : '>' : fun_result res + TyConApp tycon _ -> getOccString tycon ForAllTy _ ty -> getTyDescription ty LitTy n -> getTyLitDescription n } where fun_result (FunTy _ res) = '>' : fun_result res - fun_result other = getTyDescription other + fun_result other = getTyDescription other getTyLitDescription :: TyLit -> String getTyLitDescription l = @@ -944,8 +937,8 @@ indStaticInfoTable staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool -- A static closure needs a link field to aid the GC when traversing -- the static closure graph. But it only needs such a field if either --- a) it has an SRT --- b) it's a constructor with one or more pointer fields +-- a) it has an SRT +-- b) it's a constructor with one or more pointer fields -- In case (b), the constructor's fields themselves play the role -- of the SRT. -- diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index 9bfa22b344..4f12948bcc 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -235,7 +235,7 @@ buildDynCon' dflags _ binder actually_bound ccs con args use_cc -- cost-centre to stick in the object | isCurrentCCS ccs = curCCS | otherwise = panic "buildDynCon: non-current CCS not implemented" - + blame_cc = use_cc -- cost-centre on which to blame the alloc (same) diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs index 1fdb364b56..77a3b4e249 100644 --- a/compiler/codeGen/StgCmmEnv.hs +++ b/compiler/codeGen/StgCmmEnv.hs @@ -20,8 +20,8 @@ module StgCmmEnv ( bindArgsToRegs, bindToReg, rebindToReg, bindArgToReg, idToReg, getArgAmode, getNonVoidArgAmodes, - getCgIdInfo, - maybeLetNoEscape, + getCgIdInfo, + maybeLetNoEscape, ) where #include "HsVersions.h" @@ -114,7 +114,7 @@ addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr addDynTag dflags expr tag = cmmOffsetB dflags expr tag cgIdInfoId :: CgIdInfo -> Id -cgIdInfoId = cg_id +cgIdInfoId = cg_id cgIdInfoLF :: CgIdInfo -> LambdaFormInfo cgIdInfoLF = cg_lf @@ -127,8 +127,8 @@ maybeLetNoEscape _other = Nothing --------------------------------------------------------- -- The binding environment --- --- There are three basic routines, for adding (addBindC), +-- +-- There are three basic routines, for adding (addBindC), -- modifying(modifyBindC) and looking up (getCgIdInfo) bindings. --------------------------------------------------------- @@ -160,7 +160,7 @@ getCgIdInfo id Nothing -> -- Should be imported; make up a CgIdInfo for it - let + let name = idName id in if isExternalName name then do @@ -168,10 +168,10 @@ getCgIdInfo id dflags <- getDynFlags return (litIdInfo dflags id (mkLFImported id) ext_lbl) else - -- Bug + -- Bug cgLookupPanic id }}}} - + cgLookupPanic :: Id -> FCode a cgLookupPanic id = do static_binds <- getStaticBinds @@ -192,7 +192,7 @@ getArgAmode (NonVoid (StgVarArg var)) = getArgAmode (NonVoid (StgLitArg lit)) = liftM CmmLit $ cgLit lit getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr] --- NB: Filters out void args, +-- NB: Filters out void args, -- so the result list may be shorter than the argument list getNonVoidArgAmodes [] = return [] getNonVoidArgAmodes (arg:args) @@ -214,7 +214,7 @@ bindToReg nvid@(NonVoid id) lf_info return reg rebindToReg :: NonVoid Id -> FCode LocalReg --- Like bindToReg, but the Id is already in scope, so +-- Like bindToReg, but the Id is already in scope, so -- get its LF info from the envt rebindToReg nvid@(NonVoid id) = do { info <- getCgIdInfo id @@ -233,7 +233,7 @@ idToReg :: DynFlags -> NonVoid Id -> LocalReg -- We re-use the Unique from the Id to make it easier to see what is going on -- -- By now the Ids should be uniquely named; else one would worry --- about accidental collision +-- about accidental collision idToReg dflags (NonVoid id) = LocalReg (idUnique id) (case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id) diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index bbb5937240..00c6068fb0 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -323,7 +323,7 @@ This special case handles code like --> case tagToEnum# (a <$# b) of True -> .. ; False -> ... ---> case (a <$# b) of r -> +--> case (a <$# b) of r -> case tagToEnum# r of True -> .. ; False -> ... diff --git a/compiler/codeGen/StgCmmExtCode.hs b/compiler/codeGen/StgCmmExtCode.hs index 5057f1c8c4..e710204222 100644 --- a/compiler/codeGen/StgCmmExtCode.hs +++ b/compiler/codeGen/StgCmmExtCode.hs @@ -12,7 +12,7 @@ module StgCmmExtCode ( CmmParse, unEC, Named(..), Env, - + loopDecls, getEnv, @@ -50,13 +50,13 @@ import Unique -- | The environment contains variable definitions or blockids. -data Named +data Named = VarN CmmExpr -- ^ Holds CmmLit(CmmLabel ..) which gives the label type, - -- eg, RtsLabel, ForeignLabel, CmmLabel etc. + -- eg, RtsLabel, ForeignLabel, CmmLabel etc. | FunN PackageId -- ^ A function name from this package | LabelN BlockId -- ^ A blockid of some code or data. - + -- | An environment of named things. type Env = UniqFM Named @@ -65,7 +65,7 @@ type Decls = [(FastString,Named)] -- | Does a computation in the FCode monad, with a current environment -- and a list of local declarations. Returns the resulting list of declarations. -newtype CmmParse a +newtype CmmParse a = EC { unEC :: Env -> Decls -> FCode (Decls, a) } type ExtCode = CmmParse () @@ -86,7 +86,7 @@ instance HasDynFlags CmmParse where -- | Takes the variable decarations and imports from the monad --- and makes an environment, which is looped back into the computation. +-- and makes an environment, which is looped back into the computation. -- In this way, we can have embedded declarations that scope over the whole -- procedure, and imports that scope over the entire module. -- Discards the local declaration contained within decl' @@ -107,8 +107,8 @@ addDecl :: FastString -> Named -> ExtCode addDecl name named = EC $ \_ s -> return ((name, named) : s, ()) --- | Add a new variable to the list of local declarations. --- The CmmExpr says where the value is stored. +-- | Add a new variable to the list of local declarations. +-- The CmmExpr says where the value is stored. addVarDecl :: FastString -> CmmExpr -> ExtCode addVarDecl var expr = addDecl var (VarN expr) @@ -118,11 +118,11 @@ addLabel name block_id = addDecl name (LabelN block_id) -- | Create a fresh local variable of a given type. -newLocal +newLocal :: CmmType -- ^ data type -> FastString -- ^ name of variable -> CmmParse LocalReg -- ^ register holding the value - + newLocal ty name = do u <- code newUnique let reg = LocalReg u ty @@ -141,32 +141,32 @@ newBlockId :: CmmParse BlockId newBlockId = code F.newLabelC -- | Add add a local function to the environment. -newFunctionName - :: FastString -- ^ name of the function +newFunctionName + :: FastString -- ^ name of the function -> PackageId -- ^ package of the current module -> ExtCode - + newFunctionName name pkg = addDecl name (FunN pkg) - - + + -- | Add an imported foreign label to the list of local declarations. -- If this is done at the start of the module the declaration will scope -- over the whole module. -newImport - :: (FastString, CLabel) +newImport + :: (FastString, CLabel) -> CmmParse () -newImport (name, cmmLabel) +newImport (name, cmmLabel) = addVarDecl name (CmmLit (CmmLabel cmmLabel)) -- | Lookup the BlockId bound to the label with this name. --- If one hasn't been bound yet, create a fresh one based on the +-- If one hasn't been bound yet, create a fresh one based on the -- Unique of the name. lookupLabel :: FastString -> CmmParse BlockId lookupLabel name = do env <- getEnv - return $ + return $ case lookupUFM env name of Just (LabelN l) -> l _other -> mkBlockId (newTagUnique (getUnique name) 'L') @@ -179,7 +179,7 @@ lookupLabel name = do lookupName :: FastString -> CmmParse CmmExpr lookupName name = do env <- getEnv - return $ + return $ case lookupUFM env name of Just (VarN e) -> e Just (FunN pkg) -> CmmLit (CmmLabel (mkCmmCodeLabel pkg name)) @@ -188,7 +188,7 @@ lookupName name = do -- | Lift an FCode computation into the CmmParse monad code :: FCode a -> CmmParse a -code fc = EC $ \_ s -> do +code fc = EC $ \_ s -> do r <- fc return (s, r) diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index b8962cedb4..76c0a4cf69 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -469,7 +469,7 @@ cannedGCEntryPoint dflags regs W32 -> Just (mkGcLabel "stg_gc_f1") W64 -> Just (mkGcLabel "stg_gc_d1") _ -> Nothing - + | width == wordWidth dflags -> Just (mkGcLabel "stg_gc_unbx_r1") | width == W64 -> Just (mkGcLabel "stg_gc_l1") | otherwise -> Nothing diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 06a47c151b..c6e57d5041 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -6,23 +6,16 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module StgCmmLayout ( - mkArgDescr, + mkArgDescr, emitCall, emitReturn, adjustHpBackwards, - emitClosureProcAndInfoTable, - emitClosureAndInfoTable, + emitClosureProcAndInfoTable, + emitClosureAndInfoTable, - slowCall, directCall, + slowCall, directCall, - mkVirtHeapOffsets, mkVirtConstrOffsets, getHpRelOffset, hpRel, + mkVirtHeapOffsets, mkVirtConstrOffsets, getHpRelOffset, hpRel, ArgRep(..), toArgRep, argRepSizeW -- re-exported from StgCmmArgRep ) where @@ -47,8 +40,8 @@ import CLabel import StgSyn import Id import Name -import TyCon ( PrimRep(..) ) -import BasicTypes ( RepArity ) +import TyCon ( PrimRep(..) ) +import BasicTypes ( RepArity ) import DynFlags import Module @@ -59,7 +52,7 @@ import FastString import Control.Monad ------------------------------------------------------------------------ --- Call and return sequences +-- Call and return sequences ------------------------------------------------------------------------ -- | Return multiple values to the sequel @@ -108,10 +101,10 @@ emitCallWithExtraStack :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> [CmmExpr] -> FCode ReturnKind emitCallWithExtraStack (callConv, retConv) fun args extra_stack - = do { dflags <- getDynFlags + = do { dflags <- getDynFlags ; adjustHpBackwards - ; sequel <- getSequel - ; updfr_off <- getUpdFrameOff + ; sequel <- getSequel + ; updfr_off <- getUpdFrameOff ; case sequel of Return _ -> do emit $ mkJumpExtra dflags callConv fun args updfr_off extra_stack @@ -129,33 +122,33 @@ emitCallWithExtraStack (callConv, retConv) fun args extra_stack adjustHpBackwards :: FCode () -- This function adjusts and heap pointers just before a tail call or --- return. At a call or return, the virtual heap pointer may be less --- than the real Hp, because the latter was advanced to deal with --- the worst-case branch of the code, and we may be in a better-case --- branch. In that case, move the real Hp *back* and retract some +-- return. At a call or return, the virtual heap pointer may be less +-- than the real Hp, because the latter was advanced to deal with +-- the worst-case branch of the code, and we may be in a better-case +-- branch. In that case, move the real Hp *back* and retract some -- ticky allocation count. -- -- It *does not* deal with high-water-mark adjustment. -- That's done by functions which allocate heap. adjustHpBackwards - = do { hp_usg <- getHpUsage - ; let rHp = realHp hp_usg - vHp = virtHp hp_usg - adjust_words = vHp -rHp - ; new_hp <- getHpRelOffset vHp + = do { hp_usg <- getHpUsage + ; let rHp = realHp hp_usg + vHp = virtHp hp_usg + adjust_words = vHp -rHp + ; new_hp <- getHpRelOffset vHp - ; emit (if adjust_words == 0 - then mkNop - else mkAssign hpReg new_hp) -- Generates nothing when vHp==rHp + ; emit (if adjust_words == 0 + then mkNop + else mkAssign hpReg new_hp) -- Generates nothing when vHp==rHp - ; tickyAllocHeap False adjust_words -- ...ditto + ; tickyAllocHeap False adjust_words -- ...ditto - ; setRealHp vHp - } + ; setRealHp vHp + } ------------------------------------------------------------------------- --- Making calls: directCall and slowCall +-- Making calls: directCall and slowCall ------------------------------------------------------------------------- -- General plan is: @@ -183,7 +176,7 @@ directCall conv lbl arity stg_args slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind -- (slowCall fun args) applies fun to args, returning the results to Sequel -slowCall fun stg_args +slowCall fun stg_args = do { dflags <- getDynFlags ; argsreps <- getArgRepsAmodes stg_args ; let (rts_fun, arity) = slowCallPattern (map fst argsreps) @@ -299,13 +292,13 @@ slowArgs dflags args -- careful: reps contains voids (V), but args does not save_cccs_lbl = mkCmmRetInfoLabel rtsPackageId (fsLit "stg_restore_cccs") ------------------------------------------------------------------------- ----- Laying out objects on the heap and stack +---- Laying out objects on the heap and stack ------------------------------------------------------------------------- -- The heap always grows upwards, so hpRel is easy -hpRel :: VirtualHpOffset -- virtual offset of Hp - -> VirtualHpOffset -- virtual offset of The Thing - -> WordOff -- integer word offset +hpRel :: VirtualHpOffset -- virtual offset of Hp + -> VirtualHpOffset -- virtual offset of The Thing + -> WordOff -- integer word offset hpRel hp off = off - hp getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr @@ -316,10 +309,10 @@ getHpRelOffset virtual_offset mkVirtHeapOffsets :: DynFlags - -> Bool -- True <=> is a thunk - -> [(PrimRep,a)] -- Things to make offsets for - -> (WordOff, -- _Total_ number of words allocated - WordOff, -- Number of words allocated for *pointers* + -> Bool -- True <=> is a thunk + -> [(PrimRep,a)] -- Things to make offsets for + -> (WordOff, -- _Total_ number of words allocated + WordOff, -- Number of words allocated for *pointers* [(NonVoid a, VirtualHpOffset)]) -- Things with their offsets from start of object in order of @@ -333,10 +326,10 @@ mkVirtHeapOffsets -- than the unboxed things mkVirtHeapOffsets dflags is_thunk things - = let non_void_things = filterOut (isVoidRep . fst) things - (ptrs, non_ptrs) = partition (isGcPtrRep . fst) non_void_things - (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs - (tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs + = let non_void_things = filterOut (isVoidRep . fst) things + (ptrs, non_ptrs) = partition (isGcPtrRep . fst) non_void_things + (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs + (tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs in (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets) where @@ -344,8 +337,8 @@ mkVirtHeapOffsets dflags is_thunk things | otherwise = fixedHdrSize dflags computeOffset wds_so_far (rep, thing) - = (wds_so_far + argRepSizeW dflags (toArgRep rep), - (NonVoid thing, hdr_size + wds_so_far)) + = (wds_so_far + argRepSizeW dflags (toArgRep rep), + (NonVoid thing, hdr_size + wds_so_far)) mkVirtConstrOffsets :: DynFlags -> [(PrimRep,a)] -> (WordOff, WordOff, [(NonVoid a, VirtualHpOffset)]) -- Just like mkVirtHeapOffsets, but for constructors @@ -354,11 +347,11 @@ mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags False ------------------------------------------------------------------------- -- --- Making argument descriptors +-- Making argument descriptors -- -- An argument descriptor describes the layout of args on the stack, --- both for * GC (stack-layout) purposes, and --- * saving/restoring registers when a heap-check fails +-- both for * GC (stack-layout) purposes, and +-- * saving/restoring registers when a heap-check fails -- -- Void arguments aren't important, therefore (contrast constructSlowCall) -- @@ -377,7 +370,7 @@ mkArgDescr _nm args Just spec_id -> return (ArgSpec spec_id) Nothing -> return (ArgGen arg_bits) -argBits :: DynFlags -> [ArgRep] -> [Bool] -- True for non-ptr, False for ptr +argBits :: DynFlags -> [ArgRep] -> [Bool] -- True for non-ptr, False for ptr argBits _ [] = [] argBits dflags (P : args) = False : argBits dflags args argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True) @@ -387,37 +380,37 @@ argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True) stdPattern :: [ArgRep] -> Maybe Int stdPattern reps = case reps of - [] -> Just ARG_NONE -- just void args, probably - [N] -> Just ARG_N - [P] -> Just ARG_P - [F] -> Just ARG_F - [D] -> Just ARG_D - [L] -> Just ARG_L - [V16] -> Just ARG_V16 - - [N,N] -> Just ARG_NN - [N,P] -> Just ARG_NP - [P,N] -> Just ARG_PN - [P,P] -> Just ARG_PP - - [N,N,N] -> Just ARG_NNN - [N,N,P] -> Just ARG_NNP - [N,P,N] -> Just ARG_NPN - [N,P,P] -> Just ARG_NPP - [P,N,N] -> Just ARG_PNN - [P,N,P] -> Just ARG_PNP - [P,P,N] -> Just ARG_PPN - [P,P,P] -> Just ARG_PPP - - [P,P,P,P] -> Just ARG_PPPP - [P,P,P,P,P] -> Just ARG_PPPPP - [P,P,P,P,P,P] -> Just ARG_PPPPPP - - _ -> Nothing + [] -> Just ARG_NONE -- just void args, probably + [N] -> Just ARG_N + [P] -> Just ARG_P + [F] -> Just ARG_F + [D] -> Just ARG_D + [L] -> Just ARG_L + [V16] -> Just ARG_V16 + + [N,N] -> Just ARG_NN + [N,P] -> Just ARG_NP + [P,N] -> Just ARG_PN + [P,P] -> Just ARG_PP + + [N,N,N] -> Just ARG_NNN + [N,N,P] -> Just ARG_NNP + [N,P,N] -> Just ARG_NPN + [N,P,P] -> Just ARG_NPP + [P,N,N] -> Just ARG_PNN + [P,N,P] -> Just ARG_PNP + [P,P,N] -> Just ARG_PPN + [P,P,P] -> Just ARG_PPP + + [P,P,P,P] -> Just ARG_PPPP + [P,P,P,P,P] -> Just ARG_PPPPP + [P,P,P,P,P,P] -> Just ARG_PPPPPP + + _ -> Nothing ------------------------------------------------------------------------- -- --- Generating the info table and code for a closure +-- Generating the info table and code for a closure -- ------------------------------------------------------------------------- @@ -427,7 +420,7 @@ stdPattern reps -- When loading the free variables, a function closure pointer may be tagged, -- so we must take it into account. -emitClosureProcAndInfoTable :: Bool -- top-level? +emitClosureProcAndInfoTable :: Bool -- top-level? -> Id -- name of the closure -> LambdaFormInfo -> CmmInfoTable diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 251b679078..37b0a26df6 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -12,7 +12,7 @@ module StgCmmMonad ( initC, runC, thenC, thenFC, listCs, returnFC, fixC, - newUnique, newUniqSupply, + newUnique, newUniqSupply, newLabelC, emitLabel, @@ -46,7 +46,7 @@ module StgCmmMonad ( -- ideally we wouldn't export these, but some other modules access internal state getState, setState, getInfoDown, getDynFlags, getThisPackage, - -- more localised access to monad state + -- more localised access to monad state CgIdInfo(..), CgLoc(..), getBinds, setBinds, getStaticBinds, @@ -132,7 +132,7 @@ returnFC :: a -> FCode a returnFC val = FCode (\_info_down state -> (# val, state #)) thenC :: FCode () -> FCode a -> FCode a -thenC (FCode m) (FCode k) = +thenC (FCode m) (FCode k) = FCode $ \info_down state -> case m info_down state of (# _,new_state #) -> k info_down new_state @@ -141,7 +141,7 @@ listCs [] = return () listCs (fc:fcs) = do fc listCs fcs - + thenFC :: FCode a -> (a -> FCode c) -> FCode c thenFC (FCode m) k = FCode $ \info_down state -> @@ -152,7 +152,7 @@ thenFC (FCode m) k = FCode $ fixC :: (a -> FCode a) -> FCode a fixC fcode = FCode ( - \info_down state -> + \info_down state -> let (v,s) = doFCode (fcode v) info_down state in @@ -163,8 +163,8 @@ fixC fcode = FCode ( -- The code generator environment -------------------------------------------------------- --- This monadery has some information that it only passes --- *downwards*, as well as some ``state'' which is modified +-- This monadery has some information that it only passes +-- *downwards*, as well as some ``state'' which is modified -- as we go along. data CgInfoDownwards -- information only passed *downwards* by the monad @@ -180,11 +180,11 @@ data CgInfoDownwards -- information only passed *downwards* by the monad type CgBindings = IdEnv CgIdInfo data CgIdInfo - = CgIdInfo + = CgIdInfo { cg_id :: Id -- Id that this is the info for - -- Can differ from the Id at occurrence sites by + -- Can differ from the Id at occurrence sites by -- virtue of being externalised, for splittable C - , cg_lf :: LambdaFormInfo + , cg_lf :: LambdaFormInfo , cg_loc :: CgLoc -- CmmExpr for the *tagged* value } @@ -193,9 +193,9 @@ data CgLoc -- Hp, so that it remains valid across calls | LneLoc BlockId [LocalReg] -- A join point - -- A join point (= let-no-escape) should only + -- A join point (= let-no-escape) should only -- be tail-called, and in a saturated way. - -- To tail-call it, assign to these locals, + -- To tail-call it, assign to these locals, -- and branch to the block id instance Outputable CgIdInfo where @@ -212,7 +212,7 @@ data Sequel = Return Bool -- Return result(s) to continuation found on the stack -- True <=> the continuation is update code (???) - | AssignTo + | AssignTo [LocalReg] -- Put result(s) in these regs and fall through -- NB: no void arguments here -- @@ -297,12 +297,12 @@ data ReturnKind initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards initCgInfoDown dflags mod - = MkCgInfoDown { cgd_dflags = dflags, - cgd_mod = mod, - cgd_statics = emptyVarEnv, - cgd_updfr_off = initUpdFrameOff dflags, - cgd_ticky = mkTopTickyCtrLabel, - cgd_sequel = initSequel } + = MkCgInfoDown { cgd_dflags = dflags + , cgd_mod = mod + , cgd_statics = emptyVarEnv + , cgd_updfr_off = initUpdFrameOff dflags + , cgd_ticky = mkTopTickyCtrLabel + , cgd_sequel = initSequel } initSequel :: Sequel initSequel = Return False @@ -321,9 +321,9 @@ data CgState cgs_tops :: OrdList CmmDecl, -- Other procedures and data blocks in this compilation unit - -- Both are ordered only so that we can + -- Both are ordered only so that we can -- reduce forward references, when it's easy to do so - + cgs_binds :: CgBindings, -- [Id -> info] : *local* bindings environment -- Bindings for top-level things are given in -- the info-down part @@ -346,18 +346,19 @@ type VirtualHpOffset = WordOff initCgState :: UniqSupply -> CgState initCgState uniqs - = MkCgState { cgs_stmts = mkNop, cgs_tops = nilOL, - cgs_binds = emptyVarEnv, - cgs_hp_usg = initHpUsage, - cgs_uniqs = uniqs } + = MkCgState { cgs_stmts = mkNop + , cgs_tops = nilOL + , cgs_binds = emptyVarEnv + , cgs_hp_usg = initHpUsage + , cgs_uniqs = uniqs } stateIncUsage :: CgState -> CgState -> CgState --- stateIncUsage@ e1 e2 incorporates in e1 +-- stateIncUsage@ e1 e2 incorporates in e1 -- the heap high water mark found in e2. stateIncUsage s1 s2@(MkCgState { cgs_hp_usg = hp_usg }) = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg } `addCodeBlocksFrom` s2 - + addCodeBlocksFrom :: CgState -> CgState -> CgState -- Add code blocks from the latter to the former -- (The cgs_stmts will often be empty, but not always; see codeOnly) @@ -370,13 +371,13 @@ s1 `addCodeBlocksFrom` s2 -- only records the high water marks of forked-off branches, so to find the -- heap high water mark you have to take the max of virtHp and hwHp. Remember, -- virtHp never retreats! --- +-- -- Note Jan 04: ok, so why do we only look at the virtual Hp?? heapHWM :: HeapUsage -> VirtualHpOffset heapHWM = virtHp -initHpUsage :: HeapUsage +initHpUsage :: HeapUsage initHpUsage = HeapUsage { virtHp = 0, realHp = 0 } maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage @@ -396,7 +397,7 @@ getHpUsage :: FCode HeapUsage getHpUsage = do state <- getState return $ cgs_hp_usg state - + setHpUsage :: HeapUsage -> FCode () setHpUsage new_hp_usg = do state <- getState @@ -404,24 +405,24 @@ setHpUsage new_hp_usg = do setVirtHp :: VirtualHpOffset -> FCode () setVirtHp new_virtHp - = do { hp_usage <- getHpUsage + = do { hp_usage <- getHpUsage ; setHpUsage (hp_usage {virtHp = new_virtHp}) } getVirtHp :: FCode VirtualHpOffset -getVirtHp - = do { hp_usage <- getHpUsage +getVirtHp + = do { hp_usage <- getHpUsage ; return (virtHp hp_usage) } setRealHp :: VirtualHpOffset -> FCode () setRealHp new_realHp - = do { hp_usage <- getHpUsage + = do { hp_usage <- getHpUsage ; setHpUsage (hp_usage {realHp = new_realHp}) } getBinds :: FCode CgBindings getBinds = do state <- getState return $ cgs_binds state - + setBinds :: CgBindings -> FCode () setBinds new_binds = do state <- getState @@ -433,7 +434,7 @@ getStaticBinds = do return (cgd_statics info) withState :: FCode a -> CgState -> FCode (a,CgState) -withState (FCode fcode) newstate = FCode $ \info_down state -> +withState (FCode fcode) newstate = FCode $ \info_down state -> case fcode info_down newstate of (# retval, state2 #) -> (# (retval,state2), state #) @@ -462,7 +463,7 @@ getThisPackage :: FCode PackageId getThisPackage = liftM thisPackage getDynFlags withInfoDown :: FCode a -> CgInfoDownwards -> FCode a -withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state +withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState) doFCode (FCode fcode) info_down state = @@ -480,7 +481,7 @@ getModuleName = do { info <- getInfoDown; return (cgd_mod info) } withSequel :: Sequel -> FCode a -> FCode a withSequel sequel code - = do { info <- getInfoDown + = do { info <- getInfoDown ; withInfoDown code (info {cgd_sequel = sequel }) } getSequel :: FCode Sequel @@ -499,12 +500,12 @@ getSequel = do { info <- getInfoDown withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a withUpdFrameOff size code - = do { info <- getInfoDown + = do { info <- getInfoDown ; withInfoDown code (info {cgd_updfr_off = size }) } getUpdFrameOff :: FCode UpdFrameOffset getUpdFrameOff - = do { info <- getInfoDown + = do { info <- getInfoDown ; return $ cgd_updfr_off info } -- ---------------------------------------------------------------------------- @@ -526,28 +527,27 @@ setTickyCtrLabel ticky code = do -------------------------------------------------------- forkClosureBody :: FCode () -> FCode () --- forkClosureBody takes a code, $c$, and compiles it in a +-- forkClosureBody takes a code, $c$, and compiles it in a -- fresh environment, except that: -- - compilation info and statics are passed in unchanged. -- - local bindings are passed in unchanged -- (it's up to the enclosed code to re-bind the -- free variables to a field of the closure) --- +-- -- The current state is passed on completely unaltered, except that -- C-- from the fork is incorporated. forkClosureBody body_code - = do { dflags <- getDynFlags - ; info <- getInfoDown - ; us <- newUniqSupply - ; state <- getState - ; let body_info_down = info { cgd_sequel = initSequel - , cgd_updfr_off = initUpdFrameOff dflags } - fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } - ((),fork_state_out) - = doFCode body_code body_info_down fork_state_in + = do { dflags <- getDynFlags + ; info <- getInfoDown + ; us <- newUniqSupply + ; state <- getState + ; let body_info_down = info { cgd_sequel = initSequel + , cgd_updfr_off = initUpdFrameOff dflags } + fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } + ((),fork_state_out) = doFCode body_code body_info_down fork_state_in ; setState $ state `addCodeBlocksFrom` fork_state_out } - + forkStatics :: FCode a -> FCode a -- @forkStatics@ $fc$ compiles $fc$ in an environment whose *statics* come -- from the current *local bindings*, but which is otherwise freshly initialised. @@ -555,32 +555,32 @@ forkStatics :: FCode a -> FCode a -- bindings and usage information is otherwise unchanged. forkStatics body_code = do { dflags <- getDynFlags - ; info <- getInfoDown - ; us <- newUniqSupply - ; state <- getState + ; info <- getInfoDown + ; us <- newUniqSupply + ; state <- getState ; let rhs_info_down = info { cgd_statics = cgs_binds state - , cgd_sequel = initSequel + , cgd_sequel = initSequel , cgd_updfr_off = initUpdFrameOff dflags } - (result, fork_state_out) = doFCode body_code rhs_info_down + (result, fork_state_out) = doFCode body_code rhs_info_down (initCgState us) ; setState (state `addCodeBlocksFrom` fork_state_out) ; return result } forkProc :: FCode a -> FCode a -- 'forkProc' takes a code and compiles it in the *current* environment, --- returning the graph thus constructed. +-- returning the graph thus constructed. -- -- The current environment is passed on completely unchanged to -- the successor. In particular, any heap usage from the enclosed -- code is discarded; it should deal with its own heap consumption forkProc body_code - = do { info_down <- getInfoDown - ; us <- newUniqSupply - ; state <- getState - ; let info_down' = info_down -- { cgd_sequel = initSequel } - fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } - (result, fork_state_out) = doFCode body_code info_down' fork_state_in - ; setState $ state `addCodeBlocksFrom` fork_state_out + = do { info_down <- getInfoDown + ; us <- newUniqSupply + ; state <- getState + ; let info_down' = info_down -- { cgd_sequel = initSequel } + fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } + (result, fork_state_out) = doFCode body_code info_down' fork_state_in + ; setState $ state `addCodeBlocksFrom` fork_state_out ; return result } codeOnly :: FCode () -> FCode () @@ -588,7 +588,7 @@ codeOnly :: FCode () -> FCode () -- Do not affect anything else in the outer state -- Used in almost-circular code to prevent false loop dependencies codeOnly body_code - = do { info_down <- getInfoDown + = do { info_down <- getInfoDown ; us <- newUniqSupply ; state <- getState ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state, @@ -623,7 +623,7 @@ forkAlts branch_fcodes -- collect the code emitted by an FCode computation getCodeR :: FCode a -> FCode (a, CmmAGraph) getCodeR fcode - = do { state1 <- getState + = do { state1 <- getState ; (a, state2) <- withState fcode (state1 { cgs_stmts = mkNop }) ; setState $ state2 { cgs_stmts = cgs_stmts state1 } ; return (a, cgs_stmts state2) } @@ -633,21 +633,21 @@ getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts } -- 'getHeapUsage' applies a function to the amount of heap that it uses. -- It initialises the heap usage to zeros, and passes on an unchanged --- heap usage. +-- heap usage. -- -- It is usually a prelude to performing a GC check, so everything must -- be in a tidy and consistent state. --- +-- -- Note the slightly subtle fixed point behaviour needed here getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a getHeapUsage fcode - = do { info_down <- getInfoDown + = do { info_down <- getInfoDown ; state <- getState ; let fstate_in = state { cgs_hp_usg = initHpUsage } (r, fstate_out) = doFCode (fcode hp_hw) info_down fstate_in hp_hw = heapHWM (cgs_hp_usg fstate_out) -- Loop here! - + ; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state } ; return r } @@ -683,12 +683,12 @@ newLabelC = do { u <- newUnique emit :: CmmAGraph -> FCode () emit ag - = do { state <- getState + = do { state <- getState ; setState $ state { cgs_stmts = cgs_stmts state <*> ag } } emitDecl :: CmmDecl -> FCode () emitDecl decl - = do { state <- getState + = do { state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } } emitOutOfLine :: BlockId -> CmmAGraph -> FCode () @@ -753,10 +753,10 @@ getCmm :: FCode () -> FCode CmmGroup -- Get all the CmmTops (there should be no stmts) -- Return a single Cmm which may be split from other Cmms by -- object splitting (at a later stage) -getCmm code - = do { state1 <- getState +getCmm code + = do { state1 <- getState ; ((), state2) <- withState code (state1 { cgs_tops = nilOL }) - ; setState $ state2 { cgs_tops = cgs_tops state1 } + ; setState $ state2 { cgs_tops = cgs_tops state1 } ; return (fromOL (cgs_tops state2)) } @@ -777,7 +777,7 @@ mkCmmIfGoto e tid = do mkCmmIfThen :: CmmExpr -> CmmAGraph -> FCode CmmAGraph mkCmmIfThen e tbranch = do endif <- newLabelC - tid <- newLabelC + tid <- newLabelC return $ mkCbranch e tid endif <*> mkLabel tid <*> tbranch <*> mkLabel endif @@ -786,7 +786,7 @@ mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmActual] -> UpdFrameOffset -> [CmmActual] -> FCode CmmAGraph mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do dflags <- getDynFlags - k <- newLabelC + k <- newLabelC let area = Young k (off, _, copyin) = copyInOflow dflags retConv area results [] copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 2c044faa42..c11df7009c 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -1038,7 +1038,7 @@ doIndexOffAddrOp _ _ _ _ doIndexOffAddrOpAs :: Maybe MachOp -> CmmType - -> CmmType + -> CmmType -> [LocalReg] -> [CmmExpr] -> FCode () @@ -1055,19 +1055,19 @@ doIndexByteArrayOp :: Maybe MachOp doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx] = do dflags <- getDynFlags mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr rep idx -doIndexByteArrayOp _ _ _ _ +doIndexByteArrayOp _ _ _ _ = panic "StgCmmPrim: doIndexByteArrayOp" doIndexByteArrayOpAs :: Maybe MachOp -> CmmType - -> CmmType + -> CmmType -> [LocalReg] -> [CmmExpr] -> FCode () doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx] = do dflags <- getDynFlags mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx_rep idx -doIndexByteArrayOpAs _ _ _ _ _ +doIndexByteArrayOpAs _ _ _ _ _ = panic "StgCmmPrim: doIndexByteArrayOpAs" doReadPtrArrayOp :: LocalReg @@ -1212,7 +1212,7 @@ doVecPackOp maybe_pre_write_cast ty z es res = do Just cast -> CmmMachOp cast [val] len :: Length - len = vecLength ty + len = vecLength ty wid :: Width wid = typeWidth (vecElemType ty) @@ -1246,7 +1246,7 @@ doVecUnpackOp maybe_post_read_cast ty e res = Just cast -> CmmMachOp cast [val] len :: Length - len = vecLength ty + len = vecLength ty wid :: Width wid = typeWidth (vecElemType ty) @@ -1273,7 +1273,7 @@ doVecInsertOp maybe_pre_write_cast ty src e idx res = do Just cast -> CmmMachOp cast [val] len :: Length - len = vecLength ty + len = vecLength ty wid :: Width wid = typeWidth (vecElemType ty) diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index 3307604a87..b1eaa1c27b 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -106,10 +106,10 @@ initUpdFrameProf frame {- Note [Saving the current cost centre] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The current cost centre is like a global register. Like other +The current cost centre is like a global register. Like other global registers, it's a caller-saves one. But consider case (f x) of (p,q) -> rhs -Since 'f' may set the cost centre, we must restore it +Since 'f' may set the cost centre, we must restore it before resuming rhs. So we want code like this: local_cc = CCC -- save r = f( x ) @@ -117,7 +117,7 @@ before resuming rhs. So we want code like this: That is, we explicitly "save" the current cost centre in a LocalReg, local_cc; and restore it after the call. The C-- infrastructure will arrange to save local_cc across the -call. +call. The same goes for join points; let j x = join-stuff @@ -125,7 +125,7 @@ The same goes for join points; We want this kind of code: local_cc = CCC -- save blah-blah - J: + J: CCC = local_cc -- restore -} @@ -140,7 +140,7 @@ saveCurrentCostCentre return (Just local_cc) restoreCurrentCostCentre :: Maybe LocalReg -> FCode () -restoreCurrentCostCentre Nothing +restoreCurrentCostCentre Nothing = return () restoreCurrentCostCentre (Just local_cc) = emit (storeCurCCS (CmmReg (CmmLocal local_cc))) @@ -178,7 +178,7 @@ profAlloc words ccs -- Setting the current cost centre on entry to a closure enterCostCentreThunk :: CmmExpr -> FCode () -enterCostCentreThunk closure = +enterCostCentreThunk closure = ifProfiling $ do dflags <- getDynFlags emit $ storeCurCCS (costCentreFrom dflags closure) @@ -220,7 +220,7 @@ initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs) emitCostCentreDecl :: CostCentre -> FCode () -emitCostCentreDecl cc = do +emitCostCentreDecl cc = do { dflags <- getDynFlags ; let is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF | otherwise = zero dflags @@ -241,12 +241,12 @@ emitCostCentreDecl cc = do zero dflags, -- StgWord time_ticks is_caf, -- StgInt is_caf zero dflags -- struct _CostCentre *link - ] + ] ; emitDataLits (mkCCLabel cc) lits } emitCostCentreStackDecl :: CostCentreStack -> FCode () -emitCostCentreStackDecl ccs +emitCostCentreStackDecl ccs = case maybeSingletonCCS ccs of Just cc -> do dflags <- getDynFlags @@ -316,12 +316,12 @@ staticLdvInit = zeroCLit -- Initial value of the LDV field in a dynamic closure -- dynLdvInit :: DynFlags -> CmmExpr -dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE +dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE CmmMachOp (mo_wordOr dflags) [ CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)], CmmLit (mkWordCLit dflags (iLDV_STATE_CREATE dflags)) ] - + -- -- Initialise the LDV word of a new closure -- @@ -340,7 +340,7 @@ ldvEnterClosure closure_info = do dflags <- getDynFlags let tag = funTag dflags closure_info ldvEnter (cmmOffsetB dflags (CmmReg nodeReg) (-tag)) -- don't forget to substract node's tag - + ldvEnter :: CmmExpr -> FCode () -- Argument is a closure pointer ldvEnter cl_ptr = do @@ -364,8 +364,7 @@ loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags)) (cInt dflags)] ldvWord :: DynFlags -> CmmExpr -> CmmExpr --- Takes the address of a closure, and returns +-- Takes the address of a closure, and returns -- the address of the LDV word in the closure ldvWord dflags closure_ptr = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags) - diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs index f520dc627e..3b06d3ba62 100644 --- a/compiler/codeGen/StgCmmTicky.hs +++ b/compiler/codeGen/StgCmmTicky.hs @@ -240,9 +240,9 @@ tickyEnterViaNode = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr") tickyEnterThunk :: ClosureInfo -> FCode () tickyEnterThunk cl_info - = ifTicky $ do + = ifTicky $ do { bumpTickyCounter ctr - ; unless static $ do + ; unless static $ do ticky_ctr_lbl <- getTickyCtrLabel registerTickyCtrAtEntryDyn ticky_ctr_lbl bumpTickyEntryCount ticky_ctr_lbl } @@ -581,6 +581,7 @@ bumpHistogram :: FastString -> Int -> FCode () bumpHistogram _lbl _n -- = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLongWidth)) = return () -- TEMP SPJ Apr 07 + -- six years passed - still temp? JS Aug 2013 {- bumpHistogramE :: LitString -> CmmExpr -> FCode () |