Trailing whitespaces, code formatting, detabify
authorJan Stolarek <jan.stolarek@p.lodz.pl>
Tue, 20 Aug 2013 09:34:39 +0000 (10:34 +0100)
committerJan Stolarek <jan.stolarek@p.lodz.pl>
Tue, 20 Aug 2013 16:19:29 +0000 (17:19 +0100)
A major cleanup of trailing whitespaces and tabs in codeGen/
directory. I also adjusted code formatting in some places.

13 files changed:
compiler/codeGen/StgCmm.hs
compiler/codeGen/StgCmmBind.hs
compiler/codeGen/StgCmmClosure.hs
compiler/codeGen/StgCmmCon.hs
compiler/codeGen/StgCmmEnv.hs
compiler/codeGen/StgCmmExpr.hs
compiler/codeGen/StgCmmExtCode.hs
compiler/codeGen/StgCmmHeap.hs
compiler/codeGen/StgCmmLayout.hs
compiler/codeGen/StgCmmMonad.hs
compiler/codeGen/StgCmmPrim.hs
compiler/codeGen/StgCmmProf.hs
compiler/codeGen/StgCmmTicky.hs

index 6098e61..57b0cda 100644 (file)
@@ -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
index 0344f24..7cac6ad 100644 (file)
@@ -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.
 
index c891155..611a570 100644 (file)
@@ -1,7 +1,7 @@
 -----------------------------------------------------------------------------
 --
 -- Stg to C-- code generation:
--- 
+--
 -- The types   LambdaFormInfo
 --             ClosureInfo
 --
 -----------------------------------------------------------------------------
 
 {-# 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.
 --
index 9bfa22b..4f12948 100644 (file)
@@ -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)
 
 
index 1fdb364..77a3b4e 100644 (file)
@@ -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)
index bbb5937..00c6068 100644 (file)
@@ -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 -> ...
 
index 5057f1c..e710204 100644 (file)
@@ -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)
 
index b8962ce..76c0a4c 100644 (file)
@@ -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
index 06a47c1..c6e57d5 100644 (file)
@@ -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
index 251b679..37b0a26 100644 (file)
@@ -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
index 2c044fa..c11df70 100644 (file)
@@ -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)
index 3307604..b1eaa1c 100644 (file)
@@ -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)
-
index f520dc6..3b06d3b 100644 (file)
@@ -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 ()