compiler/GHC/Core/Opt/Arity.hs

@@ -350,14 +350,7 @@ this transformation.  So we try to limit it as much as possible:
        case undefined of { (a,b) -> \y -> e }
      This showed up in #5557
 
- (2) Do NOT move a lambda outside a case if all the branches of
-     the case are known to return bottom.
-        case x of { (a,b) -> \y -> error "urk" }
-     This case is less important, but the idea is that if the fn is
-     going to diverge eventually anyway then getting the best arity
-     isn't an issue, so we might as well play safe
-
- (3) Do NOT move a lambda outside a case unless
+ (2) Do NOT move a lambda outside a case unless
      (a) The scrutinee is ok-for-speculation, or
      (b) more liberally: the scrutinee is cheap (e.g. a variable), and
          -fpedantic-bottoms is not enforced (see #2915 for an example)
@@ -554,7 +547,7 @@ vanillaArityType = ATop []      -- Totally uninformative
 exprEtaExpandArity :: DynFlags -> CoreExpr -> ArityType
 -- exprEtaExpandArity is used when eta expanding
 --      e  ==>  \xy -> e x y
-exprEtaExpandArity dflags e = arityType (initArityEnv dflags) e
+exprEtaExpandArity dflags e = arityType (etaExpandArityEnv dflags) e
 
 getBotArity :: ArityType -> Maybe Arity
 -- Arity of a divergent function
@@ -592,9 +585,10 @@ findRhsArity dflags bndr rhs old_arity
         new_atype = step cur_atype
 
     step :: ArityType -> ArityType
-    step at = arityType env rhs
+    step at = -- pprTrace "step" (ppr bndr <+> ppr at <+> ppr (arityType env rhs)) $
+              arityType env rhs
       where
-        env = extendSigEnv (initArityEnv dflags) bndr at
+        env = extendSigEnv (findRhsArityEnv dflags) bndr at
 
 {-
 Note [Arity analysis]
@@ -612,17 +606,29 @@ This example happens a lot; it first showed up in Andy Gill's thesis,
 fifteen years ago!  It also shows up in the code for 'rnf' on lists
 in #4138.
 
-The analysis is easy to achieve because exprEtaExpandArity takes an
-argument
-     type CheapFun = CoreExpr -> Maybe Type -> Bool
-used to decide if an expression is cheap enough to push inside a
-lambda.  And exprIsCheapX in turn takes an argument
-     type CheapAppFun = Id -> Int -> Bool
-which tells when an application is cheap. This makes it easy to
-write the analysis loop.
+We do the neccessary, quite simple fixed-point iteration in 'findRhsArity',
+which assumes for a single binding @botArityType@ on the first run and iterates
+until it finds a stable arity type. Two wrinkles
 
-The analysis is cheap-and-cheerful because it doesn't deal with
-mutual recursion.  But the self-recursive case is the important one.
+* We often have to ask (see the Case or Let case of 'arityType') whether some
+  expression is cheap. In the case of an application, that depends on the arity
+  of the application head! That's why we have our own version of 'exprIsCheap',
+  'myExprIsCheap', that will integrate the optimistic arity types we have on
+  f and g into the cheapness check.
+
+* Consider this (#18793)
+
+    go = \ds. case ds of
+           []     -> id
+           (x:ys) -> let acc = go ys in
+                     case blah of
+                       True  -> acc
+                       False -> \ x1 -> acc (negate x1)
+
+  We must propagate go's optimistically large arity to @acc@, so that the
+  tail call to @acc@ in the True branch has sufficient arity.  This is done
+  by the 'am_sigs' field in 'FindRhsArity', and 'lookupSigEnv' in the Var case
+  of 'arityType'.
 
 Note [Eta expanding through dictionaries]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -727,69 +733,104 @@ encountered a cast, but that is far too conservative: see #5475
 
 ---------------------------
 
+-- | Each of the entry-points of the analyser ('arityType') has different
+-- requirements. The entry-points are
+--
+--   1. 'exprBotStrictness_maybe'
+--   2. 'exprEtaExpandArity'
+--   3. 'findRhsArity'
+--
+-- For each of the entry-points, there is a separate mode that governs
+--
+--   1. How pedantic we are wrt. ⊥, in 'pedanticBottoms'.
+--   2. Whether we store arity signatures for non-recursive let-bindings,
+--      accessed in 'extendSigEnv'/'lookupSigEnv'.
+--      See Note [Arity analysis] why that's important.
+--   3. Which expressions we consider cheap to float inside a lambda,
+--      in 'myExprIsCheap'.
 data AnalysisMode
   = BotStrictness
   -- ^ Used during 'exprBotStrictness_maybe'.
-  | ArityAnalysis { aa_ped_bot :: !Bool
-                  , aa_dicts_cheap :: !Bool
-                  , aa_sigs :: !(IdEnv ArityType) }
-  -- ^ Used for regular arity analysis ('exprEtaExpandArity', 'findRhsArity').
+  | EtaExpandArity { am_ped_bot :: !Bool
+                   , am_dicts_cheap :: !Bool }
+  -- ^ Used for finding an expression's eta-expanding arity quickly, without
+  -- fixed-point iteration ('exprEtaExpandArity').
+  | FindRhsArity { am_ped_bot :: !Bool
+                 , am_dicts_cheap :: !Bool
+                 , am_sigs :: !(IdEnv ArityType) }
+  -- ^ Used for regular, fixed-point arity analysis ('findRhsArity').
+  --   See Note [Arity analysis] for details about fixed-point iteration.
 
 data ArityEnv
   = AE
   { ae_mode   :: !AnalysisMode
-  -- ^ The analysis mode. Called during 'exprBotStrictness_maybe' or not?
+  -- ^ The analysis mode. See 'AnalysisMode'.
   , ae_joins  :: !IdSet
   -- ^ In-scope join points. See Note [Eta-expansion and join points]
   }
 
--- | A regular, initial @ArityEnv@ used in arity analysis.
-initArityEnv :: DynFlags -> ArityEnv
-initArityEnv dflags
-  = AE { ae_mode  = ArityAnalysis { aa_ped_bot = gopt Opt_PedanticBottoms dflags
-                                  , aa_dicts_cheap = gopt Opt_DictsCheap dflags
-                                  , aa_sigs = emptyVarEnv }
-       , ae_joins = emptyVarSet }
-
 -- | The @ArityEnv@ used by 'exprBotStrictness_maybe'. Pedantic about bottoms
 -- and no application is ever considered cheap.
 botStrictnessArityEnv :: ArityEnv
 botStrictnessArityEnv = AE { ae_mode = BotStrictness, ae_joins = emptyVarSet }
 
+-- | The @ArityEnv@ used by 'exprEtaExpandArity'.
+etaExpandArityEnv :: DynFlags -> ArityEnv
+etaExpandArityEnv dflags
+  = AE { ae_mode  = EtaExpandArity { am_ped_bot = gopt Opt_PedanticBottoms dflags
+                                   , am_dicts_cheap = gopt Opt_DictsCheap dflags }
+       , ae_joins = emptyVarSet }
+
+-- | The @ArityEnv@ used by 'findRhsArity'.
+findRhsArityEnv :: DynFlags -> ArityEnv
+findRhsArityEnv dflags
+  = AE { ae_mode  = FindRhsArity { am_ped_bot = gopt Opt_PedanticBottoms dflags
+                                 , am_dicts_cheap = gopt Opt_DictsCheap dflags
+                                 , am_sigs = emptyVarEnv }
+       , ae_joins = emptyVarSet }
+
 extendJoinEnv :: ArityEnv -> [JoinId] -> ArityEnv
 extendJoinEnv env@(AE { ae_joins = joins }) join_ids
   = env { ae_joins = joins `extendVarSetList` join_ids }
 
 extendSigEnv :: ArityEnv -> Id -> ArityType -> ArityEnv
-extendSigEnv env id ar_ty = env { ae_mode = go (ae_mode env) }
-  where
-    go BotStrictness = BotStrictness
-    go aa            = aa { aa_sigs = extendVarEnv (aa_sigs aa) id ar_ty }
+extendSigEnv env@AE { ae_mode = am@FindRhsArity{am_sigs = sigs} } id ar_ty =
+  env { ae_mode = am { am_sigs = extendVarEnv sigs id ar_ty } }
+extendSigEnv env _ _ = env
 
 lookupSigEnv :: ArityEnv -> Id -> Maybe ArityType
 lookupSigEnv AE{ ae_mode = mode } id = case mode of
-  BotStrictness                   -> Nothing
-  ArityAnalysis{ aa_sigs = sigs } -> lookupVarEnv sigs id
+  BotStrictness                  -> Nothing
+  EtaExpandArity{}               -> Nothing
+  FindRhsArity{ am_sigs = sigs } -> lookupVarEnv sigs id
 
 -- | Whether the analysis should be pedantic about bottoms.
 -- 'exprBotStrictness_maybe' always is.
 pedanticBottoms :: ArityEnv -> Bool
 pedanticBottoms AE{ ae_mode = mode } = case mode of
-  BotStrictness                         -> True
-  ArityAnalysis{ aa_ped_bot = ped_bot } -> ped_bot
+  BotStrictness                          -> True
+  EtaExpandArity{ am_ped_bot = ped_bot } -> ped_bot
+  FindRhsArity{ am_ped_bot = ped_bot }   -> ped_bot
 
 -- | A version of 'exprIsCheap' that considers results from arity analysis
 -- and optionally the expression's type.
 -- Under 'exprBotStrictness_maybe', no expressions are cheap.
 myExprIsCheap :: ArityEnv -> CoreExpr -> Maybe Type -> Bool
 myExprIsCheap AE{ae_mode = mode} e mb_ty = case mode of
-  BotStrictness                                               -> False
-  ArityAnalysis{aa_dicts_cheap = dicts_cheap, aa_sigs = sigs} ->
-    cheap_dict || exprIsCheapX (myIsCheapApp sigs) e
+  BotStrictness -> False
+  _             -> cheap_dict || cheap_fun e
     where
-      cheap_dict = dicts_cheap && fmap isDictTy mb_ty == Just True
+      cheap_dict = am_dicts_cheap mode && fmap isDictTy mb_ty == Just True
+      cheap_fun e = case mode of
+#if __GLASGOW_HASKELL__ <= 900
+        BotStrictness                -> panic "impossible"
+#endif
+        EtaExpandArity{}             -> exprIsCheap e
+        FindRhsArity{am_sigs = sigs} -> exprIsCheapX (myIsCheapApp sigs) e
 
 -- | A version of 'isCheapApp' that considers results from arity analysis.
+-- See Note [Arity analysis] for what's in the signature environment and why
+-- it's important.
 myIsCheapApp :: IdEnv ArityType -> CheapAppFun
 myIsCheapApp sigs fn n_val_args = case lookupVarEnv sigs fn of
   -- Nothing means not a local function, fall back to regular
@@ -844,20 +885,20 @@ arityType env (App fun arg )
         --      f x y = case x of { (a,b) -> e }
         -- The difference is observable using 'seq'
         --
-arityType env (Case scrut _ _ alts)
+arityType env (Case scrut bndr _ alts)
   | exprIsDeadEnd scrut || null alts
   = botArityType    -- Do not eta expand
                     -- See Note [Dealing with bottom (1)]
-  | otherwise
-  = case alts_type of
-     ABot n  | n>0       -> ATop []       -- Don't eta expand
-             | otherwise -> botArityType  -- if RHS is bottomming
-                                          -- See Note [Dealing with bottom (2)]
-
-     ATop as | not (pedanticBottoms env)  -- See Note [Dealing with bottom (3)]
-             , myExprIsCheap env scrut Nothing -> ATop as
-             | exprOkForSpeculation scrut      -> ATop as
-             | otherwise                       -> ATop (takeWhile isOneShotInfo as)
+  | not (pedanticBottoms env)  -- See Note [Dealing with bottom (2)]
+  , myExprIsCheap env scrut (Just (idType bndr))
+  = alts_type
+  | exprOkForSpeculation scrut
+  = alts_type
+
+  | otherwise               -- In the remaining cases we may not push
+  = case alts_type of       -- evaluation of the scrutinee in
+     ATop as -> ATop (takeWhile isOneShotInfo as)
+     ABot _  -> ATop []
   where
     alts_type = foldr1 andArityType [arityType env rhs | (_,_,rhs) <- alts]
 
@@ -883,12 +924,15 @@ arityType env (Let (Rec pairs) body)
       | otherwise
       = pprPanic "arityType:joinrec" (ppr pairs)
 
-arityType env (Let b e)
-  = floatIn cheap_bind (arityType env e)
+arityType env (Let (NonRec b r) e)
+  = floatIn cheap_rhs (arityType env' e)
+  where
+    cheap_rhs = myExprIsCheap env r (Just (idType b))
+    env'      = extendSigEnv env b (arityType env r)
+
+arityType env (Let (Rec prs) e)
+  = floatIn (all is_cheap prs) (arityType env e)
   where
-    cheap_bind = case b of
-      NonRec b e -> is_cheap (b,e)
-      Rec prs    -> all is_cheap prs
     is_cheap (b,e) = myExprIsCheap env e (Just (idType b))
 
 arityType env (Tick t e)

testsuite/tests/arityanal/Main.hs

-{-# LANGUAGE CPP #-}
-
--- Optimisation problem.  There are two missed opportunities for optimisation in alex_scan_tkn, below.
-
-module Main (main) where
-
-import Data.Char ( ord )
-import Control.Monad.ST
-import Control.Monad (when)
-import Data.STRef
-import GHC.ST
-import Data.Array
-import Data.Char (ord)
-import Data.Array.Base (unsafeAt)
-import GHC.Exts
-alex_base :: AlexAddr
-alex_base = AlexA# "\xf8\xff\xfd\xff\x02\x00\x4c\x00"#
-
-alex_table :: AlexAddr
-alex_table = AlexA# "\x00\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x03\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#
-
-alex_check :: AlexAddr
-alex_check = AlexA# "\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x27\x00\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#
-
-alex_deflt :: AlexAddr
-alex_deflt = AlexA# "\xff\xff\xff\xff\xff\xff\xff\xff"#
-
-alex_accept = listArray (0::Int,3) [[],[],[(AlexAcc 0 (alex_action_0) Nothing Nothing)],[(AlexAcc 1 (alex_action_1) Nothing Nothing)]]
-word (_,_,input) len = return (take len input)
-
-scanner str = runAlex str $ do
-  let loop i = do tok <- alexScan;
-                   if tok == "stopped." || tok == "error."
-                         then return i
-                         else do let i' = i+1 in i' `seq` loop i'
-  loop 0
-
-alexEOF (_,_,"")   = return "stopped."
-alexEOF (_,_,rest) = return "error."
-
-main = do
- s <- getContents
- print (scanner s)
-alex_action_0 = skip
-alex_action_1 = word
--- {-# LINE 1 "GenericTemplate.hs" #-}
---
-------------------------------------------------------------------------
------
--- ALEX TEMPLATE
---
--- (c) Chris Dornan and Simon Marlow 2003
-
---
-------------------------------------------------------------------------
------
--- Token positions
-
--- `Posn' records the location of a token in the input text.  It has three
--- fields: the address (number of chacaters preceding the token), line number
--- and column of a token within the file. `start_pos' gives the position of the
--- start of the file and `eof_pos' a standard encoding for the end of file.
--- `move_pos' calculates the new position after traversing a given character,
--- assuming the usual eight character tab stops.
-
-data AlexPosn = AlexPn !Int !Int !Int
-         deriving (Eq,Show)
-
-alexStartPos :: AlexPosn
-alexStartPos = AlexPn 0 1 1
-
-alexMove :: AlexPosn -> Char -> AlexPosn
-alexMove (AlexPn a l c) '\t' = AlexPn (a+1)  l     (((c+7) `div` 8)*8+1)
-alexMove (AlexPn a l c) '\n' = AlexPn (a+1) (l+1)   1
-alexMove (AlexPn a l c) _    = AlexPn (a+1)  l     (c+1)
-
---
-------------------------------------------------------------------------
------
--- The Alex monad
---
--- Compile with -funbox-strict-fields for best results!
-
-data AlexState s = AlexState {
-         alex_pos :: !(STRef s AlexPosn),-- position at current input location
-         alex_inp :: !(STRef s String),  -- the current input
-         alex_chr :: !(STRef s Char),    -- the character before the input
-         alex_scd :: !(STRef s Int)      -- the current startcode
-    }
-
-type AlexInput = (AlexPosn,Char,String)
-
-alexInputPrevChar :: AlexInput -> Char
-alexInputPrevChar (p,c,s) = c
-
-runAlex :: String -> Alex a -> a
-runAlex input (Alex f)
-   = runST (do
-       inp_r <- newSTRef input
-       chr_r <- newSTRef '\n'
-       pos_r <- newSTRef alexStartPos
-       scd_r <- newSTRef 0
-       f (AlexState {alex_pos = pos_r,
-                      alex_inp = inp_r,
-                      alex_chr = chr_r,
-                      alex_scd = scd_r}))
-
---TODO include error support
-newtype Alex a = Alex { unAlex :: forall s. AlexState s -> ST s a }
-
-instance Monad Alex where
-  (Alex m) >>= k  = Alex (\s -> m s >>= \a -> unAlex (k a) s)
-  return a = Alex (\s -> return a)
-
-alexGetChar :: Alex (Maybe Char)
-alexGetChar = Alex (\st@AlexState{ alex_inp=inp_r,
-                                     alex_chr=chr_r,
-                                     alex_pos=pos_r } -> do
-  inp <- readSTRef inp_r
-  pos <- readSTRef pos_r
-  case inp of
-     []    -> return Nothing
-     (c:s) -> do  writeSTRef inp_r s
-                  writeSTRef chr_r c
-                  let p' = alexMove pos c
-                  p' `seq` writeSTRef pos_r p'
-                  return (Just c)
-  )
-
-alexGetInput :: Alex AlexInput
-alexGetInput
- = Alex (\s@AlexState{alex_pos=pos_r,alex_chr=chr_r,alex_inp=inp_r} -> do
-     inp <- readSTRef inp_r
-     chr <- readSTRef chr_r
-     pos <- readSTRef pos_r
-     return (pos,chr,inp)
- )
-
-alexSetInput :: AlexInput -> Alex ()
-alexSetInput (pos,chr,inp)
- = Alex (\s@AlexState{alex_pos=pos_r,alex_chr=chr_r,alex_inp=inp_r} -> do
-    writeSTRef inp_r inp
-    writeSTRef pos_r pos
-    writeSTRef chr_r chr
-  )
-
-alexGetStartCode :: Alex Int
-alexGetStartCode = Alex (\s@AlexState{alex_scd=scd_r} -> do
-  readSTRef scd_r)
-
-alexSetStartCode :: Int -> Alex ()
-alexSetStartCode sc = Alex (\s@AlexState{alex_scd=scd_r} -> do
-  writeSTRef scd_r sc)
-
---
------------------------------------------------------------------------------
--- Useful token actions
-
-
--- just ignore this token and scan another one
-skip input len = alexScan
-
--- ignore this token, but set the start code to a new value
-begin code input len = do alexSetStartCode code; alexScan
-
--- perform an action for this token, and set the start code to a new value
-(token `andBegin` code) input len = do alexSetStartCode code; token input len
-
---
------------------------------------------------------------------------------
--- INTERNALS and main scanner engine
-
--- {-# LINE 144 "GenericTemplate.hs" #-}
-
-data AlexAddr = AlexA# Addr#
-
-{-# INLINE alexIndexShortOffAddr #-}
-alexIndexShortOffAddr (AlexA# arr) off =
-         narrow16Int# i
-  where
-         i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)
-         high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
-         low  = int2Word# (ord# (indexCharOffAddr# arr off'))
-         off' = off *# 2#
-
-
---
------------------------------------------------------------------------------
--- Main lexing routines
-
-
-
--- alexScan :: some a . Alex a
-alexScan = do
-  (I# (startcode)) <- alexGetStartCode  -- the startcode is the initial state
-  cur_input <- alexGetInput
-  let c = alexInputPrevChar cur_input
-  c `seq` do
-  r <- alex_scan_tkn c 0# startcode AlexNone
-  case r of
-    AlexNone ->
-
-
-
-         alexEOF cur_input
-    AlexLastAcc k input len -> do
-
-
-
-         alexSetInput input
-         k cur_input len
-
--- {-# LINE 221 "GenericTemplate.hs" #-}
-
-
--- Push the input through the DFA, remembering the most recent accepting
--- state it encountered.
-
-alex_scan_tkn lc len (-1#) last_acc = return last_acc
-alex_scan_tkn lc len s last_acc = do
-  new_acc <- check_accs s lc len last_acc  --danaxu extends arguments
-  c <- alexGetChar
-  let {-# INLINE [0] join #-}
-      -- This is a *hack*, the compiler doesn't eliminate the Maybe return
-      -- from alexGetChar unless we extract this join point and inline
-      -- it later.
-      join c' =
-
-
-
-         alex_scan_tkn lc
-                 (len +# 1#) s' new_acc
-         where
-                 base   = alexIndexShortOffAddr alex_base s
-                 (I# (ord_c)) = ord c'
-                 offset = (base +# ord_c)
-                 check  = alexIndexShortOffAddr alex_check offset
-
-                 s' =
-                      if (offset >=# 0#) && (check ==# ord_c)
-                         then alexIndexShortOffAddr alex_table offset
-                         else alexIndexShortOffAddr alex_deflt s
-  case c of
-    Nothing -> return new_acc    -- end of input
-    Just c' -> join c'
-   -- where
-         -- OPTIMISATION PROBLEM.  We need to eta-expand
-         -- check_accs and check_accs1.  This needs a simple
-        -- one-shot analysis of some kind, but note that
-        -- check_accs1 is recursive.
-check_accs s lc len last_acc = check_accs1 (alex_accept `unsafeAt` (I# (s))) lc len last_acc
-check_accs1 accs lc len last_acc =
-           case accs of
-                 [] -> return last_acc
-                 (AlexAcc _ a lctx rctx : rest) ->
-
-                   case lctx of
-                     Nothing  -> check_rctx a rctx rest lc len last_acc
-                     Just arr | arr!lc    -> check_rctx a rctx rest lc len last_acc
-                              | otherwise -> check_accs1 rest lc len last_acc
-                    -- where
-
-ok a len = do inp <- alexGetInput
-              return (AlexLastAcc a inp (I# (len)))
-
-check_rctx a rctx rest lc len last_acc =
-                         case rctx of
-                            Nothing -> ok a len
-                            Just (I# (sn)) -> do
-                               inp <- alexGetInput
-                               let c = alexInputPrevChar inp
-                               c `seq` do
-                               acc <- alex_scan_tkn c 0# sn AlexNone
-                               alexSetInput inp
-                               case acc of
-                                 AlexNone      -> check_accs1 rest lc len last_acc
-                                 AlexLastAcc{} -> ok a len
-                                 -- TODO: there's no need to find the longest
-                                 -- match when checking the right context, just
-                                 -- the first match will do.
-
-data AlexLastAcc a = AlexNone | AlexLastAcc a !AlexInput !Int
-
-data AlexAcc a = AlexAcc Int a (Maybe (Array Char Bool)) (Maybe Int)

testsuite/tests/arityanal/Makefile

+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk

testsuite/tests/arityanal/f0.stderr

-
-==================== IdInfo ====================
-lvl_s1yb :: GHC.Base.Int :: [*
-			     Str: DmdType m]
-F0.f0 :: GHC.Base.Int
-	 -> GHC.Base.Int
-	 -> GHC.Base.Int
-	 -> GHC.Base.Int :: [Arity 3
-			     0 -> 0 -> 0 -> *
-			     Str: DmdType U(L)LLm]
-
-

testsuite/tests/arityanal/f1.stderr

-***Arity is changed: h1{v a19i} 3 2
-
-==================== IdInfo ====================
-lvl_s1AI :: GHC.Num.Integer -> GHC.Num.Integer :: [Arity 1
-						   0 -> *
-						   Str: DmdType S]
-lit_a1hu :: GHC.Num.Integer :: [*
-				Str: DmdType]
-lit_a1ho :: GHC.Num.Integer :: [*
-				Str: DmdType]
-h1_a19i :: GHC.Num.Integer
-	   -> GHC.Num.Integer
-	   -> GHC.Num.Integer
-	   -> GHC.Num.Integer :: [Arity 2
-				  0 -> 0 -> 0 -> *
-				  Str: DmdType SS]
-F1.f1 :: GHC.Num.Integer :: [*
-			     Str: DmdType]
-
-

testsuite/tests/arityanal/f10.stderr

-***Arity is changed as occur many times: F10.f10f{v r155} 2 1
-
-==================== IdInfo ====================
-lit_s1Ll :: GHC.Num.Integer :: [*
-				Str: DmdType]
-lit_s1Lj :: GHC.Num.Integer :: [*
-				Str: DmdType]
-lit_s1Lh :: GHC.Num.Integer :: [*
-				Str: DmdType]
-F10.f10g :: GHC.Num.Integer -> GHC.Num.Integer -> GHC.Num.Integer :: [Arity 2
-								      *
-								      Str: DmdType SS]
-F10.f10f :: forall a_a1fu.
-	    (GHC.Num.Integer -> GHC.Num.Integer -> a_a1fu)
-	    -> (a_a1fu, GHC.Num.Integer -> a_a1fu) :: [Arity 1
-						       1 -> *
-						       Str: DmdType Lm]
-F10.f10h :: (GHC.Num.Integer, GHC.Num.Integer -> GHC.Num.Integer) :: [*
-								      Str: DmdType]
-F10.f10x1 :: GHC.Num.Integer :: [*
-				 Str: DmdType]
-F10.f10x2 :: GHC.Num.Integer -> GHC.Num.Integer :: [*
-						    Str: DmdType]
-F10.f10 :: GHC.Num.Integer :: [*
-			       Str: DmdType]
-
-

testsuite/tests/arityanal/f11.stderr

-***expensive e1 0
-***expensive e1 0
-***expensive e1 0
-***expensive e1 0
-***expensive e1 0
-
-==================== IdInfo ====================
-lvl_s1Fz :: GHC.Num.Integer :: [*
-				Str: DmdType]
-lvl_s1Fv :: GHC.Num.Integer :: [*
-				Str: DmdType]
-lvl_s1Fu :: GHC.Num.Integer :: [*
-				Str: DmdType]
-fib_s1Fj :: GHC.Num.Integer -> GHC.Num.Integer :: [Arity 1
-						   0 -> *
-						   Str: DmdType S]
-lvl_s1IP :: GHC.Num.Integer :: [*]
-x_s1Fr :: GHC.Num.Integer :: [*
-			      Str: DmdType]
-lvl_s1IQ :: GHC.Num.Integer :: [*]
-a_s1rF :: GHC.Num.Integer :: [*
-			      Str: DmdType]
-lvl_s1IR :: GHC.Num.Integer :: [*]
-a_s1rE :: GHC.Num.Integer :: [*
-			      Str: DmdType]
-F11.f11 :: (GHC.Num.Integer, GHC.Num.Integer) :: [*
-						  Str: DmdType m]
-F11.f11f :: forall t_a1gd.
-	    t_a1gd -> GHC.Num.Integer -> GHC.Num.Integer :: [Arity 2
-							     T
-							     Str: DmdType AS]
-F11.fib :: forall a_a19x a_a1eN.
-	   (GHC.Num.Num a_a1eN, GHC.Num.Num a_a19x) =>
-	   a_a19x -> a_a1eN :: [Arity 2
-				0 -> 0 -> 0 -> *
-				Str: DmdType LL
-				RULES: "SPEC F11.fib" __forall {$dNum_X1Fo :: {GHC.Num.Num GHC.Num.Integer}
-								$dNum_X1Fq :: {GHC.Num.Num GHC.Num.Integer}}
-							F11.fib @ GHC.Num.Integer
-								@ GHC.Num.Integer
-								$dNum_X1Fo
-								$dNum_X1Fq
-							= fib_s1Fj ;]
-
-

testsuite/tests/arityanal/f12.stderr

-
-==================== IdInfo ====================
-lvl_s1Bx :: GHC.Num.Integer :: [*]
-lvl_s1By :: GHC.Num.Integer :: [*]
-F12.f12 :: GHC.Num.Integer :: [*
-			       Str: DmdType]
-
-

testsuite/tests/arityanal/f13.stderr

-***expensive e1 0
-
-==================== IdInfo ====================
-lvl_s1AR :: GHC.Num.Integer :: [*
-				Str: DmdType]
-lvl_s1AQ :: GHC.Num.Integer :: [*
-				Str: DmdType]
-F13.f13 :: forall a_a19A a_a1gc.
-	   (GHC.Num.Num a_a19A,
-	    GHC.Base.Ord a_a19A,
-	    GHC.Num.Num a_a1gc,
-	    GHC.Num.Num (a_a19A -> a_a1gc -> a_a1gc)) =>
-	   a_a19A -> a_a1gc -> a_a1gc -> a_a1gc :: [Arity 6
-						    0 -> 0 -> 0 -> 0 -> 0 -> 0 -> 0 -> *
-						    Str: DmdType LLLLLL]
-
-

testsuite/tests/arityanal/f14.stderr

-***expensive e1 0
-***Arity is changed as occur many times: F14.f14{v r16A} 4 0
-
-==================== IdInfo ====================
-lvl_s1zz :: forall a_a19p. a_a19p -> a_a19p :: [Arity 1
-						0 -> *
-						Str: DmdType S]
-lvl_s1zy :: GHC.Num.Integer :: [*
-				Str: DmdType]
-$wf14_s1Ak :: forall a_a19p.
-	      (a_a19p -> a_a19p -> GHC.Base.Bool)
-	      -> {GHC.Num.Num a_a19p}
-	      -> a_a19p
-	      -> a_a19p
-	      -> a_a19p
-	      -> a_a19p :: [Arity 4
-			    2 -> 0 -> 0 -> 0 -> 0 -> *
-			    Str: DmdType C(C(S))LLL]
-F14.f14 :: forall a_a19p.
-	   (GHC.Base.Ord a_a19p, GHC.Num.Num a_a19p) =>
-	   a_a19p -> a_a19p -> a_a19p -> a_a19p :: [Arity 4
-						    T
-						    Worker $wf14_s1Ak
-						    Str: DmdType U(AAC(C(S))AAAAA)LLL]
-
-

testsuite/tests/arityanal/f15.stderr

-
-==================== IdInfo ====================
-lit_s1zs :: GHC.Num.Integer :: [*
-				Str: DmdType]
-F15.f15f :: forall t_a1fm. (GHC.Num.Integer -> t_a1fm) -> t_a1fm :: [Arity 1
-								     1 -> *
-								     Str: DmdType C(S)]
-F15.f15g :: GHC.Num.Integer -> GHC.Num.Integer :: [Arity 1
-						   0 -> *
-						   Str: DmdType S]
-F15.f15 :: GHC.Num.Integer :: [*
-			       Str: DmdType]
-
-

testsuite/tests/arityanal/f2.stderr

-
-==================== IdInfo ====================
-lit_s1Bh :: GHC.Num.Integer :: [*
-				Str: DmdType]
-F2.f2f :: forall t_a19s t_a19u.
-	  (t_a19u -> GHC.Num.Integer -> t_a19s) -> t_a19u -> t_a19s :: [Arity 2
-									2 -> 0 -> *
-									Str: DmdType C(C(S))L]
-lit_a1i8 :: GHC.Num.Integer :: [*
-				Str: DmdType]
-g_a1fp :: GHC.Num.Integer -> GHC.Num.Integer -> GHC.Num.Integer :: [Arity 2
-								    0 -> 0 -> *
-								    Str: DmdType SS]
-lvl_s1DV :: GHC.Num.Integer :: [*]
-F2.f2 :: GHC.Num.Integer :: [*
-			     Str: DmdType]
-
-

testsuite/tests/arityanal/f3.stderr

-***Arity is changed as occur many times: F3.f3{v r157} 1 0
-
-==================== IdInfo ====================
-$wfac_s1Bz :: GHC.Prim.Int# -> GHC.Prim.Int# :: [Arity 1
-						 0 -> *
-						 Str: DmdType L]
-F3.fac :: GHC.Base.Int -> GHC.Base.Int :: [Arity 1
-					   T
-					   Worker $wfac_s1Bz
-					   Str: DmdType U(L)m]
-F3.f3 :: GHC.Base.Int -> GHC.Base.Int :: [Arity 1
-					  T
-					  Str: DmdType U(L)m]
-
-

testsuite/tests/arityanal/f4.stderr

-***Arity is changed as occur many times: F4.f4h{v r155} 2 0
-
-==================== IdInfo ====================
-F4.f4g :: GHC.Base.Int -> GHC.Base.Int :: [Arity 1
-					   0 -> *
-					   Str: DmdType U(L)m]
-lvl_s1Cq :: GHC.Base.Int :: [*]
-$wf4h_s1C9 :: (GHC.Base.Int -> GHC.Base.Int)
-	      -> GHC.Prim.Int#
-	      -> GHC.Base.Int :: [Arity 2
-				  0 -> 0 -> *
-				  Str: DmdType C(S)L]
-F4.f4h :: (GHC.Base.Int -> GHC.Base.Int)
-	  -> GHC.Base.Int
-	  -> GHC.Base.Int :: [Arity 2
-			      T
-			      Worker $wf4h_s1C9
-			      Str: DmdType C(S)U(L)]
-F4.f4 :: GHC.Base.Int :: [*
-			  Str: DmdType]
-
-

testsuite/tests/arityanal/f5.stderr

-
-==================== IdInfo ====================
-lvl_s1B7 :: GHC.Num.Integer :: [*
-				Str: DmdType]
-$sf5h_s1B2 :: forall t_a1gj.
-	      (t_a1gj -> GHC.Num.Integer)
-	      -> t_a1gj
-	      -> (t_a1gj -> GHC.Num.Integer)
-	      -> GHC.Num.Integer :: [Arity 3
-				     1 -> 0 -> 1 -> *
-				     Str: DmdType C(S)LC(S)]
-$sf5g_s1B1 :: forall t_a1fy.
-	      (t_a1fy -> GHC.Num.Integer) -> t_a1fy -> GHC.Num.Integer :: [Arity 2
-									   1 -> 0 -> *
-									   Str: DmdType C(S)L]
-eta_s1or :: GHC.Num.Integer :: [*
-				Str: DmdType]
-F5.f5h :: forall a_a1gd t_a1gj.
-	  (GHC.Num.Num a_a1gd) =>
-	  (t_a1gj -> a_a1gd) -> t_a1gj -> (t_a1gj -> a_a1gd) -> a_a1gd :: [Arity 4
-									   0 -> 1 -> 0 -> 1 -> *
-									   Str: DmdType U(AAC(C(S))AAAAAL)LLL
-									   RULES: "SPEC F5.f5h" __forall {@ t_a1gj
-													  $dNum_X1Bl :: {GHC.Num.Num GHC.Num.Integer}}
-												  F5.f5h @ GHC.Num.Integer
-													 @ t_a1gj
-													 $dNum_X1Bl
-												  = $sf5h_s1B2
-												      @ t_a1gj ;]
-F5.f5g :: forall t_a1fy a_a1fB.
-	  (GHC.Num.Num a_a1fB) =>
-	  (t_a1fy -> a_a1fB) -> t_a1fy -> a_a1fB :: [Arity 3
-						     0 -> 1 -> 0 -> *
-						     Str: DmdType U(AAC(C(S))AAAAAL)LL
-						     RULES: "SPEC F5.f5g" __forall {@ t_a1fy
-										    $dNum_X1Bk :: {GHC.Num.Num GHC.Num.Integer}}
-									    F5.f5g @ t_a1fy @ GHC.Num.Integer $dNum_X1Bk
-									    = $sf5g_s1B1 @ t_a1fy ;]
-F5.f5y :: GHC.Num.Integer -> GHC.Num.Integer :: [Arity 1
-						 0 -> *
-						 Str: DmdType S]
-lvl_s1DK :: GHC.Num.Integer :: [*]
-lvl_s1DL :: GHC.Num.Integer :: [*]
-F5.f5 :: GHC.Num.Integer :: [*
-			     Str: DmdType]
-
-

testsuite/tests/arityanal/f6.stderr

-
-==================== IdInfo ====================
-lit_s1zR :: GHC.Num.Integer :: [*
-				Str: DmdType]
-lvl_s1C2 :: GHC.Num.Integer :: [*]
-F6.f6 :: GHC.Num.Integer :: [*
-			     Str: DmdType]
-F6.f6t :: GHC.Num.Integer -> GHC.Num.Integer -> GHC.Num.Integer :: [Arity 2
-								    *
-								    Str: DmdType SS]
-F6.f6f :: forall t_a1fp t_a1fr.
-	  (t_a1fr -> GHC.Num.Integer -> t_a1fp) -> t_a1fr -> t_a1fp :: [Arity 2
-									2 -> 0 -> *
-									Str: DmdType C(C(S))L]
-
-

testsuite/tests/arityanal/f7.stderr

-
-==================== IdInfo ====================
-lvl_s1BI :: GHC.Num.Integer :: [*]
-lvl_s1BJ :: GHC.Num.Integer :: [*]
-F7.f7 :: GHC.Num.Integer :: [*
-			     Str: DmdType]
-F7.f7g :: GHC.Num.Integer -> GHC.Num.Integer -> GHC.Num.Integer :: [Arity 2
-								    *
-								    Str: DmdType SS]
-F7.f7f :: forall t_a1fh. t_a1fh -> t_a1fh :: [Arity 1
-					      0 -> *
-					      Str: DmdType S]
-
-

testsuite/tests/arityanal/f8.stderr

-
-==================== IdInfo ====================
-$sf8f_s1zR :: GHC.Base.Bool
-	      -> GHC.Num.Integer
-	      -> GHC.Num.Integer
-	      -> GHC.Num.Integer :: [Arity 3
-				     0 -> 0 -> 0 -> *
-				     Str: DmdType SLS]
-F8.f8 :: GHC.Num.Integer :: [*
-			     Str: DmdType]
-F8.f8f :: forall a_a1ex.
-	  (GHC.Num.Num a_a1ex) =>
-	  GHC.Base.Bool -> a_a1ex -> a_a1ex -> a_a1ex :: [Arity 4
-							  0 -> 0 -> 0 -> 0 -> *
-							  Str: DmdType LSLL
-							  RULES: "SPEC F8.f8f" __forall {$dNum_X1zY :: {GHC.Num.Num GHC.Num.Integer}}
-										 F8.f8f @ GHC.Num.Integer $dNum_X1zY
-										 = $sf8f_s1zR ;]
-
-

testsuite/tests/arityanal/f9.stderr

-
-==================== IdInfo ====================
-lit_a1hg :: GHC.Num.Integer :: [*
-				Str: DmdType]
-lit_a1he :: GHC.Num.Integer :: [*
-				Str: DmdType]
-lit_a1h9 :: GHC.Num.Integer :: [*
-				Str: DmdType]
-f_a19b :: GHC.Num.Integer -> GHC.Num.Integer :: [Arity 1
-						 0 -> *
-						 Str: DmdType S]
-F9.f91 :: GHC.Num.Integer :: [*
-			      Str: DmdType]
-
-