compiler: de-lhs coreSyn/
authorAustin Seipp <austin@well-typed.com>
Wed, 3 Dec 2014 18:43:05 +0000 (12:43 -0600)
committerAustin Seipp <austin@well-typed.com>
Wed, 3 Dec 2014 18:43:05 +0000 (12:43 -0600)
Signed-off-by: Austin Seipp <austin@well-typed.com>
12 files changed:
compiler/coreSyn/CoreArity.hs [moved from compiler/coreSyn/CoreArity.lhs with 96% similarity]
compiler/coreSyn/CoreFVs.hs [moved from compiler/coreSyn/CoreFVs.lhs with 90% similarity]
compiler/coreSyn/CoreLint.hs [moved from compiler/coreSyn/CoreLint.lhs with 92% similarity]
compiler/coreSyn/CorePrep.hs [moved from compiler/coreSyn/CorePrep.lhs with 95% similarity]
compiler/coreSyn/CoreSubst.hs [moved from compiler/coreSyn/CoreSubst.lhs with 95% similarity]
compiler/coreSyn/CoreSyn.hs [moved from compiler/coreSyn/CoreSyn.lhs with 92% similarity]
compiler/coreSyn/CoreTidy.hs [moved from compiler/coreSyn/CoreTidy.lhs with 92% similarity]
compiler/coreSyn/CoreUnfold.hs [moved from compiler/coreSyn/CoreUnfold.lhs with 96% similarity]
compiler/coreSyn/CoreUtils.hs [moved from compiler/coreSyn/CoreUtils.lhs with 91% similarity]
compiler/coreSyn/MkCore.hs [moved from compiler/coreSyn/MkCore.lhs with 90% similarity]
compiler/coreSyn/PprCore.hs [moved from compiler/coreSyn/PprCore.lhs with 93% similarity]
compiler/coreSyn/TrieMap.hs [moved from compiler/coreSyn/TrieMap.lhs with 91% similarity]

similarity index 96%
rename from compiler/coreSyn/CoreArity.lhs
rename to compiler/coreSyn/CoreArity.hs
index 37517d6..5128891 100644 (file)
@@ -1,11 +1,11 @@
-%
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
 
         Arity and eta expansion
+-}
 
-\begin{code}
 {-# LANGUAGE CPP #-}
 
 -- | Arity and eta expansion
@@ -34,13 +34,13 @@ import Outputable
 import FastString
 import Pair
 import Util     ( debugIsOn )
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
               manifestArity and exprArity
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
 It tells how many things the expression can be applied to before doing
@@ -65,8 +65,8 @@ won't be eta-expanded.
 And in any case it seems more robust to have exprArity be a bit more intelligent.
 But note that   (\x y z -> f x y z)
 should have arity 3, regardless of f's arity.
+-}
 
-\begin{code}
 manifestArity :: CoreExpr -> Arity
 -- ^ manifestArity sees how many leading value lambdas there are,
 --   after looking through casts
@@ -142,8 +142,8 @@ exprBotStrictness_maybe e
     env    = AE { ae_ped_bot = True, ae_cheap_fn = \ _ _ -> False }
     sig ar = mkClosedStrictSig (replicate ar topDmd) botRes
                   -- For this purpose we can be very simple
-\end{code}
 
+{-
 Note [exprArity invariant]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 exprArity has the following invariant:
@@ -238,11 +238,11 @@ When we come to an application we check that the arg is trivial.
    unknown, hence arity 0
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
            Computing the "arity" of an expression
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Note [Definition of arity]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -465,7 +465,8 @@ Then  f             :: AT [False,False] ATop
       f <expensive> :: AT []            ATop
 
 -------------------- Main arity code ----------------------------
-\begin{code}
+-}
+
 -- See Note [ArityType]
 data ArityType = ATop [OneShotInfo] | ABot Arity
      -- There is always an explicit lambda
@@ -559,8 +560,8 @@ rhsEtaExpandArity dflags cheap_app e
     has_lam (Tick _ e) = has_lam e
     has_lam (Lam b e)  = isId b || has_lam e
     has_lam _          = False
-\end{code}
 
+{-
 Note [Arity analysis]
 ~~~~~~~~~~~~~~~~~~~~~
 The motivating example for arity analysis is this:
@@ -628,8 +629,8 @@ PAPSs
 because that might in turn make g inline (if it has an inline pragma),
 which we might not want.  After all, INLINE pragmas say "inline only
 when saturated" so we don't want to be too gung-ho about saturating!
+-}
 
-\begin{code}
 arityLam :: Id -> ArityType -> ArityType
 arityLam id (ATop as) = ATop (idOneShotInfo id : as)
 arityLam _  (ABot n)  = ABot (n+1)
@@ -660,8 +661,8 @@ andArityType (ATop as)  (ATop bs) = ATop (as `combine` bs)
     combine (a:as) (b:bs) = (a `bestOneShot` b) : combine as bs
     combine []     bs     = takeWhile isOneShotInfo bs
     combine as     []     = takeWhile isOneShotInfo as
-\end{code}
 
+{-
 Note [Combining case branches]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
@@ -679,8 +680,8 @@ lambda wasn't one-shot we don't want to do this.
 
 So we combine the best of the two branches, on the (slightly dodgy)
 basis that if we know one branch is one-shot, then they all must be.
+-}
 
-\begin{code}
 ---------------------------
 type CheapFun = CoreExpr -> Maybe Type -> Bool
         -- How to decide if an expression is cheap
@@ -767,14 +768,13 @@ arityType env (Tick t e)
   | not (tickishIsCode t)     = arityType env e
 
 arityType _ _ = vanillaArityType
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
               The main eta-expander
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 We go for:
    f = \x1..xn -> N  ==>   f = \x1..xn y1..ym -> N y1..ym
@@ -822,8 +822,8 @@ Note that SCCs are not treated specially by etaExpand.  If we have
         etaExpand 2 (\x -> scc "foo" e)
         = (\xy -> (scc "foo" e) y)
 So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
+-}
 
-\begin{code}
 -- | @etaExpand n us e ty@ returns an expression with
 -- the same meaning as @e@, but with arity @n@.
 --
@@ -1001,4 +1001,3 @@ freshEtaId n subst ty
         eta_id' = uniqAway (getTvInScope subst) $
                   mkSysLocal (fsLit "eta") (mkBuiltinUnique n) ty'
         subst'  = extendTvInScope subst eta_id'
-\end{code}
similarity index 90%
rename from compiler/coreSyn/CoreFVs.lhs
rename to compiler/coreSyn/CoreFVs.hs
index fc804d7..af475ba 100644 (file)
@@ -1,10 +1,10 @@
-%
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
 Taken quite directly from the Peyton Jones/Lester paper.
+-}
 
-\begin{code}
 {-# LANGUAGE CPP #-}
 
 -- | A module concerned with finding the free variables of an expression.
@@ -20,7 +20,7 @@ module CoreFVs (
         exprSomeFreeVars, exprsSomeFreeVars,
 
         -- * Free variables of Rules, Vars and Ids
-        varTypeTyVars, 
+        varTypeTyVars,
         idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,
         idRuleVars, idRuleRhsVars, stableUnfoldingVars,
         ruleRhsFreeVars, ruleFreeVars, rulesFreeVars,
@@ -50,14 +50,13 @@ import Maybes( orElse )
 import Util
 import BasicTypes( Activation )
 import Outputable
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \section{Finding the free variables of an expression}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 This function simply finds the free variables of an expression.
 So far as type variables are concerned, it only finds tyvars that are
@@ -66,8 +65,8 @@ So far as type variables are concerned, it only finds tyvars that are
         * free in the type of a binder,
 
 but not those that are free in the type of variable occurrence.
+-}
 
-\begin{code}
 -- | Find all locally-defined free Ids or type variables in an expression
 exprFreeVars :: CoreExpr -> VarSet
 exprFreeVars = exprSomeFreeVars isLocalVar
@@ -101,14 +100,11 @@ exprsSomeFreeVars fv_cand = mapUnionVarSet (exprSomeFreeVars fv_cand)
 
 -- | Predicate on possible free variables: returns @True@ iff the variable is interesting
 type InterestingVarFun = Var -> Bool
-\end{code}
 
-
-\begin{code}
 type FV = InterestingVarFun
         -> VarSet               -- Locally bound
         -> VarSet               -- Free vars
- -- Return the vars that are both (a) interesting 
+ -- Return the vars that are both (a) interesting
  --                           and (b) not locally bound
  -- See function keep_it
 
@@ -172,10 +168,7 @@ addBndr bndr fv fv_cand in_scope
 
 addBndrs :: [CoreBndr] -> FV -> FV
 addBndrs bndrs fv = foldr addBndr fv bndrs
-\end{code}
-
 
-\begin{code}
 expr_fvs :: CoreExpr -> FV
 
 expr_fvs (Type ty)       = someVars (tyVarsOfType ty)
@@ -213,16 +206,15 @@ exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs
 tickish_fvs :: Tickish Id -> FV
 tickish_fvs (Breakpoint _ ids) = someVars (mkVarSet ids)
 tickish_fvs _ = noVars
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \section{Free names}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 -- | ruleLhsOrphNames is used when deciding whether
 -- a rule is an orphan.  In particular, suppose that T is defined in this
 -- module; we want to avoid declaring that a rule like:
@@ -268,15 +260,15 @@ exprOrphNames e
 -- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details
 exprsOrphNames :: [CoreExpr] -> NameSet
 exprsOrphNames es = foldr (unionNameSet . exprOrphNames) emptyNameSet es
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \section[freevars-everywhere]{Attaching free variables to every sub-expression}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 -- | Those variables free in the right hand side of a rule
 ruleRhsFreeVars :: CoreRule -> VarSet
 ruleRhsFreeVars (BuiltinRule {}) = noFVs
@@ -314,8 +306,8 @@ ruleLhsFreeIds :: CoreRule -> VarSet
 ruleLhsFreeIds (BuiltinRule {}) = noFVs
 ruleLhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args })
   = addBndrs bndrs (exprs_fvs args) isLocalId emptyVarSet
-\end{code}
 
+{-
 Note [Rule free var hack]  (Not a hack any more)
 ~~~~~~~~~~~~~~~~~~~~~~~~~
 We used not to include the Id in its own rhs free-var set.
@@ -326,8 +318,8 @@ However, the occurrence analyser distinguishes "non-rule loop breakers"
 from "rule-only loop breakers" (see BasicTypes.OccInfo).  So it will
 put this 'f' in a Rec block, but will mark the binding as a non-rule loop
 breaker, which is perfectly inlinable.
+-}
 
-\begin{code}
 -- |Free variables of a vectorisation declaration
 vectsFreeVars :: [CoreVect] -> VarSet
 vectsFreeVars = mapUnionVarSet vectFreeVars
@@ -338,19 +330,18 @@ vectsFreeVars = mapUnionVarSet vectFreeVars
     vectFreeVars (VectClass _)    = noFVs
     vectFreeVars (VectInst _)     = noFVs
       -- this function is only concerned with values, not types
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \section[freevars-everywhere]{Attaching free variables to every sub-expression}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 The free variable pass annotates every node in the expression with its
 NON-GLOBAL free variables and type variables.
+-}
 
-\begin{code}
 -- | Every node in a binding group annotated with its
 -- (non-global) free variables, both Ids and TyVars
 type CoreBindWithFVs = AnnBind Id VarSet
@@ -444,22 +435,21 @@ stableUnfoldingVars :: Unfolding -> Maybe VarSet
 stableUnfoldingVars unf
   = case unf of
       CoreUnfolding { uf_tmpl = rhs, uf_src = src }
-         | isStableSource src          
+         | isStableSource src
          -> Just (exprFreeVars rhs)
-      DFunUnfolding { df_bndrs = bndrs, df_args = args } 
+      DFunUnfolding { df_bndrs = bndrs, df_args = args }
          -> Just (exprs_fvs args isLocalVar (mkVarSet bndrs))
             -- DFuns are top level, so no fvs from types of bndrs
       _other -> Nothing
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Free variables (and types)}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 freeVars :: CoreExpr -> CoreExprWithFVs
 -- ^ Annotate a 'CoreExpr' with its (non-global) free type and value variables at every tree node
 freeVars (Var v)
@@ -541,5 +531,3 @@ freeVars (Tick tickish expr)
 freeVars (Type ty) = (tyVarsOfType ty, AnnType ty)
 
 freeVars (Coercion co) = (tyCoVarsOfCo co, AnnCoercion co)
-\end{code}
-
similarity index 92%
rename from compiler/coreSyn/CoreLint.lhs
rename to compiler/coreSyn/CoreLint.hs
index 7a050a8..26519cc 100644 (file)
@@ -1,12 +1,11 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
 
-%
-% (c) The University of Glasgow 2006
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
-%
 
 A ``lint'' pass to check for Core correctness
+-}
 
-\begin{code}
 {-# LANGUAGE CPP #-}
 {-# OPTIONS_GHC -fprof-auto #-}
 
@@ -48,8 +47,8 @@ import Control.Monad
 import MonadUtils
 import Data.Maybe
 import Pair
-\end{code}
 
+{-
 Note [GHC Formalism]
 ~~~~~~~~~~~~~~~~~~~~
 This file implements the type-checking algorithm for System FC, the "official"
@@ -62,11 +61,11 @@ just about anything in this file or you change other types/functions throughout
 the Core language (all signposted to this note), you should update that
 formalism. See docs/core-spec/README for more info about how to do so.
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Checks that a set of core bindings is well-formed.  The PprStyle and String
 just control what we print in the event of an error.  The Bool value
@@ -111,9 +110,8 @@ to the type of the binding variable.  lintBinders does this.
 For Ids, the type-substituted Id is added to the in_scope set (which
 itself is part of the TvSubst we are carrying down), and when we
 find an occurrence of an Id, we fetch it from the in-scope set.
+-}
 
-
-\begin{code}
 lintCoreBindings :: [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc)
 --   Returns (warnings, errors)
 -- If you edit this function, you may need to update the GHC formalism
@@ -149,18 +147,18 @@ lintCoreBindings local_in_scope binds
     -- See Note [GHC Formalism]
     lint_bind (Rec prs)         = mapM_ (lintSingleBinding TopLevel Recursive) prs
     lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection[lintUnfolding]{lintUnfolding}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 We use this to check all unfoldings that come in from interfaces
 (it is very painful to catch errors otherwise):
+-}
 
-\begin{code}
 lintUnfolding :: SrcLoc
               -> [Var]          -- Treat these as in scope
               -> CoreExpr
@@ -185,17 +183,17 @@ lintExpr vars expr
     (_warns, errs) = initL (addLoc TopLevelBindings $
                             addInScopeVars vars     $
                             lintCoreExpr expr)
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection[lintCoreBinding]{lintCoreBinding}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Check a core binding, returning the list of variables bound.
+-}
 
-\begin{code}
 lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM ()
 -- If you edit this function, you may need to update the GHC formalism
 -- See Note [GHC Formalism]
@@ -263,15 +261,15 @@ lintIdUnfolding bndr bndr_ty (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
        ; checkTys bndr_ty ty (mkRhsMsg bndr (ptext (sLit "unfolding")) ty) }
 lintIdUnfolding  _ _ _
   = return ()       -- We could check more
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection[lintCoreExpr]{lintCoreExpr}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 --type InKind      = Kind       -- Substitution not yet applied
 type InType      = Type
 type InCoercion  = Coercion
@@ -415,8 +413,7 @@ lintCoreExpr (Coercion co)
   = do { (_kind, ty1, ty2, role) <- lintInCo co
        ; return (mkCoercionType role ty1 ty2) }
 
-\end{code}
-
+{-
 Note [Kind instantiation in coercions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider the following coercion axiom:
@@ -436,16 +433,16 @@ kind coercions and produce the following substitution which is to be
 applied in the type variables:
   k_ag   ~~>   * -> *
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection[lintCoreArgs]{lintCoreArgs}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 The basic version of these functions checks that the argument is a
 subtype of the required type, as one would expect.
+-}
 
-\begin{code}
 lintCoreArg  :: OutType -> CoreArg -> LintM OutType
 lintCoreArg fun_ty (Type arg_ty)
   = do { arg_ty' <- applySubstTy arg_ty
@@ -496,9 +493,7 @@ lintValApp arg fun_ty arg_ty
   where
     err1 = mkAppMsg       fun_ty arg_ty arg
     err2 = mkNonFunAppMsg fun_ty arg_ty arg
-\end{code}
 
-\begin{code}
 checkTyKind :: OutTyVar -> OutType -> LintM ()
 -- Both args have had substitution applied
 
@@ -528,16 +523,15 @@ checkDeadIdOcc id
                 (ptext (sLit "Occurrence of a dead Id") <+> ppr id) }
   | otherwise
   = return ()
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection[lintCoreAlts]{lintCoreAlts}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
 -- a) Check that the alts are non-empty
 -- b1) Check that the DEFAULT comes first, if it exists
@@ -574,9 +568,7 @@ checkCaseAlts e ty alts =
     is_infinite_ty = case tyConAppTyCon_maybe ty of
                         Nothing    -> False
                         Just tycon -> isPrimTyCon tycon
-\end{code}
 
-\begin{code}
 checkAltExpr :: CoreExpr -> OutType -> LintM ()
 checkAltExpr expr ann_ty
   = do { actual_ty <- lintCoreExpr expr
@@ -620,15 +612,15 @@ lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
 
   | otherwise   -- Scrut-ty is wrong shape
   = addErrL (mkBadAltMsg scrut_ty alt)
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection[lint-types]{Types}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 -- When we lint binders, we (one at a time and in order):
 --  1. Lint var types or kinds (possibly substituting)
 --  2. Add the binder to the in scope set, and if its a coercion var,
@@ -675,20 +667,19 @@ lintAndScopeId id linterF
   = do { ty <- lintInTy (idType id)
        ; let id' = setIdType id ty
        ; addInScopeVar id' $ (linterF id') }
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
              Types and kinds
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 We have a single linter for types and kinds.  That is convenient
 because sometimes it's not clear whether the thing we are looking
 at is a type or a kind.
+-}
 
-\begin{code}
 lintInTy :: InType -> LintM LintedType
 -- Types only, not kinds
 -- Check the type, and apply the substitution to it
@@ -746,10 +737,6 @@ lintType (ForAllTy tv ty)
 
 lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty)
 
-\end{code}
-
-
-\begin{code}
 lintKind :: OutKind -> LintM ()
 -- If you edit this function, you may need to update the GHC formalism
 -- See Note [GHC Formalism]
@@ -757,10 +744,7 @@ lintKind k = do { sk <- lintType k
                 ; unless (isSuperKind sk)
                          (addErrL (hang (ptext (sLit "Ill-kinded kind:") <+> ppr k)
                                       2 (ptext (sLit "has kind:") <+> ppr sk))) }
-\end{code}
 
-
-\begin{code}
 lintArrow :: SDoc -> LintedKind -> LintedKind -> LintM LintedKind
 -- If you edit this function, you may need to update the GHC formalism
 -- See Note [GHC Formalism]
@@ -823,15 +807,15 @@ lint_app doc kfn kas
            ; return (substKiWith [kv] [ta] kfn) }
 
     go_app _ _ = failWithL fail_msg
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
          Linting coercions
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 lintInCo :: InCoercion -> LintM (LintedKind, LintedType, LintedType, Role)
 -- Check the coercion, and apply the substitution to it
 -- See Note [Linting type lets]
@@ -1053,15 +1037,13 @@ lintCoercion this@(AxiomRuleCo co ts cs)
                           [ txt "Expected:" <+> int (n + length es)
                           , txt "Provided:" <+> int n ]
 
-\end{code}
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection[lint-monad]{The Lint monad}
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
+*                                                                      *
+************************************************************************
+-}
 
 -- If you edit this type, you may need to update the GHC formalism
 -- See Note [GHC Formalism]
@@ -1118,17 +1100,12 @@ data LintLocInfo
   | TopLevelBindings
   | InType Type         -- Inside a type
   | InCo   Coercion     -- Inside a coercion
-\end{code}
-
 
-\begin{code}
 initL :: LintM a -> WarnsAndErrs    -- Errors and warnings
 initL m
   = case unLintM m [] emptyTvSubst (emptyBag, emptyBag) of
       (_, errs) -> errs
-\end{code}
 
-\begin{code}
 checkL :: Bool -> MsgDoc -> LintM ()
 checkL True  _   = return ()
 checkL False msg = failWithL msg
@@ -1195,9 +1172,7 @@ applySubstCo co = do { subst <- getTvSubst; return (substCo (tvCvSubst subst) co
 extendSubstL :: TyVar -> Type -> LintM a -> LintM a
 extendSubstL tv ty m
   = LintM (\ loc subst errs -> unLintM m loc (Type.extendTvSubst subst tv ty) errs)
-\end{code}
 
-\begin{code}
 lookupIdInScope :: Id -> LintM Id
 lookupIdInScope id
   | not (mustHaveLocalBinding id)
@@ -1247,15 +1222,14 @@ checkRole co r1 r2
             ptext (sLit "got") <+> ppr r2 $$
             ptext (sLit "in") <+> ppr co)
 
-\end{code}
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Error messages}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 dumpLoc :: LintLocInfo -> (SrcLoc, SDoc)
 
 dumpLoc (RhsOf v)
@@ -1294,9 +1268,7 @@ pp_binders bs = sep (punctuate comma (map pp_binder bs))
 pp_binder :: Var -> SDoc
 pp_binder b | isId b    = hsep [ppr b, dcolon, ppr (idType b)]
             | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)]
-\end{code}
 
-\begin{code}
 ------------------------------------------------------
 --      Messages for case expressions
 
@@ -1468,4 +1440,3 @@ dupExtVars :: [[Name]] -> MsgDoc
 dupExtVars vars
   = hang (ptext (sLit "Duplicate top-level variables with the same qualified name"))
        2 (ppr vars)
-\end{code}
similarity index 95%
rename from compiler/coreSyn/CorePrep.lhs
rename to compiler/coreSyn/CorePrep.hs
index 537cc01..9037fcb 100644 (file)
@@ -1,10 +1,10 @@
-%
-(c) The University of Glasgow, 1994-2006
-%
+{-
+(c) The University of Glasgow, 1994-2006
+
 
 Core pass to saturate constructors and PrimOps
+-}
 
-\begin{code}
 {-# LANGUAGE BangPatterns, CPP #-}
 
 module CorePrep (
@@ -56,8 +56,8 @@ import Config
 import Data.Bits
 import Data.List        ( mapAccumL )
 import Control.Monad
-\end{code}
 
+{-
 -- ---------------------------------------------------------------------------
 -- Overview
 -- ---------------------------------------------------------------------------
@@ -142,21 +142,21 @@ Here is the syntax of the Core produced by CorePrep:
 
 We define a synonym for each of these non-terminals.  Functions
 with the corresponding name produce a result in that syntax.
+-}
 
-\begin{code}
 type CpeTriv = CoreExpr    -- Non-terminal 'triv'
 type CpeApp  = CoreExpr    -- Non-terminal 'app'
 type CpeBody = CoreExpr    -- Non-terminal 'body'
 type CpeRhs  = CoreExpr    -- Non-terminal 'rhs'
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 Top level stuff
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 corePrepPgm :: DynFlags -> HscEnv -> CoreProgram -> [TyCon] -> IO CoreProgram
 corePrepPgm dflags hsc_env binds data_tycons = do
     showPass dflags "CorePrep"
@@ -202,8 +202,8 @@ mkDataConWorkers data_tycons
     | tycon <- data_tycons,     -- CorePrep will eta-expand it
       data_con <- tyConDataCons tycon,
       let id = dataConWorkId data_con ]
-\end{code}
 
+{-
 Note [Floating out of top level bindings]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 NB: we do need to float out of top-level bindings
@@ -335,13 +335,13 @@ Into this one:
 (Since f is not considered to be free in its own RHS.)
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
                 The main code
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind
         -> UniqSM (CorePrepEnv, Floats)
 cpeBind top_lvl env (NonRec bndr rhs)
@@ -349,7 +349,7 @@ cpeBind top_lvl env (NonRec bndr rhs)
        ; let dmd         = idDemandInfo bndr
              is_unlifted = isUnLiftedType (idType bndr)
        ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive
-                                          dmd 
+                                          dmd
                                           is_unlifted
                                           env bndr1 rhs
        ; let new_float = mkFloat dmd is_unlifted bndr2 rhs2
@@ -697,7 +697,7 @@ cpeApp env expr
 -- ---------------------------------------------------------------------------
 
 -- This is where we arrange that a non-trivial argument is let-bound
-cpeArg :: CorePrepEnv -> Demand 
+cpeArg :: CorePrepEnv -> Demand
        -> CoreArg -> Type -> UniqSM (Floats, CpeTriv)
 cpeArg env dmd arg arg_ty
   = do { (floats1, arg1) <- cpeRhsE env arg     -- arg1 can be a lambda
@@ -719,8 +719,8 @@ cpeArg env dmd arg arg_ty
     is_unlifted = isUnLiftedType arg_ty
     is_strict   = isStrictDmd dmd
     want_float  = wantFloatNested NonRecursive (is_strict || is_unlifted)
-\end{code}
 
+{-
 Note [Floating unlifted arguments]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider    C (let v* = expensive in v)
@@ -741,8 +741,8 @@ because that has different strictness.  Hence the use of 'allLazy'.
 
 maybeSaturate deals with saturating primops and constructors
 The type is the type of the entire application
+-}
 
-\begin{code}
 maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs
 maybeSaturate fn expr n_args
   | Just DataToTagOp <- isPrimOpId_maybe fn     -- DataToTag must have an evaluated arg
@@ -783,8 +783,8 @@ saturateDataToTag sat_expr
 
     eval_data2tag_arg other     -- Should not happen
         = pprPanic "eval_data2tag" (ppr other)
-\end{code}
 
+{-
 Note [dataToTag magic]
 ~~~~~~~~~~~~~~~~~~~~~~
 Horrid: we must ensure that the arg of data2TagOp is evaluated
@@ -795,13 +795,13 @@ How might it not be evaluated?  Well, we might have floated it out
 of the scope of a `seq`, or dropped the `seq` altogether.
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
                 Simple CoreSyn operations
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 -- we don't ignore any Tickishes at the moment.
 ignoreTickish :: Tickish Id -> Bool
 ignoreTickish _ = False
@@ -817,8 +817,8 @@ cpe_ExprIsTrivial (Tick t e)     = not (tickishIsCode t) && cpe_ExprIsTrivial e
 cpe_ExprIsTrivial (Cast e _)     = cpe_ExprIsTrivial e
 cpe_ExprIsTrivial (Lam b body) | isTyVar b = cpe_ExprIsTrivial body
 cpe_ExprIsTrivial _              = False
-\end{code}
 
+{-
 -- -----------------------------------------------------------------------------
 --      Eta reduction
 -- -----------------------------------------------------------------------------
@@ -858,14 +858,14 @@ and now we do NOT want eta expansion to give
 
 Instead CoreArity.etaExpand gives
                 f = /\a -> \y -> let s = h 3 in g s y
+-}
 
-\begin{code}
 cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs
 cpeEtaExpand arity expr
   | arity == 0 = expr
   | otherwise  = etaExpand arity expr
-\end{code}
 
+{-
 -- -----------------------------------------------------------------------------
 --      Eta reduction
 -- -----------------------------------------------------------------------------
@@ -876,8 +876,8 @@ trivial (like f, or f Int).  But for deLam it would be enough to
 get to a partial application:
         case x of { p -> \xs. map f xs }
     ==> case x of { p -> map f }
+-}
 
-\begin{code}
 tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
 tryEtaReducePrep bndrs expr@(App _ _)
   | ok_to_eta_reduce f
@@ -910,20 +910,19 @@ tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body)
     fvs = exprFreeVars r
 
 tryEtaReducePrep _ _ = Nothing
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 Floats
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Note [Pin demand info on floats]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We pin demand info on floated lets so that we can see the one-shot thunks.
+-}
 
-\begin{code}
 data FloatingBind
   = FloatLet CoreBind    -- Rhs of bindings are CpeRhss
                          -- They are always of lifted type;
@@ -1093,16 +1092,15 @@ allLazyNested :: RecFlag -> Floats -> Bool
 allLazyNested _      (Floats OkToSpec    _) = True
 allLazyNested _      (Floats NotOkToSpec _) = False
 allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 Cloning
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 -- ---------------------------------------------------------------------------
 --                      The environment
 -- ---------------------------------------------------------------------------
@@ -1208,4 +1206,3 @@ newVar ty
  = seqType ty `seq` do
      uniq <- getUniqueM
      return (mkSysLocal (fsLit "sat") uniq ty)
-\end{code}
similarity index 95%
rename from compiler/coreSyn/CoreSubst.lhs
rename to compiler/coreSyn/CoreSubst.hs
index 76f42f4..82e18ca 100644 (file)
@@ -1,11 +1,11 @@
-%
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
 
 Utility functions on @Core@ syntax
+-}
 
-\begin{code}
 {-# LANGUAGE CPP #-}
 module CoreSubst (
         -- * Main data types
@@ -82,16 +82,15 @@ import FastString
 import Data.List
 
 import TysWiredIn
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Substitutions}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 -- | A substitution environment, containing both 'Id' and 'TyVar' substitutions.
 --
 -- Some invariants apply to how you use the substitution:
@@ -124,8 +123,8 @@ data Subst
         --              Types.TvSubstEnv
         --
         -- INVARIANT 3: See Note [Extending the Subst]
-\end{code}
 
+{-
 Note [Extending the Subst]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 For a core Subst, which binds Ids as well, we make a different choice for Ids
@@ -179,8 +178,8 @@ TvSubstEnv and CvSubstEnv?
 
 * For TyVars, only coercion variables can possibly change, and they are
   easy to spot
+-}
 
-\begin{code}
 -- | An environment for substituting for 'Id's
 type IdSubstEnv = IdEnv CoreExpr
 
@@ -331,11 +330,9 @@ extendInScopeIds (Subst in_scope ids tvs cvs) vs
 
 setInScope :: Subst -> InScopeSet -> Subst
 setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs
-\end{code}
 
-Pretty printing, for debugging only
+-- Pretty printing, for debugging only
 
-\begin{code}
 instance Outputable Subst where
   ppr (Subst in_scope ids tvs cvs)
         =  ptext (sLit "<InScope =") <+> braces (fsep (map ppr (varEnvElts (getInScopeVars in_scope))))
@@ -343,16 +340,15 @@ instance Outputable Subst where
         $$ ptext (sLit " TvSubst   =") <+> ppr tvs
         $$ ptext (sLit " CvSubst   =") <+> ppr cvs
          <> char '>'
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
         Substituting expressions
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 -- | Apply a substitution to an entire 'CoreExpr'. Remember, you may only
 -- apply the substitution /once/: see "CoreSubst#apply_once"
 --
@@ -428,9 +424,7 @@ substBind subst (Rec pairs) = (subst', Rec (bndrs' `zip` rhss'))
                                 (bndrs, rhss)    = unzip pairs
                                 (subst', bndrs') = substRecBndrs subst bndrs
                                 rhss' = map (subst_expr subst') rhss
-\end{code}
 
-\begin{code}
 -- | De-shadowing the program is sometimes a useful pre-pass. It can be done simply
 -- by running over the bindings with an empty substitution, because substitution
 -- returns a result that has no-shadowing guaranteed.
@@ -442,21 +436,20 @@ substBind subst (Rec pairs) = (subst', Rec (bndrs' `zip` rhss'))
 --          short and simple that I'm going to leave it here
 deShadowBinds :: CoreProgram -> CoreProgram
 deShadowBinds binds = snd (mapAccumL substBind emptySubst binds)
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
         Substituting binders
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Remember that substBndr and friends are used when doing expression
 substitution only.  Their only business is substitution, so they
 preserve all IdInfo (suitably substituted).  For example, we *want* to
 preserve occ info in rules.
+-}
 
-\begin{code}
 -- | Substitutes a 'Var' for another one according to the 'Subst' given, returning
 -- the result and an updated 'Subst' that should be used by subsequent substitutions.
 -- 'IdInfo' is preserved by this process, although it is substituted into appropriately.
@@ -476,10 +469,7 @@ substRecBndrs subst bndrs
   = (new_subst, new_bndrs)
   where         -- Here's the reason we need to pass rec_subst to subst_id
     (new_subst, new_bndrs) = mapAccumL (substIdBndr (text "rec-bndr") new_subst) subst bndrs
-\end{code}
-
 
-\begin{code}
 substIdBndr :: SDoc
             -> Subst            -- ^ Substitution to use for the IdInfo
             -> Subst -> Id      -- ^ Substitution and Id to transform
@@ -513,12 +503,12 @@ substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id
     no_change = id1 == old_id
         -- See Note [Extending the Subst]
         -- it's /not/ necessary to check mb_new_info and no_type_change
-\end{code}
 
+{-
 Now a variant that unconditionally allocates a new unique.
 It also unconditionally zaps the OccInfo.
+-}
 
-\begin{code}
 -- | Very similar to 'substBndr', but it always allocates a new 'Unique' for
 -- each variable in its output.  It substitutes the IdInfo though.
 cloneIdBndr :: Subst -> UniqSupply -> Id -> (Subst, Id)
@@ -564,20 +554,19 @@ clone_id rec_subst subst@(Subst in_scope idvs tvs cvs) (old_id, uniq)
     new_id  = maybeModifyIdInfo (substIdInfo rec_subst id2 (idInfo old_id)) id2
     (new_idvs, new_cvs) | isCoVar old_id = (idvs, extendVarEnv cvs old_id (mkCoVarCo new_id))
                         | otherwise      = (extendVarEnv idvs old_id (Var new_id), cvs)
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 Types and Coercions
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 For types and coercions we just call the corresponding functions in
 Type and Coercion, but we have to repackage the substitution, from a
 Subst to a TvSubst.
+-}
 
-\begin{code}
 substTyVarBndr :: Subst -> TyVar -> (Subst, TyVar)
 substTyVarBndr (Subst in_scope id_env tv_env cv_env) tv
   = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
@@ -609,16 +598,15 @@ getCvSubst (Subst in_scope _ tenv cenv) = CvSubst in_scope tenv cenv
 -- | See 'Coercion.substCo'
 substCo :: Subst -> Coercion -> Coercion
 substCo subst co = Coercion.substCo (getCvSubst subst) co
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \section{IdInfo substitution}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 substIdType :: Subst -> Id -> Id
 substIdType subst@(Subst _ _ tv_env cv_env) id
   | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || isEmptyVarSet (Type.tyVarsOfType old_ty) = id
@@ -760,8 +748,8 @@ for an Id in a breakpoint.  We ensure this by never storing an Id with
 an unlifted type in a Breakpoint - see Coverage.mkTickish.
 Breakpoints can't handle free variables with unlifted types anyway.
 -}
-\end{code}
 
+{-
 Note [Worker inlining]
 ~~~~~~~~~~~~~~~~~~~~~~
 A worker can get sustituted away entirely.
@@ -774,11 +762,11 @@ In all all these cases we simply drop the special case, returning to
 InlVanilla.  The WARN is just so I can see if it happens a lot.
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
         The Very Simple Optimiser
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Note [Optimise coercion boxes agressively]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -830,8 +818,8 @@ we wouldn't simplify this expression at all:
 
 The rule LHS desugarer can't deal with Let at all, so we need to push that box into
 the use sites.
+-}
 
-\begin{code}
 simpleOptExpr :: CoreExpr -> CoreExpr
 -- Do simple optimisation on an expression
 -- The optimisation is very straightforward: just
@@ -1093,8 +1081,8 @@ simpleUnfoldingFun :: IdUnfoldingFun
 simpleUnfoldingFun id
   | isAlwaysActive (idInlineActivation id) = idUnfolding id
   | otherwise                              = noUnfolding
-\end{code}
 
+{-
 Note [Inline prag in simplOpt]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 If there's an INLINE/NOINLINE pragma that restricts the phase in
@@ -1121,11 +1109,11 @@ match if we replace coerce by its unfolding on the LHS, because that is the
 core that the rule matching engine will find. So do that for everything that
 has a compulsory unfolding. Also see Note [Desugaring coerce as cast] in Desugar
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
          exprIsConApp_maybe
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Note [exprIsConApp_maybe]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1157,8 +1145,8 @@ Just (':', [Char], ['a', unpackCString# "bc"]).
 We need to be careful about UTF8 strings here. ""# contains a ByteString, so
 we must parse it back into a FastString to split off the first character.
 That way we can treat unpackCString# and unpackCStringUtf8# in the same way.
+-}
 
-\begin{code}
 data ConCont = CC [CoreExpr] Coercion
                   -- Substitution already applied
 
@@ -1314,8 +1302,8 @@ stripTypeArgs :: [CoreExpr] -> [Type]
 stripTypeArgs args = ASSERT2( all isTypeArg args, ppr args )
                      [ty | Type ty <- args]
   -- We really do want isTypeArg here, not isTyCoArg!
-\end{code}
 
+{-
 Note [Unfolding DFuns]
 ~~~~~~~~~~~~~~~~~~~~~~
 DFuns look like
@@ -1333,8 +1321,8 @@ Note [DFun arity check]
 Here we check that the total number of supplied arguments (inclding
 type args) matches what the dfun is expecting.  This may be *less*
 than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn
+-}
 
-\begin{code}
 exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal
 -- Same deal as exprIsConApp_maybe, but much simpler
 -- Nevertheless we do need to look through unfoldings for
@@ -1347,8 +1335,8 @@ exprIsLiteral_maybe env@(_, id_unf) e
       Var v     | Just rhs <- expandUnfolding_maybe (id_unf v)
                 -> exprIsLiteral_maybe env rhs
       _         -> Nothing
-\end{code}
 
+{-
 Note [exprIsLambda_maybe]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 exprIsLambda_maybe will, given an expression `e`, try to turn it into the form
@@ -1358,8 +1346,8 @@ has a greater arity than arguments are present.
 
 Currently, it is used in Rules.match, and is required to make
 "map coerce = coerce" match.
+-}
 
-\begin{code}
 exprIsLambda_maybe :: InScopeEnv -> CoreExpr -> Maybe (Var, CoreExpr)
     -- See Note [exprIsLambda_maybe]
 
@@ -1418,5 +1406,3 @@ pushCoercionIntoLambda in_scope x e co
     | otherwise
     = pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e))
       Nothing
-
-\end{code}
similarity index 92%
rename from compiler/coreSyn/CoreSyn.lhs
rename to compiler/coreSyn/CoreSyn.hs
index 47418e2..0c6ee7c 100644 (file)
@@ -1,9 +1,8 @@
-%
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+-}
 
-\begin{code}
 {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}
 
 -- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection
@@ -105,17 +104,17 @@ import Data.Word
 
 infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps`
 -- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{The main data types}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 These data types are the heart of the compiler
+-}
 
-\begin{code}
 -- | This is the data type that represents GHCs core intermediate language. Currently
 -- GHC uses System FC <http://research.microsoft.com/~simonpj/papers/ext-f/> for this purpose,
 -- which is closely related to the simpler and better known System F <http://en.wikipedia.org/wiki/System_F>.
@@ -287,8 +286,8 @@ data AltCon
 data Bind b = NonRec b (Expr b)
             | Rec [(b, (Expr b))]
   deriving (Data, Typeable)
-\end{code}
 
+{-
 Note [Shadowing]
 ~~~~~~~~~~~~~~~~
 While various passes attempt to rename on-the-fly in a manner that
@@ -422,13 +421,13 @@ if for no other reason that we don't need to instantiate the (~) at an
 unboxed type.
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
               Ticks
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 -- | Allows attaching extra information to points in expressions
 
 -- If you edit this type, you may need to update the GHC formalism
@@ -513,19 +512,18 @@ tickishCanSplit :: Tickish Id -> Bool
 tickishCanSplit Breakpoint{} = False
 tickishCanSplit HpcTick{}    = False
 tickishCanSplit _ = True
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Transformation rules}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 The CoreRule type and its friends are dealt with mainly in CoreRules,
 but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
+-}
 
-\begin{code}
 -- | A 'CoreRule' is:
 --
 -- * \"Local\" if the function it is a rule for is defined in the
@@ -620,36 +618,34 @@ isLocalRule = ru_local
 -- | Set the 'Name' of the 'Id.Id' at the head of the rule left hand side
 setRuleIdName :: Name -> CoreRule -> CoreRule
 setRuleIdName nm ru = ru { ru_fn = nm }
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Vectorisation declarations}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Representation of desugared vectorisation declarations that are fed to the vectoriser (via
 'ModGuts').
+-}
 
-\begin{code}
 data CoreVect = Vect      Id   CoreExpr
               | NoVect    Id
               | VectType  Bool TyCon (Maybe TyCon)
               | VectClass TyCon                     -- class tycon
               | VectInst  Id                        -- instance dfun (always SCALAR)  !!!FIXME: should be superfluous now
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 Unfoldings
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 The @Unfolding@ type is declared here to avoid numerous loops
+-}
 
-\begin{code}
 -- | Records the /unfolding/ of an identifier, which is approximately the form the
 -- identifier would have if we substituted its definition in for the identifier.
 -- This type should be treated as abstract everywhere except in "CoreUnfold"
@@ -770,8 +766,8 @@ data UnfoldingGuidance
                           -- (where there are the right number of arguments.)
 
   | UnfNever        -- The RHS is big, so don't inline it
-\end{code}
 
+{-
 Note [Historical note: unfoldings for wrappers]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We used to have a nice clever scheme in interface files for
@@ -818,8 +814,8 @@ why we record the number of expected arguments in the DFunUnfolding.
 Note that although it's an Arity, it's most convenient for it to give
 the *total* number of arguments, both type and value.  See the use
 site in exprIsConApp_maybe.
+-}
 
-\begin{code}
 -- Constants for the UnfWhen constructor
 needSaturated, unSaturatedOk :: Bool
 needSaturated = False
@@ -853,9 +849,7 @@ seqUnfolding _ = ()
 seqGuidance :: UnfoldingGuidance -> ()
 seqGuidance (UnfIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` ()
 seqGuidance _                      = ()
-\end{code}
 
-\begin{code}
 isStableSource :: UnfoldingSource -> Bool
 -- Keep the unfolding template
 isStableSource InlineCompulsory   = True
@@ -963,8 +957,8 @@ neverUnfoldGuidance _        = False
 canUnfold :: Unfolding -> Bool
 canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g)
 canUnfold _                                   = False
-\end{code}
 
+{-
 Note [InlineRules]
 ~~~~~~~~~~~~~~~~~
 When you say
@@ -1008,13 +1002,13 @@ the occurrence info is wrong
     without a loop breaker marked
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
                   AltCon
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 -- The Ord is needed for the FiniteMap used in the lookForConstructor
 -- in SimplEnv.  If you declared that lookForConstructor *ignores*
 -- constructor-applications with LitArg args, then you could get
@@ -1044,13 +1038,13 @@ cmpAltCon (LitAlt _)   DEFAULT      = GT
 cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>
                                   ppr con1 <+> ppr con2 )
                       LT
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Useful synonyms}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Note [CoreProgram]
 ~~~~~~~~~~~~~~~~~~
@@ -1071,8 +1065,7 @@ a list of CoreBind
    bindings where possible.  So the program typically starts life as a
    single giant Rec, which is then dependency-analysed into smaller
    chunks.
-
-\begin{code}
+-}
 
 -- If you edit this type, you may need to update the GHC formalism
 -- See Note [GHC Formalism] in coreSyn/CoreLint.lhs
@@ -1089,15 +1082,15 @@ type CoreArg  = Arg  CoreBndr
 type CoreBind = Bind CoreBndr
 -- | Case alternatives where binders are 'CoreBndr's
 type CoreAlt  = Alt  CoreBndr
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Tagging}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 -- | Binders are /tagged/ with a t
 data TaggedBndr t = TB CoreBndr t       -- TB for "tagged binder"
 
@@ -1132,16 +1125,15 @@ deTagBind (Rec prs)             = Rec [(b, deTagExpr rhs) | (TB b _, rhs) <- prs
 
 deTagAlt :: TaggedAlt t -> CoreAlt
 deTagAlt (con, bndrs, rhs) = (con, [b | TB b _ <- bndrs], deTagExpr rhs)
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Core-constructing functions with checking}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 -- | Apply a list of argument expressions to a function expression in a nested fashion. Prefer to
 -- use 'MkCore.mkCoreApps' if possible
 mkApps    :: Expr b -> [Arg b]  -> Expr b
@@ -1253,16 +1245,15 @@ varToCoreExpr v | isTyVar v = Type (mkTyVarTy v)
 
 varsToCoreExprs :: [CoreBndr] -> [Expr b]
 varsToCoreExprs vs = map varToCoreExpr vs
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Simple access functions}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 -- | Extract every variable by this group
 bindersOf  :: Bind b -> [b]
 -- If you edit this function, you may need to update the GHC formalism
@@ -1287,9 +1278,7 @@ flattenBinds :: [Bind b] -> [(b, Expr b)]
 flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
 flattenBinds (Rec prs1   : binds) = prs1 ++ flattenBinds binds
 flattenBinds []                   = []
-\end{code}
 
-\begin{code}
 -- | We often want to strip off leading lambdas before getting down to
 -- business. This function is your friend.
 collectBinders               :: Expr b -> ([b],         Expr b)
@@ -1325,9 +1314,7 @@ collectValBinders expr
   where
     go ids (Lam b e) | isId b = go (b:ids) e
     go ids body               = (reverse ids, body)
-\end{code}
 
-\begin{code}
 -- | Takes a nested application expression and returns the the function
 -- being applied and the arguments to which it is applied
 collectArgs :: Expr b -> (Expr b, [Arg b])
@@ -1336,20 +1323,20 @@ collectArgs expr
   where
     go (App f a) as = go f (a:as)
     go e         as = (e, as)
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Predicates}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 At one time we optionally carried type arguments through to runtime.
 @isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
 i.e. if type applications are actual lambdas because types are kept around
 at runtime.  Similarly isRuntimeArg.
+-}
 
-\begin{code}
 -- | Will this variable exist at runtime?
 isRuntimeVar :: Var -> Bool
 isRuntimeVar = isId
@@ -1384,16 +1371,15 @@ valBndrCount = count isId
 -- | The number of argument expressions that are values rather than types at their top level
 valArgCount :: [Arg b] -> Int
 valArgCount = count isValArg
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Seq stuff}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 seqExpr :: CoreExpr -> ()
 seqExpr (Var v)         = v `seq` ()
 seqExpr (Lit lit)       = lit `seq` ()
@@ -1439,15 +1425,15 @@ seqRules [] = ()
 seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)
   = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
 seqRules (BuiltinRule {} : rules) = seqRules rules
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Annotated core}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 -- | Annotated core: allows annotation at every node in the tree
 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
 
@@ -1472,9 +1458,7 @@ type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
 data AnnBind bndr annot
   = AnnNonRec bndr (AnnExpr bndr annot)
   | AnnRec    [(bndr, AnnExpr bndr annot)]
-\end{code}
 
-\begin{code}
 -- | Takes a nested application expression and returns the the function
 -- being applied and the arguments to which it is applied
 collectAnnArgs :: AnnExpr b a -> (AnnExpr b a, [AnnExpr b a])
@@ -1483,9 +1467,7 @@ collectAnnArgs expr
   where
     go (_, AnnApp f a) as = go f (a:as)
     go e               as = (e, as)
-\end{code}
 
-\begin{code}
 deAnnotate :: AnnExpr bndr annot -> Expr bndr
 deAnnotate (_, e) = deAnnotate' e
 
@@ -1510,9 +1492,7 @@ deAnnotate' (AnnCase scrut v t alts)
 
 deAnnAlt :: AnnAlt bndr annot -> Alt bndr
 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
-\end{code}
 
-\begin{code}
 -- | As 'collectBinders' but for 'AnnExpr' rather than 'Expr'
 collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
 collectAnnBndrs e
@@ -1520,4 +1500,3 @@ collectAnnBndrs e
   where
     collect bs (_, AnnLam b body) = collect (b:bs) body
     collect bs body               = (reverse bs, body)
-\end{code}
similarity index 92%
rename from compiler/coreSyn/CoreTidy.lhs
rename to compiler/coreSyn/CoreTidy.hs
index 810a71c..7f09c68 100644 (file)
@@ -1,12 +1,12 @@
-%
-(c) The University of Glasgow 2006
-(c) The AQUA Project, Glasgow University, 1996-1998
-%
+{-
+(c) The University of Glasgow 2006
+(c) The AQUA Project, Glasgow University, 1996-1998
+
 
 This module contains "tidying" code for *nested* expressions, bindings, rules.
 The code for *top-level* bindings is in TidyPgm.
+-}
 
-\begin{code}
 {-# LANGUAGE CPP #-}
 module CoreTidy (
         tidyExpr, tidyVarOcc, tidyRule, tidyRules, tidyUnfolding
@@ -27,16 +27,15 @@ import Name hiding (tidyNameOcc)
 import SrcLoc
 import Maybes
 import Data.List
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Tidying expressions, rules}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 tidyBind :: TidyEnv
          -> CoreBind
          ->  (TidyEnv, CoreBind)
@@ -105,16 +104,15 @@ tidyRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs,
            ru_rhs   = tidyExpr env' rhs,
            ru_fn    = tidyNameOcc env fn,
            ru_rough = map (fmap (tidyNameOcc env')) mb_ns }
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Tidying non-top-level binders}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 tidyNameOcc :: TidyEnv -> Name -> Name
 -- In rules and instances, we have Names, and we must tidy them too
 -- Fortunately, we can lookup in the VarEnv with a name
@@ -223,8 +221,8 @@ tidyUnfolding tidy_env
   | otherwise
   = unf_from_rhs
 tidyUnfolding _ unf _ = unf     -- NoUnfolding or OtherCon
-\end{code}
 
+{-
 Note [Tidy IdInfo]
 ~~~~~~~~~~~~~~~~~~
 All nested Ids now have the same IdInfo, namely vanillaIdInfo, which
@@ -268,9 +266,7 @@ optimisation pipeline, leaving only the OneShotInfo on the lambda. Hence we
 must preserve this info in inlinings.
 
 This applies to lambda binders only, hence it is stored in IfaceLamBndr.
+-}
 
-
-\begin{code}
 (=:) :: a -> (a -> b) -> b
 m =: k = m `seq` k m
-\end{code}
similarity index 96%
rename from compiler/coreSyn/CoreUnfold.lhs
rename to compiler/coreSyn/CoreUnfold.hs
index fd485ae..dc9f95e 100644 (file)
@@ -1,7 +1,7 @@
-%
-(c) The University of Glasgow 2006
-(c) The AQUA Project, Glasgow University, 1994-1998
-%
+{-
+(c) The University of Glasgow 2006
+(c) The AQUA Project, Glasgow University, 1994-1998
+
 
 Core-syntax unfoldings
 
@@ -13,8 +13,8 @@ unfoldings, capturing ``higher-level'' things we know about a binding,
 usually things that the simplifier found out (e.g., ``it's a
 literal'').  In the corner of a @CoreUnfolding@ unfolding, you will
 find, unsurprisingly, a Core expression.
+-}
 
-\begin{code}
 {-# LANGUAGE CPP #-}
 
 module CoreUnfold (
@@ -66,16 +66,15 @@ import ForeignCall
 
 import qualified Data.ByteString as BS
 import Data.Maybe
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Making unfoldings}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 mkTopUnfolding :: DynFlags -> Bool -> CoreExpr -> Unfolding
 mkTopUnfolding dflags = mkUnfolding dflags InlineRhs True {- Top level -}
 
@@ -184,8 +183,8 @@ specUnfolding _ _ _ _ _ = noUnfolding
 
 spec_doc :: SDoc
 spec_doc = ptext (sLit "specUnfolding")
-\end{code}
 
+{-
 Note [Specialising unfoldings]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When we specialise a function for some given type-class arguments, we use
@@ -214,9 +213,8 @@ specUnfolding to specialise its unfolding.  Some important points:
         we keep it (so the specialised thing too will always inline)
      if a stable unfolding has UnfoldingGuidance of UnfIfGoodArgs
         (which arises from INLINEABLE), we discard it
+-}
 
-
-\begin{code}
 mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr
                 -> UnfoldingGuidance -> Unfolding
 -- Occurrence-analyses the expression before capturing it
@@ -253,8 +251,8 @@ mkUnfolding dflags src top_lvl is_bottoming expr
     guidance = calcUnfoldingGuidance dflags expr
         -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr expr))!
         -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression]
-\end{code}
 
+{-
 Note [Occurrence analysis of unfoldings]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We do occurrence-analysis of unfoldings once and for all, when the
@@ -297,13 +295,13 @@ it gets fixed up next round.  And it should be rare, because large
 let-bound things that are dead are usually caught by preInlineUnconditionally
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection{The UnfoldingGuidance type}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 inlineBoringOk :: CoreExpr -> Bool
 -- See Note [INLINE for small functions]
 -- True => the result of inlining the expression is
@@ -361,8 +359,8 @@ calcUnfoldingGuidance dflags expr
              plus_disc | isFunTy (idType bndr) = max
                        | otherwise             = (+)
              -- See Note [Function and non-function discounts]
-\end{code}
 
+{-
 Note [Computing the size of an expression]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The basic idea of sizeExpr is obvious enough: count nodes.  But getting the
@@ -457,8 +455,8 @@ Things to note:
     NB: you might think that PostInlineUnconditionally would do this
     but it doesn't fire for top-level things; see SimplUtils
     Note [Top level and postInlineUnconditionally]
+-}
 
-\begin{code}
 uncondInline :: CoreExpr -> Arity -> Int -> Bool
 -- Inline unconditionally if there no size increase
 -- Size of call is arity (+1 for the function)
@@ -466,10 +464,7 @@ uncondInline :: CoreExpr -> Arity -> Int -> Bool
 uncondInline rhs arity size
   | arity > 0 = size <= 10 * (arity + 1) -- See Note [INLINE for small functions] (1)
   | otherwise = exprIsTrivial rhs        -- See Note [INLINE for small functions] (4)
-\end{code}
 
-
-\begin{code}
 sizeExpr :: DynFlags
          -> FastInt         -- Bomb out if it gets bigger than this
          -> [Id]            -- Arguments; we're interested in which of these
@@ -630,10 +625,7 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr
     -- an expression of type State# RealWorld must be a variable
     isRealWorldExpr (Var id) = isRealWorldId id
     isRealWorldExpr _        = False
-\end{code}
-
 
-\begin{code}
 -- | Finds a nominal size of a string literal.
 litSize :: Literal -> Int
 -- Used by CoreUnfold.sizeExpr
@@ -699,8 +691,8 @@ conSize dc n_val_args
 
 -- See Note [Constructor size and result discount]
   | otherwise = SizeIs (_ILIT(10)) emptyBag (iUnbox (10 * (1 + n_val_args)))
-\end{code}
 
+{-
 Note [Constructor size and result discount]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Treat a constructors application as size 10, regardless of how many
@@ -771,8 +763,8 @@ There's no point in doing so -- any optimisations will see the S#
 through n's unfolding.  Nor will a big size inhibit unfoldings functions
 that mention a literal Integer, because the float-out pass will float
 all those constants to top level.
+-}
 
-\begin{code}
 primOpSize :: PrimOp -> Int -> ExprSize
 primOpSize op n_val_args
  = if primOpOutOfLine op
@@ -800,8 +792,8 @@ augmentSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(40))
 lamScrutDiscount :: DynFlags -> ExprSize -> ExprSize
 lamScrutDiscount dflags (SizeIs n vs _) = SizeIs n vs (iUnbox (ufFunAppDiscount dflags))
 lamScrutDiscount _      TooBig          = TooBig
-\end{code}
 
+{-
 Note [addAltSize result discounts]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When adding the size of alternatives, we *add* the result discounts
@@ -854,8 +846,8 @@ In a function application (f a b)
     get a saturated application)
 
 Code for manipulating sizes
+-}
 
-\begin{code}
 data ExprSize = TooBig
               | SizeIs FastInt          -- Size found
                        !(Bag (Id,Int))  -- Arguments cased herein, and discount for each such
@@ -886,21 +878,20 @@ sizeN :: Int -> ExprSize
 
 sizeZero = SizeIs (_ILIT(0))  emptyBag (_ILIT(0))
 sizeN n  = SizeIs (iUnbox n) emptyBag (_ILIT(0))
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 We use 'couldBeSmallEnoughToInline' to avoid exporting inlinings that
 we ``couldn't possibly use'' on the other side.  Can be overridden w/
 flaggery.  Just the same as smallEnoughToInline, except that it has no
 actual arguments.
+-}
 
-\begin{code}
 couldBeSmallEnoughToInline :: DynFlags -> Int -> CoreExpr -> Bool
 couldBeSmallEnoughToInline dflags threshold rhs
   = case sizeExpr dflags (iUnbox threshold) [] body of
@@ -947,8 +938,8 @@ certainlyWillInline _ unf@(DFunUnfolding {})
 
 certainlyWillInline _ _
   = Nothing
-\end{code}
 
+{-
 Note [certainlyWillInline: be careful of thunks]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Don't claim that thunks will certainly inline, because that risks work
@@ -959,11 +950,11 @@ found that the WorkWrap phase thought that
 was certainlyWillInline, so the addition got duplicated.
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection{callSiteInline}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 This is the key function.  It decides whether to inline a variable at a call site
 
@@ -980,8 +971,8 @@ NOTE: we don't want to inline top-level functions that always diverge.
 It just makes the code bigger.  Tt turns out that the convenient way to prevent
 them inlining is to give them a NOINLINE pragma, which we do in
 StrictAnal.addStrictnessInfoToTopId
+-}
 
-\begin{code}
 callSiteInline :: DynFlags
                -> Id                    -- The Id
                -> Bool                  -- True <=> unfolding is active
@@ -1117,8 +1108,8 @@ tryUnfolding dflags id lone_variable
               RhsCtxt     -> uf_arity > 0  --
               _           -> not is_top && uf_arity > 0   -- Note [Nested functions]
                                                       -- Note [Inlining in ArgCtxt]
-\end{code}
 
+{-
 Note [Unfold into lazy contexts], Note [RHS of lets]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When the call is the argument of a function with a RULE, or the RHS of a let,
@@ -1310,8 +1301,8 @@ This kind of thing can occur if you have
         foo = let x = e in (x,x)
 
 which Roman did.
+-}
 
-\begin{code}
 computeDiscount :: DynFlags -> [Int] -> Int -> [ArgSummary] -> CallCtxt
                 -> Int
 computeDiscount dflags arg_discounts res_discount arg_infos cont_info
@@ -1361,13 +1352,13 @@ computeDiscount dflags arg_discounts res_discount arg_infos cont_info
                 -- Otherwise we, rather arbitrarily, threshold it.  Yuk.
                 -- But we want to aovid inlining large functions that return
                 -- constructors into contexts that are simply "interesting"
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
         Interesting arguments
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Note [Interesting arguments]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1398,8 +1389,8 @@ where df is con-like. Then we'd really like to inline 'f' so that the
 rule for (*) (df d) can fire.  To do this
   a) we give a discount for being an argument of a class-op (eg (*) d)
   b) we say that a con-like argument (eg (df d)) is interesting
+-}
 
-\begin{code}
 data ArgSummary = TrivArg       -- Nothing interesting
                 | NonTrivArg    -- Arg has structure
                 | ValueArg      -- Arg is a con-app or PAP
@@ -1439,4 +1430,3 @@ interestingArg e = go e 0
 nonTriv ::  ArgSummary -> Bool
 nonTriv TrivArg = False
 nonTriv _       = True
-\end{code}
similarity index 91%
rename from compiler/coreSyn/CoreUtils.lhs
rename to compiler/coreSyn/CoreUtils.hs
index 86db946..ffb3275 100644 (file)
@@ -1,11 +1,11 @@
-%
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
 
 Utility functions on @Core@ syntax
+-}
 
-\begin{code}
 {-# LANGUAGE CPP #-}
 
 -- | Commonly useful utilites for manipulating the Core language
@@ -71,16 +71,15 @@ import Platform
 import Util
 import Pair
 import Data.List
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Find the type of a Core atom/expression}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 exprType :: CoreExpr -> Type
 -- ^ Recover the type of a well-typed Core expression. Fails when
 -- applied to the actual 'CoreSyn.Type' expression as it cannot
@@ -88,7 +87,7 @@ exprType :: CoreExpr -> Type
 exprType (Var var)           = idType var
 exprType (Lit lit)           = literalType lit
 exprType (Coercion co)       = coercionType co
-exprType (Let bind body)     
+exprType (Let bind body)
   | NonRec tv rhs <- bind    -- See Note [Type bindings]
   , Type ty <- rhs           = substTyWith [tv] [ty] (exprType body)
   | otherwise                = exprType body
@@ -116,15 +115,15 @@ coreAltsType :: [CoreAlt] -> Type
 -- ^ Returns the type of the first alternative, which should be the same as for all alternatives
 coreAltsType (alt:_) = coreAltType alt
 coreAltsType []      = panic "corAltsType"
-\end{code}
 
+{-
 Note [Type bindings]
 ~~~~~~~~~~~~~~~~~~~~
 Core does allow type bindings, although such bindings are
 not much used, except in the output of the desuguarer.
 Example:
      let a = Int in (\x:a. x)
-Given this, exprType must be careful to substitute 'a' in the 
+Given this, exprType must be careful to substitute 'a' in the
 result type (Trac #8522).
 
 Note [Existential variables and silly type synonyms]
@@ -150,8 +149,8 @@ Various possibilities suggest themselves:
 
  - Expand synonyms on the fly, when the problem arises. That is what
    we are doing here.  It's not too expensive, I think.
+-}
 
-\begin{code}
 applyTypeToArg :: Type -> CoreExpr -> Type
 -- ^ Determines the type resulting from applying an expression with given type
 -- to a given argument expression
@@ -180,15 +179,15 @@ applyTypeToArgs e op_ty args
     panic_msg = vcat [ ptext (sLit "Expression:") <+> pprCoreExpr e
                      , ptext (sLit "Type:") <+> ppr op_ty
                      , ptext (sLit "Args:") <+> ppr args ]
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Attaching notes}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 -- | Wrap the given expression in the coercion safely, dropping
 -- identity coercions and coalescing nested coercions
 mkCast :: CoreExpr -> Coercion -> CoreExpr
@@ -196,7 +195,7 @@ mkCast e co | ASSERT2( coercionRole co == Representational
                      , ptext (sLit "coercion") <+> ppr co <+> ptext (sLit "passed to mkCast") <+> ppr e <+> ptext (sLit "has wrong role") <+> ppr (coercionRole co) )
               isReflCo co = e
 
-mkCast (Coercion e_co) co 
+mkCast (Coercion e_co) co
   | isCoVarType (pSnd (coercionKind co))
        -- The guard here checks that g has a (~#) on both sides,
        -- otherwise decomposeCo fails.  Can in principle happen
@@ -219,9 +218,7 @@ mkCast expr co
 --    else
         WARN(not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ ppr (coercionType co))
          (Cast expr co)
-\end{code}
 
-\begin{code}
 -- | Wraps the given expression in the source annotation, dropping the
 -- annotation if possible.
 mkTick :: Tickish Id -> CoreExpr -> CoreExpr
@@ -288,15 +285,15 @@ tickHNFArgs t e = push t e
   push t (App f (Type u)) = App (push t f) (Type u)
   push t (App f arg) = App (push t f) (mkTick t arg)
   push _t e = e
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Other expression construction}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
 -- ^ @bindNonRec x r b@ produces either:
 --
@@ -323,9 +320,7 @@ needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
         -- Make a case expression instead of a let
         -- These can arise either from the desugarer,
         -- or from beta reductions: (\x.e) (x +# y)
-\end{code}
 
-\begin{code}
 mkAltExpr :: AltCon     -- ^ Case alternative constructor
           -> [CoreBndr] -- ^ Things bound by the pattern match
           -> [Type]     -- ^ The type arguments to the case alternative
@@ -338,19 +333,18 @@ mkAltExpr (LitAlt lit) [] []
   = Lit lit
 mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt"
 mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT"
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Taking expressions apart}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 The default alternative must be first, if it exists at all.
 This makes it easy to find, though it makes matching marginally harder.
+-}
 
-\begin{code}
 -- | Extract the default case alternative
 findDefault :: [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b)
 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
@@ -404,16 +398,14 @@ trimConArgs :: AltCon -> [CoreArg] -> [CoreArg]
 trimConArgs DEFAULT      args = ASSERT( null args ) []
 trimConArgs (LitAlt _)   args = ASSERT( null args ) []
 trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args
-\end{code}
 
-\begin{code}
 filterAlts :: [Unique]             -- ^ Supply of uniques used in case we have to manufacture a new AltCon
            -> Type                 -- ^ Type of scrutinee (used to prune possibilities)
            -> [AltCon]             -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee
            -> [(AltCon, [Var], a)] -- ^ Alternatives
            -> ([AltCon], Bool, [(AltCon, [Var], a)])
              -- Returns:
-             --  1. Constructors that will never be encountered by the 
+             --  1. Constructors that will never be encountered by the
              --     *default* case (if any).  A superset of imposs_cons
              --  2. Whether we managed to refine the default alternative into a specific constructor (for statistics only)
              --  3. The new alternatives, trimmed by
@@ -424,13 +416,13 @@ filterAlts :: [Unique]             -- ^ Supply of uniques used in case we have t
              --
              -- NB: the final list of alternatives may be empty:
              -- This is a tricky corner case.  If the data type has no constructors,
-             -- which GHC allows, or if the imposs_cons covers all constructors (after taking 
+             -- which GHC allows, or if the imposs_cons covers all constructors (after taking
              -- account of GADTs), then no alternatives can match.
              --
              -- If callers need to preserve the invariant that there is always at least one branch
              -- in a "case" statement then they will need to manually add a dummy case branch that just
              -- calls "error" or similar.
-filterAlts us ty imposs_cons alts 
+filterAlts us ty imposs_cons alts
   | Just (tycon, inst_tys) <- splitTyConApp_maybe ty
   = filter_alts tycon inst_tys
   | otherwise
@@ -439,31 +431,31 @@ filterAlts us ty imposs_cons alts
     (alts_wo_default, maybe_deflt) = findDefault alts
     alt_cons = [con | (con,_,_) <- alts_wo_default]
 
-    filter_alts tycon inst_tys 
+    filter_alts tycon inst_tys
       = (imposs_deflt_cons, refined_deflt, merged_alts)
      where
        trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default
 
        imposs_deflt_cons = nub (imposs_cons ++ alt_cons)
-         -- "imposs_deflt_cons" are handled 
-         --   EITHER by the context, 
+         -- "imposs_deflt_cons" are handled
+         --   EITHER by the context,
          --   OR by a non-DEFAULT branch in this case expression.
 
        merged_alts  = mergeAlts trimmed_alts (maybeToList maybe_deflt')
-         -- We need the mergeAlts in case the new default_alt 
+         -- We need the mergeAlts in case the new default_alt
          -- has turned into a constructor alternative.
          -- The merge keeps the inner DEFAULT at the front, if there is one
          -- and interleaves the alternatives in the right order
 
        (refined_deflt, maybe_deflt') = case maybe_deflt of
           Nothing -> (False, Nothing)
-          Just deflt_rhs 
-             | isAlgTyCon tycon            -- It's a data type, tuple, or unboxed tuples.  
+          Just deflt_rhs
+             | isAlgTyCon tycon            -- It's a data type, tuple, or unboxed tuples.
              , not (isNewTyCon tycon)      -- We can have a newtype, if we are just doing an eval:
                                            --      case x of { DEFAULT -> e }
                                            -- and we don't want to fill in a default for them!
              , Just all_cons <- tyConDataCons_maybe tycon
-             , let imposs_data_cons = [con | DataAlt con <- imposs_deflt_cons]   -- We now know it's a data type 
+             , let imposs_data_cons = [con | DataAlt con <- imposs_deflt_cons]   -- We now know it's a data type
                    impossible con   = con `elem` imposs_data_cons || dataConCannotMatch inst_tys con
              -> case filterOut impossible all_cons of
                   -- Eliminate the default alternative
@@ -489,8 +481,8 @@ filterAlts us ty imposs_cons alts
     impossible_alt _ (con, _, _) | con `elem` imposs_cons = True
     impossible_alt inst_tys (DataAlt con, _, _) = dataConCannotMatch inst_tys con
     impossible_alt _  _                         = False
-\end{code}
 
+{-
 Note [Unreachable code]
 ~~~~~~~~~~~~~~~~~~~~~~~
 It is possible (although unusual) for GHC to find a case expression
@@ -521,11 +513,11 @@ Similar things can happen (augmented by GADTs) when the Simplifier
 filters down the matching alternatives in Simplify.rebuildCase.
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
              exprIsTrivial
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Note [exprIsTrivial]
 ~~~~~~~~~~~~~~~~~~~~
@@ -552,8 +544,8 @@ Note [Tick trivial]
 Ticks are not trivial.  If we treat "tick<n> x" as trivial, it will be
 inlined inside lambdas and the entry count will be skewed, for
 example.  Furthermore "scc<n> x" will turn into just "x" in mkTick.
+-}
 
-\begin{code}
 exprIsTrivial :: CoreExpr -> Bool
 exprIsTrivial (Var _)          = True        -- See Note [Variables are trivial]
 exprIsTrivial (Type _)        = True
@@ -564,14 +556,14 @@ exprIsTrivial (Tick _ _)       = False  -- See Note [Tick trivial]
 exprIsTrivial (Cast e _)       = exprIsTrivial e
 exprIsTrivial (Lam b body)     = not (isRuntimeVar b) && exprIsTrivial body
 exprIsTrivial _                = False
-\end{code}
 
+{-
 When substituting in a breakpoint we need to strip away the type cruft
 from a trivial expression and get back to the Id.  The invariant is
 that the expression we're substituting was originally trivial
 according to exprIsTrivial.
+-}
 
-\begin{code}
 getIdFromTrivialExpr :: CoreExpr -> Id
 getIdFromTrivialExpr e = go e
   where go (Var v) = v
@@ -579,14 +571,14 @@ getIdFromTrivialExpr e = go e
         go (Cast e _) = go e
         go (Lam b e) | not (isRuntimeVar b) = go e
         go e = pprPanic "getIdFromTrivialExpr" (ppr e)
-\end{code}
 
+{-
 exprIsBottom is a very cheap and cheerful function; it may return
 False for bottoming expressions, but it never costs much to ask.  See
 also CoreArity.exprBotStrictness_maybe, but that's a bit more
 expensive.
+-}
 
-\begin{code}
 exprIsBottom :: CoreExpr -> Bool
 exprIsBottom e
   = go 0 e
@@ -598,14 +590,13 @@ exprIsBottom e
     go n (Cast e _)              = go n e
     go n (Let _ e)               = go n e
     go _ _                       = False
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
              exprIsDupable
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Note [exprIsDupable]
 ~~~~~~~~~~~~~~~~~~~~
@@ -618,9 +609,8 @@ Note [exprIsDupable]
 
                 Its only purpose is to avoid fruitless let-binding
                 and then inlining of case join points
+-}
 
-
-\begin{code}
 exprIsDupable :: DynFlags -> CoreExpr -> Bool
 exprIsDupable dflags e
   = isJust (go dupAppSize e)
@@ -644,13 +634,13 @@ dupAppSize = 8   -- Size of term we are prepared to duplicate
                  -- This is *just* big enough to make test MethSharing
                  -- inline enough join points.  Really it should be
                  -- smaller, and could be if we fixed Trac #4960.
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
              exprIsCheap, exprIsExpandable
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Note [exprIsWorkFree]
 ~~~~~~~~~~~~~~~~~~~~~
@@ -676,11 +666,11 @@ The function 'noFactor' is heap-allocated and then called.  Turns out
 that 'notDivBy' is strict in its THIRD arg, but that is invisible to
 the caller of noFactor, which therefore cannot do w/w and
 heap-allocates noFactor's argument.  At the moment (May 12) we are just
-going to put up with this, because the previous more aggressive inlining 
-(which treated 'noFactor' as work-free) was duplicating primops, which 
+going to put up with this, because the previous more aggressive inlining
+(which treated 'noFactor' as work-free) was duplicating primops, which
 in turn was making inner loops of array calculations runs slow (#5623)
+-}
 
-\begin{code}
 exprIsWorkFree :: CoreExpr -> Bool
 -- See Note [exprIsWorkFree]
 exprIsWorkFree e = go 0 e
@@ -689,7 +679,7 @@ exprIsWorkFree e = go 0 e
     go _ (Type {})                    = True
     go _ (Coercion {})                = True
     go n (Cast e _)                   = go n e
-    go n (Case scrut _ _ alts)        = foldl (&&) (exprIsWorkFree scrut) 
+    go n (Case scrut _ _ alts)        = foldl (&&) (exprIsWorkFree scrut)
                                               [ go n rhs | (_,_,rhs) <- alts ]
          -- See Note [Case expressions are work-free]
     go _ (Let {})                     = False
@@ -700,8 +690,8 @@ exprIsWorkFree e = go 0 e
                     | otherwise      = go n e
     go n (App f e)  | isRuntimeArg e = exprIsWorkFree e && go (n+1) f
                     | otherwise      = go n f
-\end{code}
 
+{-
 Note [Case expressions are work-free]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Are case-expressions work-free?  Consider
@@ -750,8 +740,8 @@ Note that exprIsHNF does not imply exprIsCheap.  Eg
         let x = fac 20 in Just x
 This responds True to exprIsHNF (you can discard a seq), but
 False to exprIsCheap.
+-}
 
-\begin{code}
 exprIsCheap :: CoreExpr -> Bool
 exprIsCheap = exprIsCheap' isCheapApp
 
@@ -793,17 +783,17 @@ exprIsCheap' good_app other_expr        -- Applications and variables
     go (App f a) val_args | isRuntimeArg a = go f (a:val_args)
                           | otherwise      = go f val_args
 
-    go (Var _) [] = True        
+    go (Var _) [] = True
          -- Just a type application of a variable
          -- (f t1 t2 t3) counts as WHNF
          -- This case is probably handeld by the good_app case
          -- below, which should have a case for n=0, but putting
          -- it here too is belt and braces; and it's such a common
-         -- case that checking for null directly seems like a 
+         -- case that checking for null directly seems like a
          -- good plan
 
     go (Var f) args
-       | good_app f (length args) 
+       | good_app f (length args)
        = go_pap args
 
        | otherwise
@@ -845,16 +835,16 @@ exprIsCheap' good_app other_expr        -- Applications and variables
                 --      there's no guarantee that (sel d x) will be too.  Hence (n_val_args == 1)
 
 -------------------------------------
-type CheapAppFun = Id -> Int -> Bool  
-  -- Is an application of this function to n *value* args 
-  -- always cheap, assuming the arguments are cheap?  
+type CheapAppFun = Id -> Int -> Bool
+  -- Is an application of this function to n *value* args
+  -- always cheap, assuming the arguments are cheap?
   -- Mainly true of partial applications, data constructors,
   -- and of course true if the number of args is zero
 
 isCheapApp :: CheapAppFun
 isCheapApp fn n_val_args
-  =  isDataConWorkId fn 
-  || n_val_args == 0 
+  =  isDataConWorkId fn
+  || n_val_args == 0
   || n_val_args < idArity fn
 
 isExpandableApp :: CheapAppFun
@@ -872,8 +862,8 @@ isExpandableApp fn n_val_args
        | Just (arg, ty) <- splitFunTy_maybe ty
        , isPredTy arg                             = go (n_val_args-1) ty
        | otherwise                                = False
-\end{code}
 
+{-
 Note [Expandable overloadings]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Suppose the user wrote this
@@ -887,13 +877,13 @@ So we treat the application of a function (negate in this case) to a
 it's applied only to dictionaries.
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
              exprOkForSpeculation
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 -----------------------------
 -- | 'exprOkForSpeculation' returns True of an expression that is:
 --
@@ -1030,8 +1020,8 @@ isDivOp WordRemOp        = True
 isDivOp FloatDivOp       = True
 isDivOp DoubleDivOp      = True
 isDivOp _                = False
-\end{code}
 
+{-
 Note [exprOkForSpeculation: case expressions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 It's always sound for exprOkForSpeculation to return False, and we
@@ -1104,13 +1094,13 @@ We say "yes", even though 'x' may not be evaluated.  Reasons
     before code gen.  Until then, it's not guaranteed
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
              exprIsHNF, exprIsConLike
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 -- Note [exprIsHNF]             See also Note [exprIsCheap and exprIsHNF]
 -- ~~~~~~~~~~~~~~~~
 -- | exprIsHNF returns true for expressions that are certainly /already/
@@ -1144,9 +1134,7 @@ We say "yes", even though 'x' may not be evaluated.  Reasons
 -- unboxed type must be ok-for-speculation (or trivial).
 exprIsHNF :: CoreExpr -> Bool           -- True => Value-lambda, constructor, PAP
 exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding
-\end{code}
 
-\begin{code}
 -- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as
 -- data constructors. Conlike arguments are considered interesting by the
 -- inliner.
@@ -1209,18 +1197,17 @@ regarded as HNF if the expression they surround is HNF, because the
 tick is there to tell us that the expression was evaluated, so we
 don't want to discard a seq on it.
 -}
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
              Instantiating data constructors
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 These InstPat functions go here to avoid circularity between DataCon and Id
+-}
 
-\begin{code}
 dataConRepInstPat   ::                 [Unique] -> DataCon -> [Type] -> ([TyVar], [Id])
 dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [Id])
 
@@ -1297,8 +1284,8 @@ dataConInstPat fss uniqs con inst_tys
         info | isMarkedStrict str = vanillaIdInfo `setUnfoldingInfo` evaldUnfolding
              | otherwise          = vanillaIdInfo
              -- See Note [Mark evaluated arguments]
-\end{code}
 
+{-
 Note [Mark evaluated arguments]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When pattern matching on a constructor with strict fields, the binder
@@ -1313,13 +1300,13 @@ case in the RHS of the binding for 'v' is fine.  But only if we
 
 c.f. add_evals in Simplify.simplAlt
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
          Equality
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 -- | A cheap equality test which bales out fast!
 --      If it returns @True@ the arguments are definitely equal,
 --      otherwise, they may or may not be equal.
@@ -1339,9 +1326,7 @@ cheapEqExpr (Cast e1 t1) (Cast e2 t2)
   = e1 `cheapEqExpr` e2 && t1 `coreEqCoercion` t2
 
 cheapEqExpr _ _ = False
-\end{code}
 
-\begin{code}
 exprIsBig :: Expr b -> Bool
 -- ^ Returns @True@ of expressions that are too big to be compared by 'cheapEqExpr'
 exprIsBig (Lit _)      = False
@@ -1352,9 +1337,7 @@ exprIsBig (Lam _ e)    = exprIsBig e
 exprIsBig (App f a)    = exprIsBig f || exprIsBig a
 exprIsBig (Cast e _)   = exprIsBig e    -- Hopefully coercions are not too big!
 exprIsBig _            = True
-\end{code}
 
-\begin{code}
 eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool
 -- Compares for equality, modulo alpha
 eqExpr in_scope e1 e2
@@ -1402,21 +1385,21 @@ eqExpr in_scope e1 e2
     go_tickish env (Breakpoint lid lids) (Breakpoint rid rids)
       = lid == rid  &&  map (rnOccL env) lids == map (rnOccR env) rids
     go_tickish _ l r = l == r
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{The size of an expression}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 data CoreStats = CS { cs_tm :: Int    -- Terms
                     , cs_ty :: Int    -- Types
                     , cs_co :: Int }  -- Coercions
 
 
-instance Outputable CoreStats where 
+instance Outputable CoreStats where
  ppr (CS { cs_tm = i1, cs_ty = i2, cs_co = i3 })
    = braces (sep [ptext (sLit "terms:")     <+> intWithCommas i1 <> comma,
                   ptext (sLit "types:")     <+> intWithCommas i2 <> comma,
@@ -1471,10 +1454,7 @@ tyStats ty = zeroCS { cs_ty = typeSize ty }
 
 coStats :: Coercion -> CoreStats
 coStats co = zeroCS { cs_co = coercionSize co }
-\end{code}
-
 
-\begin{code}
 coreBindsSize :: [CoreBind] -> Int
 -- We use coreBindStats for user printout
 -- but this one is a quick and dirty basis for
@@ -1518,14 +1498,13 @@ pairSize (b,e) = bndrSize b + exprSize e
 
 altSize :: CoreAlt -> Int
 altSize (c,bs,e) = c `seq` bndrsSize bs + exprSize e
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 Eta reduction
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Note [Eta reduction conditions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1612,8 +1591,8 @@ It's true that we could also hope to eta reduce these:
     (\xy. (f x y) |> g)
 But the simplifier pushes those casts outwards, so we don't
 need to address that here.
+-}
 
-\begin{code}
 tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr
 tryEtaReduce bndrs body
   = go (reverse bndrs) body (mkReflCo Representational (exprType body))
@@ -1627,7 +1606,7 @@ tryEtaReduce bndrs body
     -- See Note [Eta reduction with casted arguments]
     -- for why we have an accumulating coercion
     go [] fun co
-      | ok_fun fun 
+      | ok_fun fun
       , let used_vars = exprFreeVars fun `unionVarSet` tyCoVarsOfCo co
       , not (any (`elemVarSet` used_vars) bndrs)
       = Just (mkCast fun co)   -- Check for any of the binders free in the result
@@ -1654,7 +1633,7 @@ tryEtaReduce bndrs body
        | isLocalId fun
        , isStrongLoopBreaker (idOccInfo fun) = 0
        | arity > 0                           = arity
-       | isEvaldUnfolding (idUnfolding fun)  = 1  
+       | isEvaldUnfolding (idUnfolding fun)  = 1
             -- See Note [Eta reduction of an eval'd function]
        | otherwise                           = 0
        where
@@ -1681,28 +1660,28 @@ tryEtaReduce bndrs body
        -- The simplifier combines multiple casts into one,
        -- so we can have a simple-minded pattern match here
     ok_arg _ _ _ = Nothing
-\end{code}
 
+{-
 Note [Eta reduction of an eval'd function]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 In Haskell is is not true that    f = \x. f x
 because f might be bottom, and 'seq' can distinguish them.
 
-But it *is* true that   f = f `seq` \x. f x 
+But it *is* true that   f = f `seq` \x. f x
 and we'd like to simplify the latter to the former.  This amounts
-to the rule that 
+to the rule that
   * when there is just *one* value argument,
   * f is not bottom
 we can eta-reduce    \x. f x  ===>  f
 
-This turned up in Trac #7542.  
+This turned up in Trac #7542.
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection{Determining non-updatable right-hand-sides}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Top-level constructor applications can usually be allocated
 statically, but they can't if the constructor, or any of the
@@ -1711,8 +1690,8 @@ labels in other DLLs).
 
 If this happens we simply make the RHS into an updatable thunk,
 and 'execute' it rather than allocating it statically.
+-}
 
-\begin{code}
 -- | This function is called only on *top-level* right-hand sides.
 -- Returns @True@ if the RHS can be allocated statically in the output,
 -- with no thunks involved at all.
@@ -1826,4 +1805,3 @@ rhsIsStatic platform is_dynamic_name rhs = is_static False rhs
         = case isDataConWorkId_maybe f of
             Just dc -> n_val_args == dataConRepArity dc
             Nothing -> False
-\end{code}
similarity index 90%
rename from compiler/coreSyn/MkCore.lhs
rename to compiler/coreSyn/MkCore.hs
index 81f0533..6905641 100644 (file)
@@ -1,4 +1,3 @@
-\begin{code}
 {-# LANGUAGE CPP #-}
 
 -- | Handy functions for creating much Core syntax
@@ -91,15 +90,15 @@ import Data.Word        ( Word )
 #endif
 
 infixl 4 `mkCoreApp`, `mkCoreApps`
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Basic CoreSyn construction}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 sortQuantVars :: [Var] -> [Var]
 -- Sort the variables (KindVars, TypeVars, and Ids)
 -- into order: Kind, then Type, then Id
@@ -219,26 +218,26 @@ castBottomExpr e res_ty
   | otherwise            = Case e (mkWildValBinder e_ty) res_ty []
   where
     e_ty = exprType e
-\end{code}
 
+{-
 The functions from this point don't really do anything cleverer than
 their counterparts in CoreSyn, but they are here for consistency
+-}
 
-\begin{code}
 -- | Create a lambda where the given expression has a number of variables
 -- bound over it. The leftmost binder is that bound by the outermost
 -- lambda in the result
 mkCoreLams :: [CoreBndr] -> CoreExpr -> CoreExpr
 mkCoreLams = mkLams
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Making literals}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 -- | Create a 'CoreExpr' which will evaluate to the given @Int@
 mkIntExpr :: DynFlags -> Integer -> CoreExpr        -- Result = I# i :: Int
 mkIntExpr dflags i = mkConApp intDataCon  [mkIntLit dflags i]
@@ -295,9 +294,6 @@ mkStringExprFS str
   where
     chars = unpackFS str
     safeChar c = ord c >= 1 && ord c <= 0x7F
-\end{code}
-
-\begin{code}
 
 -- This take a ~# b (or a ~# R b) and returns a ~ b (or Coercible a b)
 mkEqBox :: Coercion -> CoreExpr
@@ -310,15 +306,14 @@ mkEqBox co = ASSERT2( typeKind ty2 `eqKind` k, ppr co $$ ppr ty1 $$ ppr ty2 $$ p
             Representational -> coercibleDataCon
             Phantom ->          pprPanic "mkEqBox does not support boxing phantom coercions"
                                          (ppr co)
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Tuple constructors}
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
+*                                                                      *
+************************************************************************
+-}
 
 -- $big_tuples
 -- #big_tuples#
@@ -361,8 +356,7 @@ chunkify xs
     split [] = []
     split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)
 
-\end{code}
-
+{-
 Creating tuples and their types for Core expressions
 
 @mkBigCoreVarTup@ builds a tuple; the inverse to @mkTupleSelector@.
@@ -371,8 +365,7 @@ Creating tuples and their types for Core expressions
 
 * If there are more elements than a big tuple can have, it nests
   the tuples.
-
-\begin{code}
+-}
 
 -- | Build a small tuple holding the specified variables
 mkCoreVarTup :: [Id] -> CoreExpr
@@ -404,16 +397,15 @@ mkBigCoreTup = mkChunkified mkCoreTup
 -- | Build the type of a big tuple that holds the specified type of thing
 mkBigCoreTupTy :: [Type] -> Type
 mkBigCoreTupTy = mkChunkified mkBoxedTupleTy
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 Floats
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 data FloatBind
   = FloatLet  CoreBind
   | FloatCase CoreExpr Id AltCon [Var]
@@ -428,15 +420,15 @@ instance Outputable FloatBind where
 wrapFloat :: FloatBind -> CoreExpr -> CoreExpr
 wrapFloat (FloatLet defns)       body = Let defns body
 wrapFloat (FloatCase e b con bs) body = Case e b (exprType body) [(con, bs, body)]
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Tuple destructors}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 -- | Builds a selector which scrutises the given
 -- expression and extracts the one name from the list given.
 -- If you want the no-shadowing rule to apply, the caller
@@ -475,9 +467,7 @@ mkTupleSelector vars the_var scrut_var scrut
           tpl_vs  = mkTemplateLocals tpl_tys
           [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s,
                                          the_var `elem` gp ]
-\end{code}
 
-\begin{code}
 -- | Like 'mkTupleSelector' but for tuples that are guaranteed
 -- never to be \"big\".
 --
@@ -495,9 +485,7 @@ mkSmallTupleSelector vars the_var scrut_var scrut
   = ASSERT( notNull vars )
     Case scrut scrut_var (idType the_var)
          [(DataAlt (tupleCon BoxedTuple (length vars)), vars, Var the_var)]
-\end{code}
 
-\begin{code}
 -- | A generalization of 'mkTupleSelector', allowing the body
 -- of the case to be an arbitrary expression.
 --
@@ -535,9 +523,7 @@ mkTupleCase uniqs vars body scrut_var scrut
               (mkBoxedTupleTy (map idType chunk_vars))
             body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)
         in (us', scrut_var:vs, body')
-\end{code}
 
-\begin{code}
 -- | As 'mkTupleCase', but for a tuple that is small enough to be guaranteed
 -- not to need nesting.
 mkSmallTupleCase
@@ -552,18 +538,18 @@ mkSmallTupleCase [var] body _scrut_var scrut
 mkSmallTupleCase vars body scrut_var scrut
 -- One branch no refinement?
   = Case scrut scrut_var (exprType body) [(DataAlt (tupleCon BoxedTuple (length vars)), vars, body)]
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Common list manipulation expressions}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Call the constructor Ids when building explicit lists, so that they
 interact well with rules.
+-}
 
-\begin{code}
 -- | Makes a list @[]@ for lists of the specified type
 mkNilExpr :: Type -> CoreExpr
 mkNilExpr ty = mkConApp nilDataCon [Type ty]
@@ -613,16 +599,15 @@ mkBuildExpr elt_ty mk_build_inside = do
     newTyVars tyvar_tmpls = do
       uniqs <- getUniquesM
       return (zipWith setTyVarUnique tyvar_tmpls uniqs)
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                       Error expressions
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 mkRuntimeErrorApp
         :: Id           -- Should be of type (forall a. Addr# -> a)
                         --      where Addr# points to a UTF8 encoded string
@@ -638,13 +623,13 @@ mkRuntimeErrorApp err_id res_ty err_msg
 mkImpossibleExpr :: Type -> CoreExpr
 mkImpossibleExpr res_ty
   = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative"
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                      Error Ids
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 GHC randomly injects these into the code.
 
@@ -660,8 +645,8 @@ crash).
 @parError@ is a special version of @error@ which the compiler does
 not know to be a bottoming Id.  It is used in the @_par_@ and @_seq_@
 templates, but we don't ever expect to generate code for it.
+-}
 
-\begin{code}
 errorIds :: [Id]
 errorIds
   = [ eRROR_ID,   -- This one isn't used anywhere else in the compiler
@@ -719,9 +704,7 @@ mkRuntimeErrorId name = pc_bottoming_Id1 name runtimeErrorTy
 runtimeErrorTy :: Type
 -- The runtime error Ids take a UTF8-encoded string as argument
 runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy)
-\end{code}
 
-\begin{code}
 errorName :: Name
 errorName = mkWiredInIdName gHC_ERR (fsLit "error") errorIdKey eRROR_ID
 
@@ -739,8 +722,8 @@ uNDEFINED_ID = pc_bottoming_Id0 undefinedName undefinedTy
 
 undefinedTy  :: Type   -- See Note [Error and friends have an "open-tyvar" forall]
 undefinedTy  = mkSigmaTy [openAlphaTyVar] [] openAlphaTy
-\end{code}
 
+{-
 Note [Error and friends have an "open-tyvar" forall]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 'error' and 'undefined' have types
@@ -754,13 +737,13 @@ This is OK because it never returns, so the return type is irrelevant.
 See Note [OpenTypeKind accepts foralls] in TcUnify.
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection{Utilities}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 pc_bottoming_Id1 :: Name -> Type -> Id
 -- Function of arity 1, which diverges after being given one argument
 pc_bottoming_Id1 name ty
@@ -789,4 +772,3 @@ pc_bottoming_Id0 name ty
  where
     bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig
     strict_sig = mkClosedStrictSig [] botRes
-\end{code}
similarity index 93%
rename from compiler/coreSyn/PprCore.lhs
rename to compiler/coreSyn/PprCore.hs
index 593c670..acc6c79 100644 (file)
@@ -1,11 +1,11 @@
-%
-(c) The University of Glasgow 2006
-(c) The AQUA Project, Glasgow University, 1996-1998
-%
+{-
+(c) The University of Glasgow 2006
+(c) The AQUA Project, Glasgow University, 1996-1998
+
 
 Printing of Core syntax
+-}
 
-\begin{code}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module PprCore (
         pprCoreExpr, pprParendExpr,
@@ -29,17 +29,17 @@ import BasicTypes
 import Util
 import Outputable
 import FastString
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Public interfaces for Core printing (excluding instances)}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
+-}
 
-\begin{code}
 pprCoreBindings :: OutputableBndr b => [Bind b] -> SDoc
 pprCoreBinding  :: OutputableBndr b => Bind b  -> SDoc
 pprCoreExpr     :: OutputableBndr b => Expr b  -> SDoc
@@ -53,16 +53,15 @@ instance OutputableBndr b => Outputable (Bind b) where
 
 instance OutputableBndr b => Outputable (Expr b) where
     ppr expr = pprCoreExpr expr
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{The guts}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 pprTopBinds :: OutputableBndr a => [Bind a] -> SDoc
 pprTopBinds binds = vcat (map pprTopBind binds)
 
@@ -78,9 +77,7 @@ pprTopBind (Rec (b:bs))
           vcat [blankLine $$ ppr_binding b | b <- bs],
           ptext (sLit "end Rec }"),
           blankLine]
-\end{code}
 
-\begin{code}
 ppr_bind :: OutputableBndr b => Bind b -> SDoc
 
 ppr_bind (NonRec val_bdr expr) = ppr_binding (val_bdr, expr)
@@ -92,17 +89,13 @@ ppr_binding :: OutputableBndr b => (b, Expr b) -> SDoc
 ppr_binding (val_bdr, expr)
   = pprBndr LetBind val_bdr $$
     hang (ppr val_bdr <+> equals) 2 (pprCoreExpr expr)
-\end{code}
 
-\begin{code}
 pprParendExpr expr = ppr_expr parens expr
 pprCoreExpr   expr = ppr_expr noParens expr
 
 noParens :: SDoc -> SDoc
 noParens pp = pp
-\end{code}
 
-\begin{code}
 ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
         -- The function adds parens in context that need
         -- an atomic value (e.g. function args)
@@ -158,7 +151,7 @@ ppr_expr add_par (Case expr var ty [(con,args,rhs)])
   = sdocWithDynFlags $ \dflags ->
     if gopt Opt_PprCaseAsLet dflags
     then add_par $  -- See Note [Print case as let]
-         sep [ sep [ ptext (sLit "let! {") 
+         sep [ sep [ ptext (sLit "let! {")
                      <+> ppr_case_pat con args
                      <+> ptext (sLit "~")
                      <+> ppr_bndr var
@@ -252,23 +245,23 @@ pprArg (Type ty)
    else ptext (sLit "@") <+> pprParendType ty
 pprArg (Coercion co) = ptext (sLit "@~") <+> pprParendCo co
 pprArg expr          = pprParendExpr expr
-\end{code}
 
+{-
 Note [Print case as let]
 ~~~~~~~~~~~~~~~~~~~~~~~~
 Single-branch case expressions are very common:
-   case x of y { I# x' -> 
+   case x of y { I# x' ->
    case p of q { I# p' -> ... } }
 These are, in effect, just strict let's, with pattern matching.
 With -dppr-case-as-let we print them as such:
    let! { I# x' ~ y <- x } in
    let! { I# p' ~ q <- p } in ...
 
+
 Other printing bits-and-bobs used with the general @pprCoreBinding@
 and @pprCoreExpr@ functions.
+-}
 
-\begin{code}
 instance OutputableBndr Var where
   pprBndr = pprCoreBinder
   pprInfixOcc  = pprInfixName  . varName
@@ -351,7 +344,7 @@ pprIdBndrInfo info
 
     has_prag  = not (isDefaultInlinePragma prag_info)
     has_occ   = not (isNoOcc occ_info)
-    has_dmd   = not $ isTopDmd dmd_info 
+    has_dmd   = not $ isTopDmd dmd_info
     has_lbv   = not (hasNoOneShotInfo lbv_info)
 
     doc = showAttributes
@@ -360,14 +353,13 @@ pprIdBndrInfo info
           , (has_dmd,  ptext (sLit "Dmd=") <> ppr dmd_info)
           , (has_lbv , ptext (sLit "OS=") <> ppr lbv_info)
           ]
-\end{code}
-
 
+{-
 -----------------------------------------------------
 --      IdDetails and IdInfo
 -----------------------------------------------------
+-}
 
-\begin{code}
 ppIdInfo :: Id -> IdInfo -> SDoc
 ppIdInfo id info
   = sdocWithDynFlags $ \dflags ->
@@ -412,13 +404,13 @@ showAttributes stuff
   | otherwise = brackets (sep (punctuate comma docs))
   where
     docs = [d | (True,d) <- stuff]
-\end{code}
 
+{-
 -----------------------------------------------------
 --      Unfolding and UnfoldingGuidance
 -----------------------------------------------------
+-}
 
-\begin{code}
 instance Outputable UnfoldingGuidance where
     ppr UnfNever  = ptext (sLit "NEVER")
     ppr (UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok })
@@ -441,7 +433,7 @@ instance Outputable Unfolding where
   ppr NoUnfolding                = ptext (sLit "No unfolding")
   ppr (OtherCon cs)              = ptext (sLit "OtherCon") <+> ppr cs
   ppr (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args })
-       = hang (ptext (sLit "DFun:") <+> ptext (sLit "\\") 
+       = hang (ptext (sLit "DFun:") <+> ptext (sLit "\\")
                 <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
             2 (ppr con <+> sep (map ppr args))
   ppr (CoreUnfolding { uf_src = src
@@ -463,13 +455,13 @@ instance Outputable Unfolding where
              | otherwise          = empty
             -- Don't print the RHS or we get a quadratic
             -- blowup in the size of the printout!
-\end{code}
 
+{-
 -----------------------------------------------------
 --      Rules
 -----------------------------------------------------
+-}
 
-\begin{code}
 instance Outputable CoreRule where
    ppr = pprRule
 
@@ -489,13 +481,13 @@ pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
                nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
                nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs)
             ])
-\end{code}
 
+{-
 -----------------------------------------------------
 --      Tickish
 -----------------------------------------------------
+-}
 
-\begin{code}
 instance Outputable id => Outputable (Tickish id) where
   ppr (HpcTick modl ix) =
       hcat [ptext (sLit "tick<"),
@@ -514,13 +506,13 @@ instance Outputable id => Outputable (Tickish id) where
          (True,True)  -> hcat [ptext (sLit "scctick<"), ppr cc, char '>']
          (True,False) -> hcat [ptext (sLit "tick<"),    ppr cc, char '>']
          _            -> hcat [ptext (sLit "scc<"),     ppr cc, char '>']
-\end{code}
 
+{-
 -----------------------------------------------------
 --      Vectorisation declarations
 -----------------------------------------------------
+-}
 
-\begin{code}
 instance Outputable CoreVect where
   ppr (Vect     var e)               = hang (ptext (sLit "VECTORISE") <+> ppr var <+> char '=')
                                          4 (pprCoreExpr e)
@@ -533,4 +525,3 @@ instance Outputable CoreVect where
                                        char '=' <+> ppr tc
   ppr (VectClass tc)                 = ptext (sLit "VECTORISE class") <+> ppr tc
   ppr (VectInst var)                 = ptext (sLit "VECTORISE SCALAR instance") <+> ppr var
-\end{code}
similarity index 91%
rename from compiler/coreSyn/TrieMap.lhs
rename to compiler/coreSyn/TrieMap.hs
index d552506..57f360e 100644 (file)
@@ -1,9 +1,8 @@
-%
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+-}
 
-\begin{code}
 {-# LANGUAGE RankNTypes, TypeFamilies #-}
 module TrieMap(
    CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap,
@@ -34,8 +33,8 @@ import VarEnv
 import NameEnv
 import Outputable
 import Control.Monad( (>=>) )
-\end{code}
 
+{-
 This module implements TrieMaps, which are finite mappings
 whose key is a structured value like a CoreExpr or Type.
 
@@ -43,13 +42,13 @@ The code is very regular and boilerplate-like, but there is
 some neat handling of *binders*.  In effect they are deBruijn
 numbered on the fly.
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
                    The TrieMap class
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 type XT a = Maybe a -> Maybe a  -- How to alter a non-existent elt (Nothing)
                                 --               or an existing elt (Just)
 
@@ -94,15 +93,15 @@ x |> f = f x
 deMaybe :: TrieMap m => Maybe (m a) -> m a
 deMaybe Nothing  = emptyTM
 deMaybe (Just m) = m
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                    IntMaps
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 instance TrieMap IntMap.IntMap where
   type Key IntMap.IntMap = Int
   emptyTM = IntMap.empty
@@ -129,19 +128,18 @@ instance TrieMap UniqFM where
   alterTM k f m = alterUFM f m k
   foldTM k m z = foldUFM k z m
   mapTM f m = mapUFM f m
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                    Lists
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 If              m is a map from k -> val
 then (MaybeMap m) is a map from (Maybe k) -> val
+-}
 
-\begin{code}
 data MaybeMap m a = MM { mm_nothing  :: Maybe a, mm_just :: m a }
 
 instance TrieMap m => TrieMap (MaybeMap m) where
@@ -205,16 +203,15 @@ fdList k m = foldMaybe k          (lm_nil m)
 foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b
 foldMaybe _ Nothing  b = b
 foldMaybe k (Just a) b = k a b
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                    Basic maps
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 lkNamed :: NamedThing n => n -> NameEnv a -> Maybe a
 lkNamed n env = lookupNameEnv env (getName n)
 
@@ -232,13 +229,13 @@ lkLit = lookupTM
 
 xtLit :: Literal -> XT a -> LiteralMap a -> LiteralMap a
 xtLit = alterTM
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                    CoreMap
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Note [Binders]
 ~~~~~~~~~~~~~~
@@ -268,8 +265,8 @@ is that it's unnecesary, so we have two fields (cm_case and cm_ecase)
 for the two possibilities.  Only cm_ecase looks at the type.
 
 See also Note [Empty case alternatives] in CoreSyn.
+-}
 
-\begin{code}
 data CoreMap a
   = EmptyCM
   | CM { cm_var   :: VarMap a
@@ -449,15 +446,15 @@ fdA :: (a -> b -> b) -> AltMap a -> b -> b
 fdA k m = foldTM k (am_deflt m)
         . foldTM (foldTM k) (am_data m)
         . foldTM (foldTM k) (am_lit m)
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                    Coercions
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 data CoercionMap a
   = EmptyKM
   | KM { km_refl   :: RoleMap (TypeMap a)
@@ -586,10 +583,6 @@ fdC k m = foldTM (foldTM k) (km_refl m)
         . foldTM k          (km_sub m)
         . foldTM (foldTM (foldTM k)) (km_axiom_rule m)
 
-\end{code}
-
-\begin{code}
-
 newtype RoleMap a = RM { unRM :: (IntMap.IntMap a) }
 
 instance TrieMap RoleMap where
@@ -616,16 +609,14 @@ fdR f (RM m) = foldTM f m
 mapR :: (a -> b) -> RoleMap a -> RoleMap b
 mapR f = RM . mapTM f . unRM
 
-\end{code}
-
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                    Types
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 data TypeMap a
   = EmptyTM
   | TM { tm_var   :: VarMap a
@@ -764,16 +755,15 @@ xtTyLit l f m =
 foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b
 foldTyLit l m = flip (Map.fold l) (tlm_string m)
               . flip (Map.fold l) (tlm_number m)
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                    Variables
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 type BoundVar = Int  -- Bound variables are deBruijn numbered
 type BoundVarMap a = IntMap.IntMap a
 
@@ -837,4 +827,3 @@ lkFreeVar var env = lookupVarEnv env var
 
 xtFreeVar :: Var -> XT a -> VarEnv a -> VarEnv a
 xtFreeVar v f m = alterVarEnv f m v
-\end{code}