Commit 9825f863 authored by Simon Marlow's avatar Simon Marlow
Browse files

remove tabs

parent 0ca75749
......@@ -6,17 +6,10 @@
--
-----------------------------------------------------------------------------
{-# 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 StgCmmBind (
cgTopRhsClosure,
cgBind,
emitBlackHoleCode,
cgTopRhsClosure,
cgBind,
emitBlackHoleCode,
pushUpdateFrame
) where
......@@ -36,7 +29,7 @@ import StgCmmClosure
import StgCmmForeign (emitPrimCall)
import MkGraph
import CoreSyn ( AltCon(..) )
import CoreSyn ( AltCon(..) )
import SMRep
import Cmm
import CmmUtils
......@@ -57,18 +50,18 @@ import Maybes
import DynFlags
------------------------------------------------------------------------
-- Top-level bindings
-- Top-level bindings
------------------------------------------------------------------------
-- For closures bound at top level, allocate in static space.
-- They should have no free variables.
cgTopRhsClosure :: Id
-> CostCentreStack -- Optional cost centre annotation
-> StgBinderInfo
-> UpdateFlag
-> CostCentreStack -- Optional cost centre annotation
-> StgBinderInfo
-> UpdateFlag
-> [Id] -- Args
-> StgExpr
-> StgExpr
-> FCode (CgIdInfo, FCode ())
cgTopRhsClosure id ccs _ upd_flag args body
......@@ -90,11 +83,11 @@ cgTopRhsClosure id ccs _ upd_flag args body
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)
-- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
; emitDataLits closure_label closure_rep
; let fv_details :: [(NonVoid Id, VirtualHpOffset)]
(_, _, fv_details) = mkVirtHeapOffsets dflags (isLFThunk lf_info)
(addIdReps [])
(addIdReps [])
-- 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)
......@@ -102,7 +95,7 @@ cgTopRhsClosure id ccs _ upd_flag args body
; return () }
------------------------------------------------------------------------
-- Non-top-level bindings
-- Non-top-level bindings
------------------------------------------------------------------------
cgBind :: StgBinding -> FCode ()
......@@ -192,19 +185,19 @@ cgRhs name (StgRhsClosure cc bi fvs upd_flag _srt args body)
mkRhsClosure dflags name cc bi (nonVoidIds fvs) upd_flag args body
------------------------------------------------------------------------
-- Non-constructor right hand sides
-- Non-constructor right hand sides
------------------------------------------------------------------------
mkRhsClosure :: DynFlags -> Id -> CostCentreStack -> StgBinderInfo
-> [NonVoid Id] -- Free vars
-> [NonVoid Id] -- Free vars
-> UpdateFlag
-> [Id] -- Args
-> StgExpr
-> [Id] -- Args
-> StgExpr
-> FCode (CgIdInfo, FCode CmmAGraph)
{- mkRhsClosure looks for two special forms of the right-hand side:
a) selector thunks
b) AP thunks
a) selector thunks
b) AP thunks
If neither happens, it just calls mkClosureLFInfo. You might think
that mkClosureLFInfo should do all this, but it seems wrong for the
......@@ -217,14 +210,14 @@ but nothing deep. We are looking for a closure of {\em exactly} the
form:
... = [the_fv] \ u [] ->
case the_fv of
con a_1 ... a_n -> a_i
case the_fv of
con a_1 ... a_n -> a_i
Note [Ap thunks]
~~~~~~~~~~~~~~~~
A more generic AP thunk of the form
x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
A set of these is compiled statically into the RTS, so we just use
those. We could extend the idea to thunks where some of the x_i are
......@@ -239,17 +232,17 @@ for semi-obvious reasons.
---------- Note [Selectors] ------------------
mkRhsClosure dflags bndr _cc _bi
[NonVoid the_fv] -- Just one free var
upd_flag -- Updatable thunk
[NonVoid the_fv] -- Just one free var
upd_flag -- Updatable thunk
[] -- A thunk
(StgCase (StgApp scrutinee [{-no args-}])
_ _ _ _ -- ignore uniq, etc.
(AlgAlt _)
[(DataAlt _, params, _use_mask,
(StgApp selectee [{-no args-}]))])
| the_fv == scrutinee -- Scrutinee is the only free variable
&& maybeToBool maybe_offset -- Selectee is a component of the tuple
&& offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough
_ _ _ _ -- ignore uniq, etc.
(AlgAlt _)
[(DataAlt _, params, _use_mask,
(StgApp selectee [{-no args-}]))])
| the_fv == scrutinee -- Scrutinee is the only free variable
&& maybeToBool maybe_offset -- Selectee is a component of the tuple
&& offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough
= -- NOT TRUE: ASSERT(is_single_constructor)
-- The simplifier may have statically determined that the single alternative
-- is the only possible case and eliminated the others, even if there are
......@@ -260,25 +253,25 @@ mkRhsClosure dflags bndr _cc _bi
-- srt is discarded; it must be empty
cgRhsStdThunk bndr lf_info [StgVarArg the_fv]
where
lf_info = mkSelectorLFInfo bndr offset_into_int
(isUpdatable upd_flag)
lf_info = mkSelectorLFInfo bndr offset_into_int
(isUpdatable upd_flag)
(_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps params)
-- Just want the layout
maybe_offset = assocMaybe params_w_offsets (NonVoid selectee)
Just the_offset = maybe_offset
-- Just want the layout
maybe_offset = assocMaybe params_w_offsets (NonVoid selectee)
Just the_offset = maybe_offset
offset_into_int = the_offset - fixedHdrSize dflags
---------- Note [Ap thunks] ------------------
mkRhsClosure dflags bndr _cc _bi
fvs
upd_flag
fvs
upd_flag
[] -- No args; a thunk
(StgApp fun_id args)
| args `lengthIs` (arity-1)
&& all (isGcPtrRep . idPrimRep . stripNV) fvs
&& isUpdatable upd_flag
&& arity <= mAX_SPEC_AP_SIZE
&& all (isGcPtrRep . idPrimRep . stripNV) fvs
&& isUpdatable upd_flag
&& arity <= mAX_SPEC_AP_SIZE
&& not (dopt Opt_SccProfilingOn dflags)
-- not when profiling: we don't want to
-- lose information about this particular
......@@ -288,11 +281,11 @@ mkRhsClosure dflags bndr _cc _bi
= cgRhsStdThunk bndr lf_info payload
where
lf_info = mkApLFInfo bndr upd_flag arity
-- the payload has to be in the correct order, hence we can't
-- just use the fvs.
payload = StgVarArg fun_id : args
arity = length fvs
lf_info = mkApLFInfo bndr upd_flag arity
-- the payload has to be in the correct order, hence we can't
-- just use the fvs.
payload = StgVarArg fun_id : args
arity = length fvs
---------- Default case ------------------
mkRhsClosure _ bndr cc _ fvs upd_flag args body
......@@ -302,42 +295,42 @@ mkRhsClosure _ bndr cc _ fvs upd_flag args body
where
gen_code lf_info reg
= do { -- LAY OUT THE OBJECT
-- If the binder is itself a free variable, then don't store
-- it in the closure. Instead, just bind it to Node on entry.
-- NB we can be sure that Node will point to it, because we
-- haven't told mkClosureLFInfo about this; so if the binder
-- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
-- stored in the closure itself, so it will make sure that
-- Node points to it...
; let
is_elem = isIn "cgRhsClosure"
bndr_is_a_fv = (NonVoid bndr) `is_elem` fvs
reduced_fvs | bndr_is_a_fv = fvs `minusList` [NonVoid bndr]
| otherwise = fvs
-- MAKE CLOSURE INFO FOR THIS CLOSURE
-- If the binder is itself a free variable, then don't store
-- it in the closure. Instead, just bind it to Node on entry.
-- NB we can be sure that Node will point to it, because we
-- haven't told mkClosureLFInfo about this; so if the binder
-- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
-- stored in the closure itself, so it will make sure that
-- Node points to it...
; let
is_elem = isIn "cgRhsClosure"
bndr_is_a_fv = (NonVoid bndr) `is_elem` fvs
reduced_fvs | bndr_is_a_fv = fvs `minusList` [NonVoid bndr]
| otherwise = fvs
-- MAKE CLOSURE INFO FOR THIS CLOSURE
; mod_name <- getModuleName
; dflags <- getDynFlags
; let name = idName bndr
descr = closureDescription dflags mod_name name
fv_details :: [(NonVoid Id, VirtualHpOffset)]
(tot_wds, ptr_wds, fv_details)
= mkVirtHeapOffsets dflags (isLFThunk lf_info)
(addIdReps (map stripNV reduced_fvs))
closure_info = mkClosureInfo dflags False -- Not static
bndr lf_info tot_wds ptr_wds
(tot_wds, ptr_wds, fv_details)
= mkVirtHeapOffsets dflags (isLFThunk lf_info)
(addIdReps (map stripNV reduced_fvs))
closure_info = mkClosureInfo dflags False -- Not static
bndr lf_info tot_wds ptr_wds
descr
-- BUILD ITS INFO TABLE AND CODE
; forkClosureBody $
-- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere
-- (b) ignore Sequel from context; use empty Sequel
-- And compile the body
closureCodeBody False bndr closure_info cc (nonVoidIds args)
-- BUILD ITS INFO TABLE AND CODE
; forkClosureBody $
-- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere
-- (b) ignore Sequel from context; use empty Sequel
-- And compile the body
closureCodeBody False bndr closure_info cc (nonVoidIds args)
(length args) body fv_details
-- BUILD THE OBJECT
-- BUILD THE OBJECT
-- ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
; let use_cc = curCCS; blame_cc = curCCS
; emit (mkComment $ mkFastString "calling allocDynClosure")
......@@ -346,7 +339,7 @@ mkRhsClosure _ bndr cc _ fvs upd_flag args body
; hp_plus_n <- allocDynClosure info_tbl lf_info use_cc blame_cc
(map toVarArg fv_details)
-- RETURN
-- RETURN
; return (mkRhsInit reg lf_info hp_plus_n) }
......@@ -367,36 +360,36 @@ cgRhsStdThunk bndr lf_info payload
}
where
gen_code reg
= do -- AHA! A STANDARD-FORM THUNK
{ -- LAY OUT THE OBJECT
= do -- AHA! A STANDARD-FORM THUNK
{ -- LAY OUT THE OBJECT
mod_name <- getModuleName
; dflags <- getDynFlags
; let (tot_wds, ptr_wds, payload_w_offsets)
= mkVirtHeapOffsets dflags (isLFThunk lf_info) (addArgReps payload)
= mkVirtHeapOffsets dflags (isLFThunk lf_info) (addArgReps payload)
descr = closureDescription dflags mod_name (idName bndr)
closure_info = mkClosureInfo dflags False -- Not static
bndr lf_info tot_wds ptr_wds
descr = closureDescription dflags mod_name (idName bndr)
closure_info = mkClosureInfo dflags False -- Not static
bndr lf_info tot_wds ptr_wds
descr
-- ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
; let use_cc = curCCS; blame_cc = curCCS
-- BUILD THE OBJECT
-- BUILD THE OBJECT
; let info_tbl = mkCmmInfo closure_info
; hp_plus_n <- allocDynClosure info_tbl lf_info
use_cc blame_cc payload_w_offsets
-- RETURN
-- RETURN
; return (mkRhsInit reg lf_info hp_plus_n) }
mkClosureLFInfo :: Id -- The binder
-> TopLevelFlag -- True of top level
-> [NonVoid Id] -- Free vars
-> UpdateFlag -- Update flag
-> [Id] -- Args
-> FCode LambdaFormInfo
mkClosureLFInfo :: Id -- The binder
-> TopLevelFlag -- True of top level
-> [NonVoid Id] -- Free vars
-> UpdateFlag -- Update flag
-> [Id] -- Args
-> FCode LambdaFormInfo
mkClosureLFInfo bndr top fvs upd_flag args
| null args = return (mkLFThunk (idType bndr) top (map stripNV fvs) upd_flag)
| otherwise =
......@@ -405,18 +398,18 @@ mkClosureLFInfo bndr top fvs upd_flag args
------------------------------------------------------------------------
-- The code for closures}
-- The code for closures}
------------------------------------------------------------------------
closureCodeBody :: Bool -- whether this is a top-level binding
-> Id -- the closure's name
-> ClosureInfo -- Lots of information about this closure
-> CostCentreStack -- Optional cost centre attached to closure
-> [NonVoid Id] -- incoming args to the closure
-> Int -- arity, including void args
-> StgExpr
-> [(NonVoid Id, VirtualHpOffset)] -- the closure's free vars
-> FCode ()
-> ClosureInfo -- Lots of information about this closure
-> CostCentreStack -- Optional cost centre attached to closure
-> [NonVoid Id] -- incoming args to the closure
-> Int -- arity, including void args
-> StgExpr
-> [(NonVoid Id, VirtualHpOffset)] -- the closure's free vars
-> FCode ()
{- There are two main cases for the code for closures.
......@@ -549,7 +542,7 @@ thunkCode cl_info fv_details _cc node arity body
------------------------------------------------------------------------
-- Update and black-hole wrappers
-- Update and black-hole wrappers
------------------------------------------------------------------------
blackHoleIt :: ClosureInfo -> FCode ()
......@@ -593,9 +586,9 @@ emitBlackHoleCode is_single_entry = do
emitStore (CmmReg nodeReg) (CmmReg (CmmGlobal EagerBlackholeInfo))
setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()
-- Nota Bene: this function does not change Node (even if it's a CAF),
-- so that the cost centre in the original closure can still be
-- extracted by a subsequent enterCostCentre
-- Nota Bene: this function does not change Node (even if it's a CAF),
-- so that the cost centre in the original closure can still be
-- extracted by a subsequent enterCostCentre
setupUpdate closure_info node body
| closureReEntrant closure_info
= body
......@@ -616,14 +609,14 @@ setupUpdate closure_info node body
pushUpdateFrame lbl (CmmReg (CmmLocal node)) body
| otherwise -- A static closure
= do { tickyUpdateBhCaf closure_info
| otherwise -- A static closure
= do { tickyUpdateBhCaf closure_info
; if closureUpdReqd closure_info
then do -- Blackhole the (updatable) CAF:
; if closureUpdReqd closure_info
then do -- Blackhole the (updatable) CAF:
{ upd_closure <- link_caf node True
; pushUpdateFrame mkBHUpdInfoLabel upd_closure body }
else do {tickyUpdateFrameOmitted; body}
else do {tickyUpdateFrameOmitted; body}
}
-----------------------------------------------------------------------------
......@@ -693,7 +686,7 @@ link_caf :: LocalReg -- pointer to the closure
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)
; let use_cc = costCentreFrom (CmmReg nodeReg)
blame_cc = use_cc
tso = CmmReg (CmmGlobal CurrentTSO)
......@@ -708,8 +701,8 @@ link_caf node _is_upd = do
-- Call the RTS function newCAF to add the CAF to the CafList
-- so that the garbage collector can find them
-- This must be done *before* the info table pointer is overwritten,
-- because the old info table ptr is needed for reversion
-- This must be done *before* the info table pointer is overwritten,
-- because the old info table ptr is needed for reversion
; ret <- newTemp bWord
; emitRtsCallGen [(ret,NoHint)] rtsPackageId (fsLit "newCAF")
[ (CmmReg (CmmGlobal BaseReg), AddrHint),
......@@ -731,7 +724,7 @@ link_caf node _is_upd = do
; return hp_rel }
------------------------------------------------------------------------
-- Profiling
-- Profiling
------------------------------------------------------------------------
-- For "global" data constructors the description is simply occurrence
......@@ -739,16 +732,16 @@ link_caf node _is_upd = do
-- @closureDescription@ from the let binding information.
closureDescription :: DynFlags
-> Module -- Module
-> Name -- Id of closure binding
-> String
-- Not called for StgRhsCon which have global info tables built in
-- CgConTbls.lhs with a description generated from the data constructor
-> Module -- Module
-> Name -- Id of closure binding
-> String
-- Not called for StgRhsCon which have global info tables built in
-- CgConTbls.lhs with a description generated from the data constructor
closureDescription dflags mod_name name
= showSDocDump dflags (char '<' <>
(if isExternalName name
then ppr name -- ppr will include the module name prefix
else pprModule mod_name <> char '.' <> ppr name) <>
char '>')
(if isExternalName name
then ppr name -- ppr will include the module name prefix
else pprModule mod_name <> char '.' <> ppr name) <>
char '>')
-- showSDocDump, because we want to see the unique on the Name.
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment