compiler: de-lhs stgSyn/

Signed-off-by: Austin Seipp <austin@well-typed.com>

3 files changed, 144 insertions, 163 deletions

diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.hs
index 7807d895dc..5b22e67eaf 100644
--- a/compiler/stgSyn/CoreToStg.lhs
+++ b/compiler/stgSyn/CoreToStg.hs
@@ -1,4 +1,3 @@
-\begin{code}
 {-# LANGUAGE CPP #-}
 
 --
@@ -1192,4 +1191,3 @@ stgArity :: Id -> HowBound -> Arity
 stgArity _ (LetBound _ arity) = arity
 stgArity f ImportBound        = idArity f
 stgArity _ LambdaBound        = 0
-\end{code}
diff --git a/compiler/stgSyn/StgLint.lhs b/compiler/stgSyn/StgLint.hs
index a0fdf78d34..5bd25e3116 100644
--- a/compiler/stgSyn/StgLint.lhs
+++ b/compiler/stgSyn/StgLint.hs
@@ -1,9 +1,9 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
-%
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+
 \section[StgLint]{A ``lint'' pass to check for Stg correctness}
+-}
 
-\begin{code}
 {-# LANGUAGE CPP #-}
 
 module StgLint ( lintStgBindings ) where
@@ -23,7 +23,7 @@ import ErrUtils         ( MsgDoc, Severity(..), mkLocMessage )
 import TypeRep
 import Type
 import TyCon
-import Util 
+import Util
 import SrcLoc
 import Outputable
 import FastString
@@ -34,8 +34,8 @@ import Control.Monad
 import Data.Function
 
 #include "HsVersions.h"
-\end{code}
 
+{-
 Checks for
         (a) *some* type errors
         (b) locally-defined variables used but not defined
@@ -52,15 +52,15 @@ for Stg code that is currently perfectly acceptable for code
 generation.  Solution: don't use it!  (KSW 2000-05).
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection{``lint'' for various constructs}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 @lintStgBindings@ is the top-level interface function.
+-}
 
-\begin{code}
 lintStgBindings :: String -> [StgBinding] -> [StgBinding]
 
 lintStgBindings whodunnit binds
@@ -82,10 +82,7 @@ lintStgBindings whodunnit binds
         binders <- lintStgBinds bind
         addInScopeVars binders $
             lint_binds binds
-\end{code}
-
 
-\begin{code}
 lintStgArg :: StgArg -> LintM (Maybe Type)
 lintStgArg (StgLitArg lit) = return (Just (literalType lit))
 lintStgArg (StgVarArg v)   = lintStgVar v
@@ -93,9 +90,7 @@ lintStgArg (StgVarArg v)   = lintStgVar v
 lintStgVar :: Id -> LintM (Maybe Kind)
 lintStgVar v = do checkInScope v
                   return (Just (idType v))
-\end{code}
 
-\begin{code}
 lintStgBinds :: StgBinding -> LintM [Id] -- Returns the binders
 lintStgBinds (StgNonRec binder rhs) = do
     lint_binds_help (binder,rhs)
@@ -131,9 +126,7 @@ lint_binds_help (binder, rhs)
         return ()
   where
     binder_ty = idType binder
-\end{code}
 
-\begin{code}
 lintStgRhs :: StgRhs -> LintM (Maybe Type)   -- Just ty => type is exact
 
 lintStgRhs (StgRhsClosure _ _ _ _ _ [] expr)
@@ -150,9 +143,7 @@ lintStgRhs (StgRhsCon _ con args) = runMaybeT $ do
     MaybeT $ checkFunApp con_ty arg_tys (mkRhsConMsg con_ty arg_tys)
   where
     con_ty = dataConRepType con
-\end{code}
 
-\begin{code}
 lintStgExpr :: StgExpr -> LintM (Maybe Type) -- Just ty => type is exact
 
 lintStgExpr (StgLit l) = return (Just (literalType l))
@@ -274,16 +265,15 @@ lintAlt scrut_ty (DataAlt con, args, _, rhs) = do
     -- We give it its own copy, so it isn't overloaded.
     elem _ []       = False
     elem x (y:ys)   = x==y || elem x ys
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection[lint-monad]{The Lint monad}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 newtype LintM a = LintM
     { unLintM :: [LintLocInfo]      -- Locations
               -> IdSet              -- Local vars in scope
@@ -312,9 +302,7 @@ pp_binders bs
   where
     pp_binder b
       = hsep [ppr b, dcolon, ppr (idType b)]
-\end{code}
 
-\begin{code}
 initL :: LintM a -> Maybe MsgDoc
 initL (LintM m)
   = case (m [] emptyVarSet emptyBag) of { (_, errs) ->
@@ -345,9 +333,7 @@ thenL_ :: LintM a -> LintM b -> LintM b
 thenL_ m k = LintM $ \loc scope errs
   -> case unLintM m loc scope errs of
       (_, errs') -> unLintM k loc scope errs'
-\end{code}
 
-\begin{code}
 checkL :: Bool -> MsgDoc -> LintM ()
 checkL True  _   = return ()
 checkL False msg = addErrL msg
@@ -382,15 +368,15 @@ addInScopeVars ids m = LintM $ \loc scope errs
 --  then id
 --  else pprTrace "Shadowed vars:" (ppr (varSetElems shadowed))) $
     unLintM m loc (scope `unionVarSet` new_set) errs
-\end{code}
 
+{-
 Checking function applications: we only check that the type has the
 right *number* of arrows, we don't actually compare the types.  This
 is because we can't expect the types to be equal - the type
 applications and type lambdas that we use to calculate accurate types
 have long since disappeared.
+-}
 
-\begin{code}
 checkFunApp :: Type                 -- The function type
             -> [Type]               -- The arg type(s)
             -> MsgDoc              -- Error message
@@ -410,9 +396,9 @@ checkFunApp fun_ty arg_tys msg
   cfa accurate fun_ty []      -- Args have run out; that's fine
       = (if accurate then Just fun_ty else Nothing, Nothing)
 
-  cfa accurate fun_ty arg_tys@(arg_ty':arg_tys')   
+  cfa accurate fun_ty arg_tys@(arg_ty':arg_tys')
       | Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty
-      = if accurate && not (arg_ty `stgEqType` arg_ty') 
+      = if accurate && not (arg_ty `stgEqType` arg_ty')
         then (Nothing, Just msg)       -- Arg type mismatch
         else cfa accurate res_ty arg_tys'
 
@@ -421,7 +407,7 @@ checkFunApp fun_ty arg_tys msg
 
       | Just (tc,tc_args) <- splitTyConApp_maybe fun_ty
       , isNewTyCon tc
-      = if length tc_args < tyConArity tc 
+      = if length tc_args < tyConArity tc
         then WARN( True, text "cfa: unsaturated newtype" <+> ppr fun_ty $$ msg )
              (Nothing, Nothing)   -- This is odd, but I've seen it
         else cfa False (newTyConInstRhs tc tc_args) arg_tys
@@ -432,9 +418,7 @@ checkFunApp fun_ty arg_tys msg
 
       | otherwise
       = (Nothing, Nothing)
-\end{code}
 
-\begin{code}
 stgEqType :: Type -> Type -> Bool
 -- Compare types, but crudely because we have discarded
 -- both casts and type applications, so types might look
@@ -443,7 +427,7 @@ stgEqType :: Type -> Type -> Bool
 --
 -- Fundamentally this is a losing battle because of unsafeCoerce
 
-stgEqType orig_ty1 orig_ty2 
+stgEqType orig_ty1 orig_ty2
   = gos (repType orig_ty1) (repType orig_ty2)
   where
     gos :: RepType -> RepType -> Bool
@@ -456,18 +440,18 @@ stgEqType orig_ty1 orig_ty2
     go ty1 ty2
       | Just (tc1, tc_args1) <- splitTyConApp_maybe ty1
       , Just (tc2, tc_args2) <- splitTyConApp_maybe ty2
-      , let res = if tc1 == tc2 
+      , let res = if tc1 == tc2
                   then equalLength tc_args1 tc_args2 && and (zipWith (gos `on` repType) tc_args1 tc_args2)
-                  else  -- TyCons don't match; but don't bleat if either is a 
-                        -- family TyCon because a coercion might have made it 
+                  else  -- TyCons don't match; but don't bleat if either is a
+                        -- family TyCon because a coercion might have made it
                         -- equal to something else
                     (isFamilyTyCon tc1 || isFamilyTyCon tc2)
       = if res then True
-        else 
-        pprTrace "stgEqType: unequal" (vcat [ppr ty1, ppr ty2]) 
+        else
+        pprTrace "stgEqType: unequal" (vcat [ppr ty1, ppr ty2])
         False
 
-      | otherwise = True  -- Conservatively say "fine".  
+      | otherwise = True  -- Conservatively say "fine".
                           -- Type variables in particular
 
 checkInScope :: Id -> LintM ()
@@ -482,9 +466,7 @@ checkTys ty1 ty2 msg = LintM $ \loc _scope errs
   -> if (ty1 `stgEqType` ty2)
      then ((), errs)
      else ((), addErr errs msg loc)
-\end{code}
 
-\begin{code}
 _mkCaseAltMsg :: [StgAlt] -> MsgDoc
 _mkCaseAltMsg _alts
   = ($$) (text "In some case alternatives, type of alternatives not all same:")
@@ -551,4 +533,3 @@ mkUnLiftedTyMsg binder rhs
      ptext (sLit "has unlifted type") <+> quotes (ppr (idType binder)))
     $$
     (ptext (sLit "RHS:") <+> ppr rhs)
-\end{code}
diff --git a/compiler/stgSyn/StgSyn.lhs b/compiler/stgSyn/StgSyn.hs
index 2ecd573133..7577e837a8 100644
--- a/compiler/stgSyn/StgSyn.lhs
+++ b/compiler/stgSyn/StgSyn.hs
@@ -1,14 +1,14 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
 \section[StgSyn]{Shared term graph (STG) syntax for spineless-tagless code generation}
 
 This data type represents programs just before code generation (conversion to
 @Cmm@): basically, what we have is a stylised form of @CoreSyntax@, the style
 being one that happens to be ideally suited to spineless tagless code
 generation.
+-}
 
-\begin{code}
 {-# LANGUAGE CPP #-}
 
 module StgSyn (
@@ -69,13 +69,13 @@ import UniqSet
 import Unique      ( Unique )
 import Util
 import VarSet      ( IdSet, isEmptyVarSet )
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{@GenStgBinding@}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 As usual, expressions are interesting; other things are boring. Here
 are the boring things [except note the @GenStgRhs@], parameterised
@@ -83,20 +83,20 @@ with respect to binder and occurrence information (just as in
 @CoreSyn@):
 
 There is one SRT for each group of bindings.
+-}
 
-\begin{code}
 data GenStgBinding bndr occ
   = StgNonRec bndr (GenStgRhs bndr occ)
   | StgRec    [(bndr, GenStgRhs bndr occ)]
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{@GenStgArg@}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 data GenStgArg occ
   = StgVarArg  occ
   | StgLitArg  Literal
@@ -142,22 +142,22 @@ isAddrRep _       = False
 stgArgType :: StgArg -> Type
 stgArgType (StgVarArg v)   = idType v
 stgArgType (StgLitArg lit) = literalType lit
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{STG expressions}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 The @GenStgExpr@ data type is parameterised on binder and occurrence
 info, as before.
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsubsection{@GenStgExpr@ application}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 An application is of a function to a list of atoms [not expressions].
 Operationally, we want to push the arguments on the stack and call the
@@ -166,24 +166,26 @@ their closures first.)
 
 There is no constructor for a lone variable; it would appear as
 @StgApp var [] _@.
-\begin{code}
+-}
+
 type GenStgLiveVars occ = UniqSet occ
 
 data GenStgExpr bndr occ
   = StgApp
         occ             -- function
         [GenStgArg occ] -- arguments; may be empty
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsubsection{@StgConApp@ and @StgPrimApp@---saturated applications}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 There are a specialised forms of application, for constructors,
 primitives, and literals.
-\begin{code}
+-}
+
   | StgLit      Literal
 
         -- StgConApp is vital for returning unboxed tuples
@@ -196,32 +198,32 @@ primitives, and literals.
                 Type            -- Result type
                                 -- We need to know this so that we can
                                 -- assign result registers
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsubsection{@StgLam@}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 StgLam is used *only* during CoreToStg's work. Before CoreToStg has
 finished it encodes (\x -> e) as (let f = \x -> e in f)
+-}
 
-\begin{code}
   | StgLam
         [bndr]
         StgExpr    -- Body of lambda
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsubsection{@GenStgExpr@: case-expressions}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 This has the same boxed/unboxed business as Core case expressions.
-\begin{code}
+-}
+
   | StgCase
         (GenStgExpr bndr occ)
                     -- the thing to examine
@@ -248,13 +250,13 @@ This has the same boxed/unboxed business as Core case expressions.
         [GenStgAlt bndr occ]
                     -- The DEFAULT case is always *first*
                     -- if it is there at all
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsubsection{@GenStgExpr@: @let(rec)@-expressions}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 The various forms of let(rec)-expression encode most of the
 interesting things we want to do.
@@ -341,7 +343,8 @@ in e
 \end{enumerate}
 
 And so the code for let(rec)-things:
-\begin{code}
+-}
+
   | StgLet
         (GenStgBinding bndr occ)    -- right hand sides (see below)
         (GenStgExpr bndr occ)       -- body
@@ -358,50 +361,51 @@ And so the code for let(rec)-things:
 
         (GenStgBinding bndr occ)    -- right hand sides (see below)
         (GenStgExpr bndr occ)       -- body
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsubsection{@GenStgExpr@: @scc@ expressions}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 For @scc@ expressions we introduce a new STG construct.
+-}
 
-\begin{code}
   | StgSCC
         CostCentre             -- label of SCC expression
         !Bool                  -- bump the entry count?
         !Bool                  -- push the cost centre?
         (GenStgExpr bndr occ)  -- scc expression
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsubsection{@GenStgExpr@: @hpc@ expressions}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Finally for @hpc@ expressions we introduce a new STG construct.
+-}
 
-\begin{code}
   | StgTick
         Module                 -- the module of the source of this tick
         Int                    -- tick number
         (GenStgExpr bndr occ)  -- sub expression
 
 -- END of GenStgExpr
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{STG right-hand sides}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Here's the rest of the interesting stuff for @StgLet@s; the first
 flavour is for closures:
-\begin{code}
+-}
+
 data GenStgRhs bndr occ
   = StgRhsClosure
         CostCentreStack         -- CCS to be attached (default is CurrentCCS)
@@ -413,7 +417,8 @@ data GenStgRhs bndr occ
         [bndr]                  -- arguments; if empty, then not a function;
                                 -- as above, order is important.
         (GenStgExpr bndr occ)   -- body
-\end{code}
+
+{-
 An example may be in order.  Consider:
 \begin{verbatim}
 let t = \x -> \y -> ... x ... y ... p ... q in e
@@ -427,7 +432,8 @@ offsets from @Node@ into the closure, and the code ptr for the closure
 will be exactly that in parentheses above.
 
 The second flavour of right-hand-side is for constructors (simple but important):
-\begin{code}
+-}
+
   | StgRhsCon
         CostCentreStack  -- CCS to be attached (default is CurrentCCS).
                          -- Top-level (static) ones will end up with
@@ -456,10 +462,9 @@ rhsHasCafRefs (StgRhsCon _ _ args)
 stgArgHasCafRefs :: GenStgArg Id -> Bool
 stgArgHasCafRefs (StgVarArg id) = mayHaveCafRefs (idCafInfo id)
 stgArgHasCafRefs _ = False
-\end{code}
 
-Here's the @StgBinderInfo@ type, and its combining op:
-\begin{code}
+-- Here's the @StgBinderInfo@ type, and its combining op:
+
 data StgBinderInfo
   = NoStgBinderInfo
   | SatCallsOnly        -- All occurrences are *saturated* *function* calls
@@ -484,13 +489,13 @@ combineStgBinderInfo _            _            = NoStgBinderInfo
 pp_binder_info :: StgBinderInfo -> SDoc
 pp_binder_info NoStgBinderInfo = empty
 pp_binder_info SatCallsOnly    = ptext (sLit "sat-only")
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection[Stg-case-alternatives]{STG case alternatives}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Very like in @CoreSyntax@ (except no type-world stuff).
 
@@ -502,8 +507,8 @@ constructor might not have all the constructors visible. So
 mkStgAlgAlts (in CoreToStg) ensures that it gets the TyCon from the
 constructors or literals (which are guaranteed to have the Real McCoy)
 rather than from the scrutinee type.
+-}
 
-\begin{code}
 type GenStgAlt bndr occ
   = (AltCon,            -- alts: data constructor,
      [bndr],            -- constructor's parameters,
@@ -518,30 +523,30 @@ data AltType
   | UbxTupAlt Int       -- Unboxed tuple of this arity
   | AlgAlt    TyCon     -- Algebraic data type; the AltCons will be DataAlts
   | PrimAlt   TyCon     -- Primitive data type; the AltCons will be LitAlts
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection[Stg]{The Plain STG parameterisation}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 This happens to be the only one we use at the moment.
+-}
 
-\begin{code}
 type StgBinding  = GenStgBinding  Id Id
 type StgArg      = GenStgArg      Id
 type StgLiveVars = GenStgLiveVars Id
 type StgExpr     = GenStgExpr     Id Id
 type StgRhs      = GenStgRhs      Id Id
 type StgAlt      = GenStgAlt      Id Id
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsubsection[UpdateFlag-datatype]{@UpdateFlag@}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
 
@@ -550,8 +555,8 @@ updated or blackholed. An @Updatable@ closure should be updated after
 evaluation (and may be blackholed during evaluation). A @SingleEntry@
 closure will only be entered once, and so need not be updated but may
 safely be blackholed.
+-}
 
-\begin{code}
 data UpdateFlag = ReEntrant | Updatable | SingleEntry
 
 instance Outputable UpdateFlag where
@@ -564,19 +569,19 @@ isUpdatable :: UpdateFlag -> Bool
 isUpdatable ReEntrant   = False
 isUpdatable SingleEntry = False
 isUpdatable Updatable   = True
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsubsection{StgOp}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 An StgOp allows us to group together PrimOps and ForeignCalls.
 It's quite useful to move these around together, notably
 in StgOpApp and COpStmt.
+-}
 
-\begin{code}
 data StgOp
   = StgPrimOp  PrimOp
 
@@ -586,14 +591,13 @@ data StgOp
         -- The Unique is occasionally needed by the C pretty-printer
         -- (which lacks a unique supply), notably when generating a
         -- typedef for foreign-export-dynamic
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsubsection[Static Reference Tables]{@SRT@}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 There is one SRT per top-level function group. Each local binding and
 case expression within this binding group has a subrange of the whole
@@ -601,8 +605,8 @@ SRT, expressed as an offset and length.
 
 In CoreToStg we collect the list of CafRefs at each SRT site, which is later
 converted into the length and offset form by the SRT pass.
+-}
 
-\begin{code}
 data SRT
   = NoSRT
   | SRTEntries IdSet
@@ -619,18 +623,18 @@ pprSRT :: SRT -> SDoc
 pprSRT (NoSRT)          = ptext (sLit "_no_srt_")
 pprSRT (SRTEntries ids) = text "SRT:" <> ppr ids
 pprSRT (SRT off _ _)    = parens (ppr off <> comma <> text "*bitmap*")
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection[Stg-pretty-printing]{Pretty-printing}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Robin Popplestone asked for semi-colon separators on STG binds; here's
 hoping he likes terminators instead...  Ditto for case alternatives.
+-}
 
-\begin{code}
 pprGenStgBinding :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
                  => GenStgBinding bndr bdee -> SDoc
 
@@ -814,5 +818,3 @@ pprStgRhs (StgRhsCon cc con args)
 pprMaybeSRT :: SRT -> SDoc
 pprMaybeSRT (NoSRT) = empty
 pprMaybeSRT srt     = ptext (sLit "srt:") <> pprSRT srt
-\end{code}
-