unlit compiler/stranal/ modules

Reviewed By: austin

Differential Revision: https://phabricator.haskell.org/D541

3 files changed, 121 insertions, 129 deletions

diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.hs
index 5cb2655afd..9d9af64a7e 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.hs
@@ -1,12 +1,12 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
-%
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+
 
                         -----------------
                         A demand analysis
                         -----------------
+-}
 
-\begin{code}
 {-# LANGUAGE CPP #-}
 
 module DmdAnal ( dmdAnalProgram ) where
@@ -35,15 +35,15 @@ import TysPrim          ( realWorldStatePrimTy )
 import ErrUtils         ( dumpIfSet_dyn )
 import Name             ( getName, stableNameCmp )
 import Data.Function    ( on )
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Top level stuff}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
 dmdAnalProgram dflags fam_envs binds
   = do {
@@ -75,13 +75,13 @@ dmdAnalTopBind sigs (Rec pairs)
     (sigs', _, pairs')  = dmdFix TopLevel sigs pairs
                 -- We get two iterations automatically
                 -- c.f. the NonRec case above
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{The analyser itself}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Note [Ensure demand is strict]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -98,8 +98,8 @@ b) More important, consider
 c) The application rule wouldn't be right either
    Evaluating (f x) in a L demand does *not* cause
    evaluation of f in a C(L) demand!
+-}
 
-\begin{code}
 -- If e is complicated enough to become a thunk, its contents will be evaluated
 -- at most once, so oneify it.
 dmdTransformThunkDmd :: CoreExpr -> Demand -> Demand
@@ -366,8 +366,8 @@ dmdAnalAlt env dmd (con,bndrs,rhs)
                        idType (head bndrs) `eqType` realWorldStatePrimTy
     in
     (final_alt_ty, (con, bndrs', rhs'))
-\end{code}
 
+{-
 Note [Aggregated demand for cardinality]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We use different strategies for strictness and usage/cardinality to
@@ -424,8 +424,8 @@ in this case.
 
 In other words, for locally-bound lambdas we can infer
 one-shotness.
+-}
 
-\begin{code}
 addDataConPatDmds :: AltCon -> [Var] -> DmdType -> DmdType
 -- See Note [Add demands for strict constructors]
 addDataConPatDmds DEFAULT    _ dmd_ty = dmd_ty
@@ -438,8 +438,8 @@ addDataConPatDmds (DataAlt con) bndrs dmd_ty
                                    (filter isId bndrs)
                                    (dataConRepStrictness con)
                     , isMarkedStrict s ]
-\end{code}
 
+{-
 Note [Add demands for strict constructors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider this program (due to Roman):
@@ -472,13 +472,13 @@ if X is monomorphic, and has an UNPACK pragma, then this optimisation
 is even more important.  We don't want the wrapper to rebox an unboxed
 argument, and pass an Int to $wfoo!
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
                     Demand transformer
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 dmdTransform :: AnalEnv         -- The strictness environment
              -> Id              -- The function
              -> CleanDemand     -- The demand on the function
@@ -508,15 +508,14 @@ dmdTransform env var dmd
 
   | otherwise                                    -- Local non-letrec-bound thing
   = unitVarDmd var (mkOnceUsedDmd dmd)
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Bindings}
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
+*                                                                      *
+************************************************************************
+-}
 
 -- Recursive bindings
 dmdFix :: TopLevelFlag
@@ -653,8 +652,8 @@ unpackTrivial (Cast e _)              = unpackTrivial e
 unpackTrivial (Lam v e) | isTyVar v   = unpackTrivial e
 unpackTrivial (App e a) | isTypeArg a = unpackTrivial e
 unpackTrivial _                       = Nothing
-\end{code}
 
+{-
 Note [Demand analysis for trivial right-hand sides]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
@@ -697,13 +696,13 @@ the whole function gets the CPR property if we do.
 So for the demand on the body of a RHS we use a product demand if it's
 a product type.
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection{Strictness signatures and types}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 unitVarDmd :: Var -> Demand -> DmdType
 unitVarDmd var dmd
   = DmdType (unitVarEnv var dmd) [] topRes
@@ -738,15 +737,15 @@ addLazyFVs dmd_ty lazy_fvs
         -- which floats out of the defn for h.  Without the modifyEnv, that
         -- L demand doesn't get both'd with the Bot coming up from the inner
         -- call to f.  So we just get an L demand for x for g.
-\end{code}
 
+{-
 Note [Do not strictify the argument dictionaries of a dfun]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The typechecker can tie recursive knots involving dfuns, so we do the
 conservative thing and refrain from strictifying a dfun's argument
 dictionaries.
+-}
 
-\begin{code}
 annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var)
 -- The returned env has the var deleted
 -- The returned var is annotated with demand info
@@ -796,8 +795,8 @@ annotateLamIdBndr env arg_of_dfun dmd_ty one_shot id
 deleteFVs :: DmdType -> [Var] -> DmdType
 deleteFVs (DmdType fvs dmds res) bndrs
   = DmdType (delVarEnvList fvs bndrs) dmds res
-\end{code}
 
+{-
 Note [CPR for sum types]
 ~~~~~~~~~~~~~~~~~~~~~~~~
 At the moment we do not do CPR for let-bindings that
@@ -991,13 +990,13 @@ Then if <body> uses 'y', then transitively it uses 'x', and we must not
 forget that fact, otherwise we might make 'x' absent when it isn't.
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection{Strictness signatures}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 type DFunFlag = Bool  -- indicates if the lambda being considered is in the
                       -- sequence of lambdas at the top of the RHS of a dfun
 notArgOfDfun :: DFunFlag
@@ -1124,8 +1123,7 @@ dumpStrSig binds = vcat (map printId ids)
   printId id | isExportedId id = ppr id <> colon <+> pprIfaceStrictSig (idStrictness id)
              | otherwise       = empty
 
-\end{code}
-
+{-
 Note [Initial CPR for strict binders]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 CPR is initialized for a lambda binder in an optimistic manner, i.e,
@@ -1185,3 +1183,4 @@ of the Id, and start from "bottom".  Nowadays the Id can have a current
 strictness, because interface files record strictness for nested bindings.
 To know when we are in the first iteration, we look at the ae_virgin
 field of the AnalEnv.
+-}
diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.hs
index d2c7b3da1d..eedababb43 100644
--- a/compiler/stranal/WorkWrap.lhs
+++ b/compiler/stranal/WorkWrap.hs
@@ -1,9 +1,9 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
-%
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+
 \section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser}
+-}
 
-\begin{code}
 {-# LANGUAGE CPP #-}
 module WorkWrap ( wwTopBinds ) where
 
@@ -26,8 +26,8 @@ import FamInstEnv
 import MonadUtils
 
 #include "HsVersions.h"
-\end{code}
 
+{-
 We take Core bindings whose binders have:
 
 \begin{enumerate}
@@ -53,26 +53,26 @@ then only one worker/wrapper doing both transformations is produced;
 these workers/wrappers (this is where we get STRICTNESS and CPR pragma
 info for exported values).
 \end{enumerate}
+-}
 
-\begin{code}
 wwTopBinds :: DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram
 
 wwTopBinds dflags fam_envs us top_binds
   = initUs_ us $ do
     top_binds' <- mapM (wwBind dflags fam_envs) top_binds
     return (concat top_binds')
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection[wwBind-wwExpr]{@wwBind@ and @wwExpr@}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 @wwBind@ works on a binding, trying each \tr{(binder, expr)} pair in
 turn.  Non-recursive case first, then recursive...
+-}
 
-\begin{code}
 wwBind  :: DynFlags
         -> FamInstEnvs
         -> CoreBind
@@ -92,14 +92,14 @@ wwBind dflags fam_envs (Rec pairs)
   where
     do_one (binder, rhs) = do new_rhs <- wwExpr dflags fam_envs rhs
                               tryWW dflags fam_envs Recursive binder new_rhs
-\end{code}
 
+{-
 @wwExpr@ basically just walks the tree, looking for appropriate
 annotations that can be used. Remember it is @wwBind@ that does the
 matching by looking for strict arguments of the correct type.
 @wwExpr@ is a version that just returns the ``Plain'' Tree.
+-}
 
-\begin{code}
 wwExpr :: DynFlags -> FamInstEnvs -> CoreExpr -> UniqSM CoreExpr
 
 wwExpr _      _ e@(Type {}) = return e
@@ -131,13 +131,13 @@ wwExpr dflags fam_envs (Case expr binder ty alts) = do
     ww_alt (con, binders, rhs) = do
         new_rhs <- wwExpr dflags fam_envs rhs
         return (con, binders, new_rhs)
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection[tryWW]{@tryWW@: attempt a worker/wrapper pair}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 @tryWW@ just accumulates arguments, converts strictness info from the
 front-end into the proper form, then calls @mkWwBodies@ to do
@@ -262,8 +262,8 @@ it appears in the first place in the defining module.
 At one stage I tried making the wrapper inlining always-active, and
 that had a very bad effect on nofib/imaginary/x2n1; a wrapper was
 inlined before the specialisation fired.
+-}
 
-\begin{code}
 tryWW   :: DynFlags
         -> FamInstEnvs
         -> RecFlag
@@ -405,8 +405,8 @@ get_one_shots (Lam b e)
   | otherwise = get_one_shots e
 get_one_shots (Tick _ e) = get_one_shots e
 get_one_shots _          = []
-\end{code}
 
+{-
 Note [Do not split void functions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider this rather common form of binding:
@@ -451,8 +451,8 @@ Notice that x certainly has the CPR property now!
 In fact, splitThunk uses the function argument w/w splitting
 function, so that if x's demand is deeper (say U(U(L,L),L))
 then the splitting will go deeper too.
+-}
 
-\begin{code}
 -- See Note [Thunk splitting]
 -- splitThunk converts the *non-recursive* binding
 --      x = e
@@ -474,4 +474,3 @@ splitThunk dflags fam_envs is_rec fn_id rhs
        ; if useful then ASSERT2( isNonRec is_rec, ppr fn_id ) -- The thunk must be non-recursive
                    return res
                    else return [(fn_id, rhs)] }
-\end{code}
diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.hs
index 1f1fbdf745..8c96afadd6 100644
--- a/compiler/stranal/WwLib.lhs
+++ b/compiler/stranal/WwLib.hs
@@ -1,9 +1,9 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
-%
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+
 \section[WwLib]{A library for the ``worker\/wrapper'' back-end to the strictness analyser}
+-}
 
-\begin{code}
 {-# LANGUAGE CPP #-}
 
 module WwLib ( mkWwBodies, mkWWstr, mkWorkerArgs
@@ -38,14 +38,13 @@ import Util
 import Outputable
 import DynFlags
 import FastString
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Here's an example.  The original function is:
 
@@ -100,15 +99,15 @@ same, we ``revise'' the strictness info, so that we won't propagate
 the unusable strictness-info into the interfaces.
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection{The worker wrapper core}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 @mkWwBodies@ is called when doing the worker\/wrapper split inside a module.
+-}
 
-\begin{code}
 mkWwBodies :: DynFlags
            -> FamInstEnvs
            -> Type                                  -- Type of original function
@@ -165,8 +164,7 @@ mkWwBodies dflags fam_envs fun_ty demands res_info one_shots
       | otherwise
       = False
 
-\end{code}
-
+{-
 Note [Always do CPR w/w]
 ~~~~~~~~~~~~~~~~~~~~~~~~
 At one time we refrained from doing CPR w/w for thunks, on the grounds that
@@ -180,11 +178,11 @@ property, but now doesn't and there a cascade of disaster.  A good example
 is Trac #5920.
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection{Making wrapper args}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 During worker-wrapper stuff we may end up with an unlifted thing
 which we want to let-bind without losing laziness.  So we
@@ -196,8 +194,8 @@ add a void argument.  E.g.
         f  = /\ a -> \x y z -> fw realworld
 
 We use the state-token type which generates no code.
+-}
 
-\begin{code}
 mkWorkerArgs :: DynFlags -> [Var]
              -> OneShotInfo  -- Whether all arguments are one-shot
              -> Type    -- Type of body
@@ -216,8 +214,8 @@ mkWorkerArgs dflags args all_one_shot res_ty
 
       -- see Note [All One-Shot Arguments of a Worker]
       newArg = setIdOneShotInfo voidArgId all_one_shot
-\end{code}
 
+{-
 Note [Protecting the last value argument]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 If the user writes (\_ -> E), they might be intentionally disallowing
@@ -255,11 +253,11 @@ If we made the void-arg one-shot we might inline an expensive
 computation for y, which would be terrible!
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection{Coercion stuff}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 We really want to "look through" coerces.
 Reason: I've seen this situation:
@@ -285,8 +283,8 @@ Now we'll inline f to get
 
 Now we'll see that fw has arity 1, and will arity expand
 the \x to get what we want.
+-}
 
-\begin{code}
 -- mkWWargs just does eta expansion
 -- is driven off the function type and arity.
 -- It chomps bites off foralls, arrows, newtypes
@@ -356,8 +354,8 @@ mk_wrap_arg uniq ty dmd one_shot
   = mkSysLocal (fsLit "w") uniq ty
        `setIdDemandInfo` dmd
        `setIdOneShotInfo` one_shot
-\end{code}
 
+{-
 Note [Freshen type variables]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Wen we do a worker/wrapper split, we must not use shadowed names,
@@ -369,13 +367,13 @@ variables *are* mentioned in <blah>, so we must substitute.
 
 That's why we carry the TvSubst through mkWWargs
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection{Strictness stuff}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 mkWWstr :: DynFlags
         -> FamInstEnvs
         -> [Var]                                -- Wrapper args; have their demand info on them
@@ -397,8 +395,7 @@ mkWWstr dflags fam_envs (arg : args) = do
     (useful2, args2, wrap_fn2, work_fn2) <- mkWWstr dflags fam_envs args
     return (useful1 || useful2, args1 ++ args2, wrap_fn1 . wrap_fn2, work_fn1 . work_fn2)
 
-\end{code}
-
+{-
 Note [Unpacking arguments with product and polymorphic demands]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The argument is unpacked in a case if it has a product type and has a
@@ -425,8 +422,8 @@ to unbox its second argument.  This actually happened in GHC's onwn
 source code, in Packages.applyPackageFlag, which ended up un-boxing
 the enormous DynFlags tuple, and being strict in the
 as-yet-un-filled-in pkgState files.
+-}
 
-\begin{code}
 ----------------------
 -- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn)
 --   *  wrap_fn assumes wrap_arg is in scope,
@@ -494,15 +491,15 @@ mkWWstr_one dflags fam_envs arg
         -- If the wrapper argument is a one-shot lambda, then
         -- so should (all) the corresponding worker arguments be
         -- This bites when we do w/w on a case join point
-    set_worker_arg_info worker_arg demand 
+    set_worker_arg_info worker_arg demand
       = worker_arg `setIdDemandInfo`  demand
                    `setIdOneShotInfo` one_shot
 
 ----------------------
 nop_fn :: CoreExpr -> CoreExpr
 nop_fn body = body
-\end{code}
 
+{-
 Note [mkWWstr and unsafeCoerce]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 By using unsafeCoerce, it is possible to make the number of demands fail to
@@ -510,11 +507,11 @@ match the number of constructor arguments; this happened in Trac #8037.
 If so, the worker/wrapper split doesn't work right and we get a Core Lint
 bug.  The fix here is simply to decline to do w/w if that happens.
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
          Type scrutiny that is specfic to demand analysis
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Note [Do not unpack class dictionaries]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -535,8 +532,8 @@ Moreover, dictinoaries can have a lot of fields, so unpacking them can
 increase closure sizes.
 
 Conclusion: don't unpack dictionaries.
+-}
 
-\begin{code}
 deepSplitProductType_maybe :: FamInstEnvs -> Type -> Maybe (DataCon, [Type], [Type], Coercion)
 -- If    deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co)
 -- then  dc @ tys (args::arg_tys) :: rep_ty
@@ -586,14 +583,13 @@ findTypeShape fam_envs ty
 
   | otherwise
   = TsUnk
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{CPR stuff}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 
 @mkWWcpr@ takes the worker/wrapper pair produced from the strictness
@@ -603,9 +599,8 @@ tuple and re-produces the correct structured output.
 
 The non-CPR results appear ordered in the unboxed tuple as if by a
 left-to-right traversal of the result structure.
+-}
 
-
-\begin{code}
 mkWWcpr :: FamInstEnvs
         -> Type                              -- function body type
         -> DmdResult                         -- CPR analysis results
@@ -671,8 +666,8 @@ mkUnpackCase scrut co uniq boxing_con unpk_args body
   where
     casted_scrut = scrut `mkCast` co
     bndr = mk_ww_local uniq (exprType casted_scrut)
-\end{code}
 
+{-
 Note [non-algebraic or open body type warning]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
@@ -711,11 +706,11 @@ including the case itself in the cost centre, since it is morally
 part of the function (post transformation) anyway.
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection{Utilities}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Note [Absent errors]
 ~~~~~~~~~~~~~~~~~~~~
@@ -738,8 +733,8 @@ every primitive type, so the function is partial.
     is dead code, which is fragile, and indeed failed when
     profiling is on, which disables various optimisations.  So
     using a literal will do.]
+-}
 
-\begin{code}
 mk_absent_let :: DynFlags -> Id -> Maybe (CoreExpr -> CoreExpr)
 mk_absent_let dflags arg
   | not (isUnLiftedType arg_ty)
@@ -773,4 +768,3 @@ sanitiseCaseBndr id = id `setIdInfo` vanillaIdInfo
 
 mk_ww_local :: Unique -> Type -> Id
 mk_ww_local uniq ty = mkSysLocal (fsLit "ww") uniq ty
-\end{code}