Simon's big boxy-type commit

[ghc-hetmet.git] / ghc / compiler / basicTypes / BasicTypes.lhs

diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs
index b0b3bc1..6b662bd 100644 (file)
--- a/ghc/compiler/basicTypes/BasicTypes.lhs
+++ b/ghc/compiler/basicTypes/BasicTypes.lhs
@@ -22,7 +22,7 @@ module BasicTypes(
 
        Fixity(..), FixityDirection(..),
        defaultFixity, maxPrecedence, 
-       negateFixity,
+       negateFixity, funTyFixity,
        compareFixity,
 
        IPName(..), ipNameName, mapIPName,
@@ -36,10 +36,11 @@ module BasicTypes(
        TupCon(..), tupleParens,
 
        OccInfo(..), seqOccInfo, isFragileOcc, isOneOcc, 
-       isDeadOcc, isLoopBreaker,
+       isDeadOcc, isLoopBreaker, isNoOcc,
 
        InsideLam, insideLam, notInsideLam,
        OneBranch, oneBranch, notOneBranch,
+       InterestingCxt,
 
         EP(..),
 
@@ -47,6 +48,7 @@ module BasicTypes(
 
        CompilerPhase, 
        Activation(..), isActive, isNeverActive, isAlwaysActive,
+       InlineSpec(..), defaultInlineSpec, alwaysInlineSpec, neverInlineSpec,
 
        SuccessFlag(..), succeeded, failed, successIf
    ) where
@@ -155,11 +157,10 @@ instance Outputable FixityDirection where
 maxPrecedence = (9::Int)
 defaultFixity = Fixity maxPrecedence InfixL
 
-negateFixity :: Fixity
-negateFixity     = Fixity negatePrecedence InfixL      -- Precedence of unary negate is wired in as infixl 6!
-
-negatePrecedence :: Int
-negatePrecedence = 6
+negateFixity, funTyFixity :: Fixity
+-- Wired-in fixities
+negateFixity = Fixity 6 InfixL         -- Fixity of unary negate
+funTyFixity  = Fixity 0        InfixR  -- Fixity of '->'
 \end{code}
 
 Consider
@@ -332,23 +333,33 @@ data OccInfo
   | IAmDead            -- Marks unused variables.  Sometimes useful for
                        -- lambda and case-bound variables.
 
-  | OneOcc InsideLam
-
-          OneBranch
+  | OneOcc !InsideLam
+          !OneBranch
+          !InterestingCxt
 
   | IAmALoopBreaker    -- Used by the occurrence analyser to mark loop-breakers
                        -- in a group of recursive definitions
 
+isNoOcc :: OccInfo -> Bool
+isNoOcc NoOccInfo = True
+isNoOcc other     = False
+
 seqOccInfo :: OccInfo -> ()
-seqOccInfo (OneOcc in_lam once) = in_lam `seq` once `seq` ()
-seqOccInfo occ                 = ()
+seqOccInfo occ = occ `seq` ()
+
+-----------------
+type InterestingCxt = Bool     -- True <=> Function: is applied
+                               --          Data value: scrutinised by a case with
+                               --                      at least one non-DEFAULT branch
 
+-----------------
 type InsideLam = Bool  -- True <=> Occurs inside a non-linear lambda
                        -- Substituting a redex for this occurrence is
                        -- dangerous because it might duplicate work.
 insideLam    = True
 notInsideLam = False
 
+-----------------
 type OneBranch = Bool  -- True <=> Occurs in only one case branch
                        --      so no code-duplication issue to worry about
 oneBranch    = True
@@ -362,12 +373,12 @@ isDeadOcc :: OccInfo -> Bool
 isDeadOcc IAmDead = True
 isDeadOcc other          = False
 
-isOneOcc (OneOcc _ _) = True
-isOneOcc other       = False
+isOneOcc (OneOcc _ _ _) = True
+isOneOcc other         = False
 
 isFragileOcc :: OccInfo -> Bool
-isFragileOcc (OneOcc _ _) = True
-isFragileOcc other       = False
+isFragileOcc (OneOcc _ _ _) = True
+isFragileOcc other         = False
 \end{code}
 
 \begin{code}
@@ -376,9 +387,15 @@ instance Outputable OccInfo where
   ppr NoOccInfo                                  = empty
   ppr IAmALoopBreaker                            = ptext SLIT("LoopBreaker")
   ppr IAmDead                                    = ptext SLIT("Dead")
-  ppr (OneOcc inside_lam one_branch) | inside_lam = ptext SLIT("OnceInLam")
-                                    | one_branch = ptext SLIT("Once")
-                                    | otherwise  = ptext SLIT("OnceEachBranch")
+  ppr (OneOcc inside_lam one_branch int_cxt)
+       = ptext SLIT("Once") <> pp_lam <> pp_br <> pp_args
+       where
+         pp_lam | inside_lam = char 'L'
+                | otherwise  = empty
+         pp_br  | one_branch = empty
+                | otherwise  = char '*'
+         pp_args | int_cxt   = char '!'
+                 | otherwise = empty
 
 instance Show OccInfo where
   showsPrec p occ = showsPrecSDoc p (ppr occ)
@@ -454,12 +471,27 @@ data Activation = NeverActive
                | ActiveAfter CompilerPhase     -- Active in this phase and later
                deriving( Eq )                  -- Eq used in comparing rules in HsDecls
 
+data InlineSpec
+  = Inline 
+       Activation      -- Says during which phases inlining is allowed
+       Bool            -- True <=> make the RHS look small, so that when inlining
+                       --          is enabled, it will definitely actually happen
+  deriving( Eq )
+
+defaultInlineSpec = Inline AlwaysActive False  -- Inlining is OK, but not forced
+alwaysInlineSpec  = Inline AlwaysActive True   -- INLINE always
+neverInlineSpec   = Inline NeverActive  False  -- NOINLINE 
+
 instance Outputable Activation where
    ppr AlwaysActive     = empty                -- The default
    ppr (ActiveBefore n) = brackets (char '~' <> int n)
    ppr (ActiveAfter n)  = brackets (int n)
    ppr NeverActive      = ptext SLIT("NEVER")
     
+instance Outputable InlineSpec where
+   ppr (Inline act True)  = ptext SLIT("INLINE") <> ppr act
+   ppr (Inline act False) = ptext SLIT("NOINLINE") <> ppr act
+
 isActive :: CompilerPhase -> Activation -> Bool
 isActive p NeverActive      = False
 isActive p AlwaysActive     = True