[project @ 2001-02-26 15:42:24 by simonpj]

[ghc-hetmet.git] / ghc / compiler / coreSyn / CoreSyn.lhs

diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs
index fa08ba4..b78bbcf 100644 (file)
--- a/ghc/compiler/coreSyn/CoreSyn.lhs
+++ b/ghc/compiler/coreSyn/CoreSyn.lhs
@@ -15,7 +15,8 @@ module CoreSyn (
        mkConApp, 
        varToCoreExpr,
 
-       bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, isTyVar, isId,
+       isTyVar, isId, 
+       bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, 
        collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
        collectArgs, collectBindersIgnoringNotes,
        coreExprCc,
@@ -28,17 +29,19 @@ module CoreSyn (
        noUnfolding, mkOtherCon,
        unfoldingTemplate, maybeUnfoldingTemplate, otherCons, 
        isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
-       hasUnfolding, hasSomeUnfolding,
+       hasUnfolding, hasSomeUnfolding, neverUnfold,
 
        -- Seq stuff
        seqRules, seqExpr, seqExprs, seqUnfolding,
 
        -- Annotated expressions
-       AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, deAnnotate, deAnnotate',
+       AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, 
+       deAnnotate, deAnnotate', deAnnAlt,
 
        -- Core rules
        CoreRules(..),  -- Representation needed by friends
        CoreRule(..),   -- CoreSubst, CoreTidy, CoreFVs, PprCore only
+       IdCoreRule,
        RuleName,
        emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules,
        isBuiltinRule
@@ -47,11 +50,9 @@ module CoreSyn (
 #include "HsVersions.h"
 
 import CostCentre      ( CostCentre, noCostCentre )
-import Var             ( Var, Id, TyVar, isTyVar, isId, idType )
-import VarEnv
-import Type            ( Type, UsageAnn, mkTyVarTy, isUnLiftedType, seqType )
-import Literal         ( Literal(MachStr), mkMachInt )
-import PrimOp          ( PrimOp )
+import Var             ( Var, Id, TyVar, isTyVar, isId )
+import Type            ( Type, mkTyVarTy, seqType )
+import Literal         ( Literal, mkMachInt )
 import DataCon         ( DataCon, dataConId )
 import VarSet
 import Outputable
@@ -104,9 +105,6 @@ data Note
 
   | InlineMe           -- Instructs simplifer to treat the enclosed expression
                        -- as very small, and inline it at its call sites
-
-  | TermUsg             -- A term-level usage annotation
-        UsageAnn        -- (should not be a variable except during UsageSP inference)
 \end{code}
 
 
@@ -139,6 +137,7 @@ rulesRules (Rules rules _) = rules
 
 \begin{code}
 type RuleName = FAST_STRING
+type IdCoreRule = (Id,CoreRule)                -- Rules don't have their leading Id inside them
 
 data CoreRule
   = Rule RuleName
@@ -182,12 +181,11 @@ data Unfolding
 
   | CoreUnfolding                      -- An unfolding with redundant cached information
                CoreExpr                -- Template; binder-info is correct
-               Bool                    -- This is a top-level binding
-               Bool                    -- exprIsCheap template (cached); it won't duplicate (much) work 
-                                       --      if you inline this in more than one place
+               Bool                    -- True <=> top level binding
                Bool                    -- exprIsValue template (cached); it is ok to discard a `seq` on
                                        --      this variable
-               Bool                    -- exprIsBottom template (cached)
+               Bool                    -- True <=> doesn't waste (much) work to expand inside an inlining
+                                       --      Basically it's exprIsCheap
                UnfoldingGuidance       -- Tells about the *size* of the template.
 
 
@@ -210,8 +208,8 @@ noUnfolding = NoUnfolding
 mkOtherCon  = OtherCon
 
 seqUnfolding :: Unfolding -> ()
-seqUnfolding (CoreUnfolding e top b1 b2 b3 g)
-  = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` seqGuidance g
+seqUnfolding (CoreUnfolding e top b1 b2 g)
+  = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g
 seqUnfolding other = ()
 
 seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
@@ -220,14 +218,14 @@ seqGuidance other                 = ()
 
 \begin{code}
 unfoldingTemplate :: Unfolding -> CoreExpr
-unfoldingTemplate (CoreUnfolding expr _ _ _ _ _) = expr
-unfoldingTemplate (CompulsoryUnfolding expr)     = expr
+unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr
+unfoldingTemplate (CompulsoryUnfolding expr)   = expr
 unfoldingTemplate other = panic "getUnfoldingTemplate"
 
 maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
-maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _ _) = Just expr
-maybeUnfoldingTemplate (CompulsoryUnfolding expr)     = Just expr
-maybeUnfoldingTemplate other                         = Nothing
+maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr
+maybeUnfoldingTemplate (CompulsoryUnfolding expr)   = Just expr
+maybeUnfoldingTemplate other                       = Nothing
 
 otherCons :: Unfolding -> [AltCon]
 otherCons (OtherCon cons) = cons
@@ -235,31 +233,37 @@ otherCons other             = []
 
 isValueUnfolding :: Unfolding -> Bool
        -- Returns False for OtherCon
-isValueUnfolding (CoreUnfolding _ _ _ is_evald _ _) = is_evald
-isValueUnfolding other                             = False
+isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
+isValueUnfolding other                           = False
 
 isEvaldUnfolding :: Unfolding -> Bool
        -- Returns True for OtherCon
-isEvaldUnfolding (OtherCon _)                      = True
-isEvaldUnfolding (CoreUnfolding _ _ _ is_evald _ _) = is_evald
-isEvaldUnfolding other                             = False
+isEvaldUnfolding (OtherCon _)                    = True
+isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
+isEvaldUnfolding other                           = False
 
 isCheapUnfolding :: Unfolding -> Bool
-isCheapUnfolding (CoreUnfolding _ _ is_cheap _ _ _) = is_cheap
-isCheapUnfolding other                             = False
+isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap
+isCheapUnfolding other                           = False
 
 isCompulsoryUnfolding :: Unfolding -> Bool
 isCompulsoryUnfolding (CompulsoryUnfolding _) = True
 isCompulsoryUnfolding other                  = False
 
 hasUnfolding :: Unfolding -> Bool
-hasUnfolding (CoreUnfolding _ _ _ _ _ _) = True
-hasUnfolding (CompulsoryUnfolding _)     = True
-hasUnfolding other                      = False
+hasUnfolding (CoreUnfolding _ _ _ _ _) = True
+hasUnfolding (CompulsoryUnfolding _)   = True
+hasUnfolding other                    = False
 
 hasSomeUnfolding :: Unfolding -> Bool
 hasSomeUnfolding NoUnfolding = False
 hasSomeUnfolding other      = True
+
+neverUnfold :: Unfolding -> Bool
+neverUnfold NoUnfolding                                = True
+neverUnfold (OtherCon _)                       = True
+neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True
+neverUnfold other                              = False
 \end{code}
 
 
@@ -299,7 +303,6 @@ type CoreExpr = Expr CoreBndr
 type CoreArg  = Arg  CoreBndr
 type CoreBind = Bind CoreBndr
 type CoreAlt  = Alt  CoreBndr
-type CoreNote = Note
 \end{code}
 
 Binders are ``tagged'' with a \tr{t}:
@@ -453,6 +456,7 @@ coreExprCc other               = noCostCentre
 \end{code}
 
 
+
 %************************************************************************
 %*                                                                     *
 \subsection{Predicates}
@@ -570,7 +574,8 @@ deAnnotate' (AnnLet bind body)
 
 deAnnotate' (AnnCase scrut v alts)
   = Case (deAnnotate scrut) v (map deAnnAlt alts)
-  where
-    deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
+
+deAnnAlt :: AnnAlt bndr annot -> Alt bndr
+deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
 \end{code}