<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html>
<head>
<!-- Generated by HsColour, http://www.cs.york.ac.uk/fp/darcs/hscolour/ -->
<title>specialise/SpecConstr.lhs</title>
<link type='text/css' rel='stylesheet' href='hscolour.css' />
</head>
<body>
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[SpecConstr]{Specialise over constructors}
\begin{code}
<pre><a name="line-1"></a><span class='hs-comment'>-- The above warning supression flag is a temporary kludge.</span>
<a name="line-2"></a><span class='hs-comment'>-- While working on this module you are encouraged to remove it and fix</span>
<a name="line-3"></a><span class='hs-comment'>-- any warnings in the module. See</span>
<a name="line-4"></a><span class='hs-comment'>-- <a href="http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings">http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings</a></span>
<a name="line-5"></a><span class='hs-comment'>-- for details</span>
<a name="line-6"></a>
<a name="line-7"></a><span class='hs-keyword'>module</span> <span class='hs-conid'>SpecConstr</span><span class='hs-layout'>(</span>
<a name="line-8"></a> <span class='hs-varid'>specConstrProgram</span>
<a name="line-9"></a> <span class='hs-layout'>)</span> <span class='hs-keyword'>where</span>
<a name="line-10"></a>
<a name="line-11"></a><span class='hs-cpp'>#include "HsVersions.h"</span>
<a name="line-12"></a>
<a name="line-13"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>CoreSyn</span>
<a name="line-14"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>CoreSubst</span>
<a name="line-15"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>CoreUtils</span>
<a name="line-16"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>CoreUnfold</span> <span class='hs-layout'>(</span> <span class='hs-varid'>couldBeSmallEnoughToInline</span> <span class='hs-layout'>)</span>
<a name="line-17"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>CoreFVs</span> <span class='hs-layout'>(</span> <span class='hs-varid'>exprsFreeVars</span> <span class='hs-layout'>)</span>
<a name="line-18"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>WwLib</span> <span class='hs-layout'>(</span> <span class='hs-varid'>mkWorkerArgs</span> <span class='hs-layout'>)</span>
<a name="line-19"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>DataCon</span> <span class='hs-layout'>(</span> <span class='hs-varid'>dataConRepArity</span><span class='hs-layout'>,</span> <span class='hs-varid'>dataConUnivTyVars</span> <span class='hs-layout'>)</span>
<a name="line-20"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Coercion</span>
<a name="line-21"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Rules</span>
<a name="line-22"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Type</span> <span class='hs-varid'>hiding</span><span class='hs-layout'>(</span> <span class='hs-varid'>substTy</span> <span class='hs-layout'>)</span>
<a name="line-23"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Id</span>
<a name="line-24"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>MkId</span> <span class='hs-layout'>(</span> <span class='hs-varid'>mkImpossibleExpr</span> <span class='hs-layout'>)</span>
<a name="line-25"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Var</span>
<a name="line-26"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>VarEnv</span>
<a name="line-27"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>VarSet</span>
<a name="line-28"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Name</span>
<a name="line-29"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>DynFlags</span> <span class='hs-layout'>(</span> <span class='hs-conid'>DynFlags</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>..</span><span class='hs-layout'>)</span> <span class='hs-layout'>)</span>
<a name="line-30"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>StaticFlags</span> <span class='hs-layout'>(</span> <span class='hs-varid'>opt_PprStyle_Debug</span> <span class='hs-layout'>)</span>
<a name="line-31"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>StaticFlags</span> <span class='hs-layout'>(</span> <span class='hs-varid'>opt_SpecInlineJoinPoints</span> <span class='hs-layout'>)</span>
<a name="line-32"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>BasicTypes</span> <span class='hs-layout'>(</span> <span class='hs-conid'>Activation</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>..</span><span class='hs-layout'>)</span> <span class='hs-layout'>)</span>
<a name="line-33"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Maybes</span> <span class='hs-layout'>(</span> <span class='hs-varid'>orElse</span><span class='hs-layout'>,</span> <span class='hs-varid'>catMaybes</span><span class='hs-layout'>,</span> <span class='hs-varid'>isJust</span><span class='hs-layout'>,</span> <span class='hs-varid'>isNothing</span> <span class='hs-layout'>)</span>
<a name="line-34"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>NewDemand</span>
<a name="line-35"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>DmdAnal</span> <span class='hs-layout'>(</span> <span class='hs-varid'>both</span> <span class='hs-layout'>)</span>
<a name="line-36"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Util</span>
<a name="line-37"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>UniqSupply</span>
<a name="line-38"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Outputable</span>
<a name="line-39"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>FastString</span>
<a name="line-40"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>UniqFM</span>
<a name="line-41"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>MonadUtils</span>
<a name="line-42"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span> <span class='hs-layout'>(</span> <span class='hs-varid'>zipWithM</span> <span class='hs-layout'>)</span>
<a name="line-43"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>List</span>
</pre>\end{code}
-----------------------------------------------------
Game plan
-----------------------------------------------------
Consider
drop n [] = []
drop 0 xs = []
drop n (x:xs) = drop (n-1) xs
After the first time round, we could pass n unboxed. This happens in
numerical code too. Here's what it looks like in Core:
drop n xs = case xs of
[] -> []
(y:ys) -> case n of
I# n# -> case n# of
0 -> []
_ -> drop (I# (n# -# 1#)) xs
Notice that the recursive call has an explicit constructor as argument.
Noticing this, we can make a specialised version of drop
RULE: drop (I# n#) xs ==> drop' n# xs
drop' n# xs = let n = I# n# in ...orig RHS...
Now the simplifier will apply the specialisation in the rhs of drop', giving
drop' n# xs = case xs of
[] -> []
(y:ys) -> case n# of
0 -> []
_ -> drop (n# -# 1#) xs
Much better!
We'd also like to catch cases where a parameter is carried along unchanged,
but evaluated each time round the loop:
f i n = if i>0 || i>n then i else f (i*2) n
Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.
In Core, by the time we've w/wd (f is strict in i) we get
f i# n = case i# ># 0 of
False -> I# i#
True -> case n of n' { I# n# ->
case i# ># n# of
False -> I# i#
True -> f (i# *# 2#) n'
At the call to f, we see that the argument, n is know to be (I# n#),
and n is evaluated elsewhere in the body of f, so we can play the same
trick as above.
Note [Reboxing]
~~~~~~~~~~~~~~~
We must be careful not to allocate the same constructor twice. Consider
f p = (...(case p of (a,b) -> e)...p...,
...let t = (r,s) in ...t...(f t)...)
At the recursive call to f, we can see that t is a pair. But we do NOT want
to make a specialised copy:
f' a b = let p = (a,b) in (..., ...)
because now t is allocated by the caller, then r and s are passed to the
recursive call, which allocates the (r,s) pair again.
This happens if
(a) the argument p is used in other than a case-scrutinsation way.
(b) the argument to the call is not a 'fresh' tuple; you have to
look into its unfolding to see that it's a tuple
Hence the "OR" part of Note [Good arguments] below.
ALTERNATIVE 2: pass both boxed and unboxed versions. This no longer saves
allocation, but does perhaps save evals. In the RULE we'd have
something like
f (I# x#) = f' (I# x#) x#
If at the call site the (I# x) was an unfolding, then we'd have to
rely on CSE to eliminate the duplicate allocation.... This alternative
doesn't look attractive enough to pursue.
ALTERNATIVE 3: ignore the reboxing problem. The trouble is that
the conservative reboxing story prevents many useful functions from being
specialised. Example:
foo :: Maybe Int -> Int -> Int
foo (Just m) 0 = 0
foo x@(Just m) n = foo x (n-m)
Here the use of 'x' will clearly not require boxing in the specialised function.
The strictness analyser has the same problem, in fact. Example:
f p@(a,b) = ...
If we pass just 'a' and 'b' to the worker, it might need to rebox the
pair to create (a,b). A more sophisticated analysis might figure out
precisely the cases in which this could happen, but the strictness
analyser does no such analysis; it just passes 'a' and 'b', and hopes
for the best.
So my current choice is to make SpecConstr similarly aggressive, and
ignore the bad potential of reboxing.
Note [Good arguments]
~~~~~~~~~~~~~~~~~~~~~
So we look for
* A self-recursive function. Ignore mutual recursion for now,
because it's less common, and the code is simpler for self-recursion.
* EITHER
a) At a recursive call, one or more parameters is an explicit
constructor application
AND
That same parameter is scrutinised by a case somewhere in
the RHS of the function
OR
b) At a recursive call, one or more parameters has an unfolding
that is an explicit constructor application
AND
That same parameter is scrutinised by a case somewhere in
the RHS of the function
AND
Those are the only uses of the parameter (see Note [Reboxing])
What to abstract over
~~~~~~~~~~~~~~~~~~~~~
There's a bit of a complication with type arguments. If the call
site looks like
f p = ...f ((:) [a] x xs)...
then our specialised function look like
f_spec x xs = let p = (:) [a] x xs in ....as before....
This only makes sense if either
a) the type variable 'a' is in scope at the top of f, or
b) the type variable 'a' is an argument to f (and hence fs)
Actually, (a) may hold for value arguments too, in which case
we may not want to pass them. Supose 'x' is in scope at f's
defn, but xs is not. Then we'd like
f_spec xs = let p = (:) [a] x xs in ....as before....
Similarly (b) may hold too. If x is already an argument at the
call, no need to pass it again.
Finally, if 'a' is not in scope at the call site, we could abstract
it as we do the term variables:
f_spec a x xs = let p = (:) [a] x xs in ...as before...
So the grand plan is:
* abstract the call site to a constructor-only pattern
e.g. C x (D (f p) (g q)) ==> C s1 (D s2 s3)
* Find the free variables of the abstracted pattern
* Pass these variables, less any that are in scope at
the fn defn. But see Note [Shadowing] below.
NOTICE that we only abstract over variables that are not in scope,
so we're in no danger of shadowing variables used in "higher up"
in f_spec's RHS.
Note [Shadowing]
~~~~~~~~~~~~~~~~
In this pass we gather up usage information that may mention variables
that are bound between the usage site and the definition site; or (more
seriously) may be bound to something different at the definition site.
For example:
f x = letrec g y v = let x = ...
in ...(g (a,b) x)...
Since 'x' is in scope at the call site, we may make a rewrite rule that
looks like
RULE forall a,b. g (a,b) x = ...
But this rule will never match, because it's really a different 'x' at
the call site -- and that difference will be manifest by the time the
simplifier gets to it. [A worry: the simplifier doesn't *guarantee*
no-shadowing, so perhaps it may not be distinct?]
Anyway, the rule isn't actually wrong, it's just not useful. One possibility
is to run deShadowBinds before running SpecConstr, but instead we run the
simplifier. That gives the simplest possible program for SpecConstr to
chew on; and it virtually guarantees no shadowing.
Note [Specialising for constant parameters]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This one is about specialising on a *constant* (but not necessarily
constructor) argument
foo :: Int -> (Int -> Int) -> Int
foo 0 f = 0
foo m f = foo (f m) (+1)
It produces
lvl_rmV :: GHC.Base.Int -> GHC.Base.Int
lvl_rmV =
\ (ds_dlk :: GHC.Base.Int) ->
case ds_dlk of wild_alH { GHC.Base.I# x_alG ->
GHC.Base.I# (GHC.Prim.+# x_alG 1)
T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
GHC.Prim.Int#
T.$wfoo =
\ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->
case ww_sme of ds_Xlw {
__DEFAULT ->
case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->
T.$wfoo ww1_Xmz lvl_rmV
};
0 -> 0
}
The recursive call has lvl_rmV as its argument, so we could create a specialised copy
with that argument baked in; that is, not passed at all. Now it can perhaps be inlined.
When is this worth it? Call the constant 'lvl'
- If 'lvl' has an unfolding that is a constructor, see if the corresponding
parameter is scrutinised anywhere in the body.
- If 'lvl' has an unfolding that is a inlinable function, see if the corresponding
parameter is applied (...to enough arguments...?)
Also do this is if the function has RULES?
Also
Note [Specialising for lambda parameters]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
foo :: Int -> (Int -> Int) -> Int
foo 0 f = 0
foo m f = foo (f m) (\n -> n-m)
This is subtly different from the previous one in that we get an
explicit lambda as the argument:
T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
GHC.Prim.Int#
T.$wfoo =
\ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->
case ww_sm8 of ds_Xlr {
__DEFAULT ->
case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->
T.$wfoo
ww1_Xmq
(\ (n_ad3 :: GHC.Base.Int) ->
case n_ad3 of wild_alB { GHC.Base.I# x_alA ->
GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)
})
};
0 -> 0
}
I wonder if SpecConstr couldn't be extended to handle this? After all,
lambda is a sort of constructor for functions and perhaps it already
has most of the necessary machinery?
Furthermore, there's an immediate win, because you don't need to allocate the lamda
at the call site; and if perchance it's called in the recursive call, then you
may avoid allocating it altogether. Just like for constructors.
Looks cool, but probably rare...but it might be easy to implement.
Note [SpecConstr for casts]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
data family T a :: *
data instance T Int = T Int
foo n = ...
where
go (T 0) = 0
go (T n) = go (T (n-1))
The recursive call ends up looking like
go (T (I# ...) `cast` g)
So we want to spot the construtor application inside the cast.
That's why we have the Cast case in argToPat
Note [Local recursive groups]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For a *local* recursive group, we can see all the calls to the
function, so we seed the specialisation loop from the calls in the
body, not from the calls in the RHS. Consider:
bar m n = foo n (n,n) (n,n) (n,n) (n,n)
where
foo n p q r s
| n == 0 = m
| n > 3000 = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s }
| n > 2000 = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s }
| n > 1000 = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s }
| otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) }
If we start with the RHSs of 'foo', we get lots and lots of specialisations,
most of which are not needed. But if we start with the (single) call
in the rhs of 'bar' we get exactly one fully-specialised copy, and all
the recursive calls go to this fully-specialised copy. Indeed, the original
function is later collected as dead code. This is very important in
specialising the loops arising from stream fusion, for example in NDP where
we were getting literally hundreds of (mostly unused) specialisations of
a local function.
Note [Do not specialise diverging functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Specialising a function that just diverges is a waste of code.
Furthermore, it broke GHC (simpl014) thus:
{-# STR Sb #-}
f = \x. case x of (a,b) -> f x
If we specialise f we get
f = \x. case x of (a,b) -> fspec a b
But fspec doesn't have decent strictnes info. As it happened,
(f x) :: IO t, so the state hack applied and we eta expanded fspec,
and hence f. But now f's strictness is less than its arity, which
breaks an invariant.
-----------------------------------------------------
Stuff not yet handled
-----------------------------------------------------
Here are notes arising from Roman's work that I don't want to lose.
Example 1
~~~~~~~~~
data T a = T !a
foo :: Int -> T Int -> Int
foo 0 t = 0
foo x t | even x = case t of { T n -> foo (x-n) t }
| otherwise = foo (x-1) t
SpecConstr does no specialisation, because the second recursive call
looks like a boxed use of the argument. A pity.
$wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
$wfoo_sFw =
\ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
case ww_sFo of ds_Xw6 [Just L] {
__DEFAULT ->
case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
__DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
0 ->
case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
$wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
} } };
0 -> 0
Example 2
~~~~~~~~~
data a :*: b = !a :*: !b
data T a = T !a
foo :: (Int :*: T Int) -> Int
foo (0 :*: t) = 0
foo (x :*: t) | even x = case t of { T n -> foo ((x-n) :*: t) }
| otherwise = foo ((x-1) :*: t)
Very similar to the previous one, except that the parameters are now in
a strict tuple. Before SpecConstr, we have
$wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
$wfoo_sG3 =
\ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
GHC.Base.Int) ->
case ww_sFU of ds_Xws [Just L] {
__DEFAULT ->
case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
__DEFAULT ->
case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
$wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2 -- $wfoo1
};
0 ->
case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
$wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB -- $wfoo2
} } };
0 -> 0 }
We get two specialisations:
"SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
= Foo.$s$wfoo1 a_sFB sc_sGC ;
"SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
= Foo.$s$wfoo y_aFp sc_sGC ;
But perhaps the first one isn't good. After all, we know that tpl_B2 is
a T (I# x) really, because T is strict and Int has one constructor. (We can't
unbox the strict fields, becuase T is polymorphic!)
%************************************************************************
%* *
\subsection{Top level wrapper stuff}
%* *
%************************************************************************
\begin{code}
<pre><a name="line-1"></a><a name="specConstrProgram"></a><span class='hs-definition'>specConstrProgram</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>DynFlags</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>UniqSupply</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>CoreBind</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>CoreBind</span><span class='hs-keyglyph'>]</span>
<a name="line-2"></a><span class='hs-definition'>specConstrProgram</span> <span class='hs-varid'>dflags</span> <span class='hs-varid'>us</span> <span class='hs-varid'>binds</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>fst</span> <span class='hs-varop'>$</span> <span class='hs-varid'>initUs</span> <span class='hs-varid'>us</span> <span class='hs-layout'>(</span><span class='hs-varid'>go</span> <span class='hs-layout'>(</span><span class='hs-varid'>initScEnv</span> <span class='hs-varid'>dflags</span><span class='hs-layout'>)</span> <span class='hs-varid'>binds</span><span class='hs-layout'>)</span>
<a name="line-3"></a> <span class='hs-keyword'>where</span>
<a name="line-4"></a> <span class='hs-varid'>go</span> <span class='hs-keyword'>_</span> <span class='hs-conid'>[]</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-conid'>[]</span>
<a name="line-5"></a> <span class='hs-varid'>go</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-varid'>bind</span><span class='hs-conop'>:</span><span class='hs-varid'>binds</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-layout'>(</span><span class='hs-varid'>env'</span><span class='hs-layout'>,</span> <span class='hs-varid'>bind'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>scTopBind</span> <span class='hs-varid'>env</span> <span class='hs-varid'>bind</span>
<a name="line-6"></a> <span class='hs-varid'>binds'</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>go</span> <span class='hs-varid'>env'</span> <span class='hs-varid'>binds</span>
<a name="line-7"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>bind'</span> <span class='hs-conop'>:</span> <span class='hs-varid'>binds'</span><span class='hs-layout'>)</span>
</pre>\end{code}
%************************************************************************
%* *
\subsection{Environment: goes downwards}
%* *
%************************************************************************
\begin{code}
<pre><a name="line-1"></a><a name="ScEnv"></a><span class='hs-keyword'>data</span> <span class='hs-conid'>ScEnv</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>SCE</span> <span class='hs-layout'>{</span> <span class='hs-varid'>sc_size</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Maybe</span> <span class='hs-conid'>Int</span><span class='hs-layout'>,</span> <span class='hs-comment'>-- Size threshold</span>
<a name="line-2"></a> <span class='hs-varid'>sc_count</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Maybe</span> <span class='hs-conid'>Int</span><span class='hs-layout'>,</span> <span class='hs-comment'>-- Max # of specialisations for any one fn</span>
<a name="line-3"></a>
<a name="line-4"></a> <span class='hs-varid'>sc_subst</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Subst</span><span class='hs-layout'>,</span> <span class='hs-comment'>-- Current substitution</span>
<a name="line-5"></a> <span class='hs-comment'>-- Maps InIds to OutExprs</span>
<a name="line-6"></a>
<a name="line-7"></a> <span class='hs-varid'>sc_how_bound</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>HowBoundEnv</span><span class='hs-layout'>,</span>
<a name="line-8"></a> <span class='hs-comment'>-- Binds interesting non-top-level variables</span>
<a name="line-9"></a> <span class='hs-comment'>-- Domain is OutVars (*after* applying the substitution)</span>
<a name="line-10"></a>
<a name="line-11"></a> <span class='hs-varid'>sc_vals</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ValueEnv</span>
<a name="line-12"></a> <span class='hs-comment'>-- Domain is OutIds (*after* applying the substitution)</span>
<a name="line-13"></a> <span class='hs-comment'>-- Used even for top-level bindings (but not imported ones)</span>
<a name="line-14"></a> <span class='hs-layout'>}</span>
<a name="line-15"></a>
<a name="line-16"></a><a name="InExpr"></a><span class='hs-comment'>---------------------</span>
<a name="line-17"></a><a name="InExpr"></a><span class='hs-comment'>-- As we go, we apply a substitution (sc_subst) to the current term</span>
<a name="line-18"></a><a name="InExpr"></a><span class='hs-keyword'>type</span> <span class='hs-conid'>InExpr</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>CoreExpr</span> <span class='hs-comment'>-- _Before_ applying the subst</span>
<a name="line-19"></a>
<a name="line-20"></a><a name="OutExpr"></a><span class='hs-keyword'>type</span> <span class='hs-conid'>OutExpr</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>CoreExpr</span> <span class='hs-comment'>-- _After_ applying the subst</span>
<a name="line-21"></a><a name="OutId"></a><span class='hs-keyword'>type</span> <span class='hs-conid'>OutId</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Id</span>
<a name="line-22"></a><a name="OutVar"></a><span class='hs-keyword'>type</span> <span class='hs-conid'>OutVar</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Var</span>
<a name="line-23"></a>
<a name="line-24"></a><a name="HowBoundEnv"></a><span class='hs-comment'>---------------------</span>
<a name="line-25"></a><a name="HowBoundEnv"></a><span class='hs-keyword'>type</span> <span class='hs-conid'>HowBoundEnv</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>VarEnv</span> <span class='hs-conid'>HowBound</span> <span class='hs-comment'>-- Domain is OutVars</span>
<a name="line-26"></a>
<a name="line-27"></a><a name="ValueEnv"></a><span class='hs-comment'>---------------------</span>
<a name="line-28"></a><a name="ValueEnv"></a><span class='hs-keyword'>type</span> <span class='hs-conid'>ValueEnv</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>IdEnv</span> <span class='hs-conid'>Value</span> <span class='hs-comment'>-- Domain is OutIds</span>
<a name="line-29"></a><a name="Value"></a><span class='hs-keyword'>data</span> <span class='hs-conid'>Value</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ConVal</span> <span class='hs-conid'>AltCon</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>CoreArg</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- _Saturated_ constructors</span>
<a name="line-30"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>LambdaVal</span> <span class='hs-comment'>-- Inlinable lambdas or PAPs</span>
<a name="line-31"></a>
<a name="line-32"></a><span class='hs-keyword'>instance</span> <span class='hs-conid'>Outputable</span> <span class='hs-conid'>Value</span> <span class='hs-keyword'>where</span>
<a name="line-33"></a> <span class='hs-varid'>ppr</span> <span class='hs-layout'>(</span><span class='hs-conid'>ConVal</span> <span class='hs-varid'>con</span> <span class='hs-varid'>args</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>ppr</span> <span class='hs-varid'>con</span> <span class='hs-varop'><+></span> <span class='hs-varid'>interpp'SP</span> <span class='hs-varid'>args</span>
<a name="line-34"></a> <span class='hs-varid'>ppr</span> <span class='hs-conid'>LambdaVal</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>ptext</span> <span class='hs-layout'>(</span><span class='hs-varid'>sLit</span> <span class='hs-str'>"<Lambda>"</span><span class='hs-layout'>)</span>
<a name="line-35"></a>
<a name="line-36"></a><a name="initScEnv"></a><span class='hs-comment'>---------------------</span>
<a name="line-37"></a><span class='hs-definition'>initScEnv</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>DynFlags</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ScEnv</span>
<a name="line-38"></a><span class='hs-definition'>initScEnv</span> <span class='hs-varid'>dflags</span>
<a name="line-39"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>SCE</span> <span class='hs-layout'>{</span> <span class='hs-varid'>sc_size</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>specConstrThreshold</span> <span class='hs-varid'>dflags</span><span class='hs-layout'>,</span>
<a name="line-40"></a> <span class='hs-varid'>sc_count</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>specConstrCount</span> <span class='hs-varid'>dflags</span><span class='hs-layout'>,</span>
<a name="line-41"></a> <span class='hs-varid'>sc_subst</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>emptySubst</span><span class='hs-layout'>,</span>
<a name="line-42"></a> <span class='hs-varid'>sc_how_bound</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>emptyVarEnv</span><span class='hs-layout'>,</span>
<a name="line-43"></a> <span class='hs-varid'>sc_vals</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>emptyVarEnv</span> <span class='hs-layout'>}</span>
<a name="line-44"></a>
<a name="line-45"></a><a name="HowBound"></a><span class='hs-keyword'>data</span> <span class='hs-conid'>HowBound</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>RecFun</span> <span class='hs-comment'>-- These are the recursive functions for which </span>
<a name="line-46"></a> <span class='hs-comment'>-- we seek interesting call patterns</span>
<a name="line-47"></a>
<a name="line-48"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>RecArg</span> <span class='hs-comment'>-- These are those functions' arguments, or their sub-components; </span>
<a name="line-49"></a> <span class='hs-comment'>-- we gather occurrence information for these</span>
<a name="line-50"></a>
<a name="line-51"></a><span class='hs-keyword'>instance</span> <span class='hs-conid'>Outputable</span> <span class='hs-conid'>HowBound</span> <span class='hs-keyword'>where</span>
<a name="line-52"></a> <span class='hs-varid'>ppr</span> <span class='hs-conid'>RecFun</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>text</span> <span class='hs-str'>"RecFun"</span>
<a name="line-53"></a> <span class='hs-varid'>ppr</span> <span class='hs-conid'>RecArg</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>text</span> <span class='hs-str'>"RecArg"</span>
<a name="line-54"></a>
<a name="line-55"></a><a name="lookupHowBound"></a><span class='hs-definition'>lookupHowBound</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ScEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Id</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Maybe</span> <span class='hs-conid'>HowBound</span>
<a name="line-56"></a><span class='hs-definition'>lookupHowBound</span> <span class='hs-varid'>env</span> <span class='hs-varid'>id</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>lookupVarEnv</span> <span class='hs-layout'>(</span><span class='hs-varid'>sc_how_bound</span> <span class='hs-varid'>env</span><span class='hs-layout'>)</span> <span class='hs-varid'>id</span>
<a name="line-57"></a>
<a name="line-58"></a><a name="scSubstId"></a><span class='hs-definition'>scSubstId</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ScEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Id</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span>
<a name="line-59"></a><span class='hs-definition'>scSubstId</span> <span class='hs-varid'>env</span> <span class='hs-varid'>v</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>lookupIdSubst</span> <span class='hs-layout'>(</span><span class='hs-varid'>sc_subst</span> <span class='hs-varid'>env</span><span class='hs-layout'>)</span> <span class='hs-varid'>v</span>
<a name="line-60"></a>
<a name="line-61"></a><a name="scSubstTy"></a><span class='hs-definition'>scSubstTy</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ScEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span>
<a name="line-62"></a><span class='hs-definition'>scSubstTy</span> <span class='hs-varid'>env</span> <span class='hs-varid'>ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>substTy</span> <span class='hs-layout'>(</span><span class='hs-varid'>sc_subst</span> <span class='hs-varid'>env</span><span class='hs-layout'>)</span> <span class='hs-varid'>ty</span>
<a name="line-63"></a>
<a name="line-64"></a><a name="zapScSubst"></a><span class='hs-definition'>zapScSubst</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ScEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ScEnv</span>
<a name="line-65"></a><span class='hs-definition'>zapScSubst</span> <span class='hs-varid'>env</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>env</span> <span class='hs-layout'>{</span> <span class='hs-varid'>sc_subst</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>zapSubstEnv</span> <span class='hs-layout'>(</span><span class='hs-varid'>sc_subst</span> <span class='hs-varid'>env</span><span class='hs-layout'>)</span> <span class='hs-layout'>}</span>
<a name="line-66"></a>
<a name="line-67"></a><a name="extendScInScope"></a><span class='hs-definition'>extendScInScope</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ScEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Var</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ScEnv</span>
<a name="line-68"></a> <span class='hs-comment'>-- Bring the quantified variables into scope</span>
<a name="line-69"></a><span class='hs-definition'>extendScInScope</span> <span class='hs-varid'>env</span> <span class='hs-varid'>qvars</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>env</span> <span class='hs-layout'>{</span> <span class='hs-varid'>sc_subst</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendInScopeList</span> <span class='hs-layout'>(</span><span class='hs-varid'>sc_subst</span> <span class='hs-varid'>env</span><span class='hs-layout'>)</span> <span class='hs-varid'>qvars</span> <span class='hs-layout'>}</span>
<a name="line-70"></a>
<a name="line-71"></a> <span class='hs-comment'>-- Extend the substitution</span>
<a name="line-72"></a><a name="extendScSubst"></a><span class='hs-definition'>extendScSubst</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ScEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Var</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>OutExpr</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ScEnv</span>
<a name="line-73"></a><span class='hs-definition'>extendScSubst</span> <span class='hs-varid'>env</span> <span class='hs-varid'>var</span> <span class='hs-varid'>expr</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>env</span> <span class='hs-layout'>{</span> <span class='hs-varid'>sc_subst</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendSubst</span> <span class='hs-layout'>(</span><span class='hs-varid'>sc_subst</span> <span class='hs-varid'>env</span><span class='hs-layout'>)</span> <span class='hs-varid'>var</span> <span class='hs-varid'>expr</span> <span class='hs-layout'>}</span>
<a name="line-74"></a>
<a name="line-75"></a><a name="extendScSubstList"></a><span class='hs-definition'>extendScSubstList</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ScEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>Var</span><span class='hs-layout'>,</span><span class='hs-conid'>OutExpr</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ScEnv</span>
<a name="line-76"></a><span class='hs-definition'>extendScSubstList</span> <span class='hs-varid'>env</span> <span class='hs-varid'>prs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>env</span> <span class='hs-layout'>{</span> <span class='hs-varid'>sc_subst</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendSubstList</span> <span class='hs-layout'>(</span><span class='hs-varid'>sc_subst</span> <span class='hs-varid'>env</span><span class='hs-layout'>)</span> <span class='hs-varid'>prs</span> <span class='hs-layout'>}</span>
<a name="line-77"></a>
<a name="line-78"></a><a name="extendHowBound"></a><span class='hs-definition'>extendHowBound</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ScEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Var</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>HowBound</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ScEnv</span>
<a name="line-79"></a><span class='hs-definition'>extendHowBound</span> <span class='hs-varid'>env</span> <span class='hs-varid'>bndrs</span> <span class='hs-varid'>how_bound</span>
<a name="line-80"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>env</span> <span class='hs-layout'>{</span> <span class='hs-varid'>sc_how_bound</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendVarEnvList</span> <span class='hs-layout'>(</span><span class='hs-varid'>sc_how_bound</span> <span class='hs-varid'>env</span><span class='hs-layout'>)</span>
<a name="line-81"></a> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>bndr</span><span class='hs-layout'>,</span><span class='hs-varid'>how_bound</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>bndr</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>bndrs</span><span class='hs-keyglyph'>]</span> <span class='hs-layout'>}</span>
<a name="line-82"></a>
<a name="line-83"></a><a name="extendBndrsWith"></a><span class='hs-definition'>extendBndrsWith</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>HowBound</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ScEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Var</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>ScEnv</span><span class='hs-layout'>,</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Var</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-84"></a><span class='hs-definition'>extendBndrsWith</span> <span class='hs-varid'>how_bound</span> <span class='hs-varid'>env</span> <span class='hs-varid'>bndrs</span>
<a name="line-85"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>env</span> <span class='hs-layout'>{</span> <span class='hs-varid'>sc_subst</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>subst'</span><span class='hs-layout'>,</span> <span class='hs-varid'>sc_how_bound</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>hb_env'</span> <span class='hs-layout'>}</span><span class='hs-layout'>,</span> <span class='hs-varid'>bndrs'</span><span class='hs-layout'>)</span>
<a name="line-86"></a> <span class='hs-keyword'>where</span>
<a name="line-87"></a> <span class='hs-layout'>(</span><span class='hs-varid'>subst'</span><span class='hs-layout'>,</span> <span class='hs-varid'>bndrs'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>substBndrs</span> <span class='hs-layout'>(</span><span class='hs-varid'>sc_subst</span> <span class='hs-varid'>env</span><span class='hs-layout'>)</span> <span class='hs-varid'>bndrs</span>
<a name="line-88"></a> <span class='hs-varid'>hb_env'</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>sc_how_bound</span> <span class='hs-varid'>env</span> <span class='hs-varop'>`extendVarEnvList`</span>
<a name="line-89"></a> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>bndr</span><span class='hs-layout'>,</span><span class='hs-varid'>how_bound</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>bndr</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>bndrs'</span><span class='hs-keyglyph'>]</span>
<a name="line-90"></a>
<a name="line-91"></a><a name="extendBndrWith"></a><span class='hs-definition'>extendBndrWith</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>HowBound</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ScEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Var</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>ScEnv</span><span class='hs-layout'>,</span> <span class='hs-conid'>Var</span><span class='hs-layout'>)</span>
<a name="line-92"></a><span class='hs-definition'>extendBndrWith</span> <span class='hs-varid'>how_bound</span> <span class='hs-varid'>env</span> <span class='hs-varid'>bndr</span>
<a name="line-93"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>env</span> <span class='hs-layout'>{</span> <span class='hs-varid'>sc_subst</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>subst'</span><span class='hs-layout'>,</span> <span class='hs-varid'>sc_how_bound</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>hb_env'</span> <span class='hs-layout'>}</span><span class='hs-layout'>,</span> <span class='hs-varid'>bndr'</span><span class='hs-layout'>)</span>
<a name="line-94"></a> <span class='hs-keyword'>where</span>
<a name="line-95"></a> <span class='hs-layout'>(</span><span class='hs-varid'>subst'</span><span class='hs-layout'>,</span> <span class='hs-varid'>bndr'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>substBndr</span> <span class='hs-layout'>(</span><span class='hs-varid'>sc_subst</span> <span class='hs-varid'>env</span><span class='hs-layout'>)</span> <span class='hs-varid'>bndr</span>
<a name="line-96"></a> <span class='hs-varid'>hb_env'</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendVarEnv</span> <span class='hs-layout'>(</span><span class='hs-varid'>sc_how_bound</span> <span class='hs-varid'>env</span><span class='hs-layout'>)</span> <span class='hs-varid'>bndr'</span> <span class='hs-varid'>how_bound</span>
<a name="line-97"></a>
<a name="line-98"></a><a name="extendRecBndrs"></a><span class='hs-definition'>extendRecBndrs</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ScEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Var</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>ScEnv</span><span class='hs-layout'>,</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Var</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-99"></a><span class='hs-definition'>extendRecBndrs</span> <span class='hs-varid'>env</span> <span class='hs-varid'>bndrs</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>env</span> <span class='hs-layout'>{</span> <span class='hs-varid'>sc_subst</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>subst'</span> <span class='hs-layout'>}</span><span class='hs-layout'>,</span> <span class='hs-varid'>bndrs'</span><span class='hs-layout'>)</span>
<a name="line-100"></a> <span class='hs-keyword'>where</span>
<a name="line-101"></a> <span class='hs-layout'>(</span><span class='hs-varid'>subst'</span><span class='hs-layout'>,</span> <span class='hs-varid'>bndrs'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>substRecBndrs</span> <span class='hs-layout'>(</span><span class='hs-varid'>sc_subst</span> <span class='hs-varid'>env</span><span class='hs-layout'>)</span> <span class='hs-varid'>bndrs</span>
<a name="line-102"></a>
<a name="line-103"></a><a name="extendBndr"></a><span class='hs-definition'>extendBndr</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ScEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Var</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>ScEnv</span><span class='hs-layout'>,</span> <span class='hs-conid'>Var</span><span class='hs-layout'>)</span>
<a name="line-104"></a><span class='hs-definition'>extendBndr</span> <span class='hs-varid'>env</span> <span class='hs-varid'>bndr</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>env</span> <span class='hs-layout'>{</span> <span class='hs-varid'>sc_subst</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>subst'</span> <span class='hs-layout'>}</span><span class='hs-layout'>,</span> <span class='hs-varid'>bndr'</span><span class='hs-layout'>)</span>
<a name="line-105"></a> <span class='hs-keyword'>where</span>
<a name="line-106"></a> <span class='hs-layout'>(</span><span class='hs-varid'>subst'</span><span class='hs-layout'>,</span> <span class='hs-varid'>bndr'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>substBndr</span> <span class='hs-layout'>(</span><span class='hs-varid'>sc_subst</span> <span class='hs-varid'>env</span><span class='hs-layout'>)</span> <span class='hs-varid'>bndr</span>
<a name="line-107"></a>
<a name="line-108"></a><a name="extendValEnv"></a><span class='hs-definition'>extendValEnv</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ScEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Id</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Maybe</span> <span class='hs-conid'>Value</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ScEnv</span>
<a name="line-109"></a><span class='hs-definition'>extendValEnv</span> <span class='hs-varid'>env</span> <span class='hs-keyword'>_</span> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>env</span>
<a name="line-110"></a><span class='hs-definition'>extendValEnv</span> <span class='hs-varid'>env</span> <span class='hs-varid'>id</span> <span class='hs-layout'>(</span><span class='hs-conid'>Just</span> <span class='hs-varid'>cv</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>env</span> <span class='hs-layout'>{</span> <span class='hs-varid'>sc_vals</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendVarEnv</span> <span class='hs-layout'>(</span><span class='hs-varid'>sc_vals</span> <span class='hs-varid'>env</span><span class='hs-layout'>)</span> <span class='hs-varid'>id</span> <span class='hs-varid'>cv</span> <span class='hs-layout'>}</span>
<a name="line-111"></a>
<a name="line-112"></a><a name="extendCaseBndrs"></a><span class='hs-definition'>extendCaseBndrs</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ScEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Id</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>AltCon</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Var</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>ScEnv</span><span class='hs-layout'>,</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Var</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-113"></a><span class='hs-comment'>-- When we encounter</span>
<a name="line-114"></a><span class='hs-comment'>-- case scrut of b</span>
<a name="line-115"></a><span class='hs-comment'>-- C x y -> ...</span>
<a name="line-116"></a><span class='hs-comment'>-- we want to bind b, to (C x y)</span>
<a name="line-117"></a><span class='hs-comment'>-- NB1: Extends only the sc_vals part of the envt</span>
<a name="line-118"></a><span class='hs-comment'>-- NB2: Kill the dead-ness info on the pattern binders x,y, since</span>
<a name="line-119"></a><span class='hs-comment'>-- they are potentially made alive by the [b -> C x y] binding</span>
<a name="line-120"></a><span class='hs-definition'>extendCaseBndrs</span> <span class='hs-varid'>env</span> <span class='hs-varid'>case_bndr</span> <span class='hs-varid'>con</span> <span class='hs-varid'>alt_bndrs</span>
<a name="line-121"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isDeadBinder</span> <span class='hs-varid'>case_bndr</span>
<a name="line-122"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>env</span><span class='hs-layout'>,</span> <span class='hs-varid'>alt_bndrs</span><span class='hs-layout'>)</span>
<a name="line-123"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span>
<a name="line-124"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>env1</span><span class='hs-layout'>,</span> <span class='hs-varid'>map</span> <span class='hs-varid'>zap</span> <span class='hs-varid'>alt_bndrs</span><span class='hs-layout'>)</span>
<a name="line-125"></a> <span class='hs-comment'>-- NB: We used to bind v too, if scrut = (Var v); but</span>
<a name="line-126"></a> <span class='hs-comment'>-- the simplifer has already done this so it seems</span>
<a name="line-127"></a> <span class='hs-comment'>-- redundant to do so here</span>
<a name="line-128"></a> <span class='hs-comment'>-- case scrut of</span>
<a name="line-129"></a> <span class='hs-comment'>-- Var v -> extendValEnv env1 v cval</span>
<a name="line-130"></a> <span class='hs-comment'>-- _other -> env1</span>
<a name="line-131"></a> <span class='hs-keyword'>where</span>
<a name="line-132"></a> <span class='hs-varid'>zap</span> <span class='hs-varid'>v</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isTyVar</span> <span class='hs-varid'>v</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>v</span> <span class='hs-comment'>-- See NB2 above</span>
<a name="line-133"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>zapIdOccInfo</span> <span class='hs-varid'>v</span>
<a name="line-134"></a> <span class='hs-varid'>env1</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendValEnv</span> <span class='hs-varid'>env</span> <span class='hs-varid'>case_bndr</span> <span class='hs-varid'>cval</span>
<a name="line-135"></a> <span class='hs-varid'>cval</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>case</span> <span class='hs-varid'>con</span> <span class='hs-keyword'>of</span>
<a name="line-136"></a> <span class='hs-conid'>DEFAULT</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Nothing</span>
<a name="line-137"></a> <span class='hs-conid'>LitAlt</span> <span class='hs-layout'>{</span><span class='hs-layout'>}</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Just</span> <span class='hs-layout'>(</span><span class='hs-conid'>ConVal</span> <span class='hs-varid'>con</span> <span class='hs-conid'>[]</span><span class='hs-layout'>)</span>
<a name="line-138"></a> <span class='hs-conid'>DataAlt</span> <span class='hs-layout'>{</span><span class='hs-layout'>}</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Just</span> <span class='hs-layout'>(</span><span class='hs-conid'>ConVal</span> <span class='hs-varid'>con</span> <span class='hs-varid'>vanilla_args</span><span class='hs-layout'>)</span>
<a name="line-139"></a> <span class='hs-keyword'>where</span>
<a name="line-140"></a> <span class='hs-varid'>vanilla_args</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>map</span> <span class='hs-conid'>Type</span> <span class='hs-layout'>(</span><span class='hs-varid'>tyConAppArgs</span> <span class='hs-layout'>(</span><span class='hs-varid'>idType</span> <span class='hs-varid'>case_bndr</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-varop'>++</span>
<a name="line-141"></a> <span class='hs-varid'>varsToCoreExprs</span> <span class='hs-varid'>alt_bndrs</span>
</pre>\end{code}
%************************************************************************
%* *
\subsection{Usage information: flows upwards}
%* *
%************************************************************************
\begin{code}
<pre><a name="line-1"></a><a name="ScUsage"></a><span class='hs-keyword'>data</span> <span class='hs-conid'>ScUsage</span>
<a name="line-2"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>SCU</span> <span class='hs-layout'>{</span>
<a name="line-3"></a> <span class='hs-varid'>scu_calls</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>CallEnv</span><span class='hs-layout'>,</span> <span class='hs-comment'>-- Calls</span>
<a name="line-4"></a> <span class='hs-comment'>-- The functions are a subset of the </span>
<a name="line-5"></a> <span class='hs-comment'>-- RecFuns in the ScEnv</span>
<a name="line-6"></a>
<a name="line-7"></a> <span class='hs-varid'>scu_occs</span> <span class='hs-keyglyph'>::</span> <span class='hs-varop'>!</span><span class='hs-layout'>(</span><span class='hs-conid'>IdEnv</span> <span class='hs-conid'>ArgOcc</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- Information on argument occurrences</span>
<a name="line-8"></a> <span class='hs-layout'>}</span> <span class='hs-comment'>-- The domain is OutIds</span>
<a name="line-9"></a>
<a name="line-10"></a><a name="CallEnv"></a><span class='hs-keyword'>type</span> <span class='hs-conid'>CallEnv</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>IdEnv</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Call</span><span class='hs-keyglyph'>]</span>
<a name="line-11"></a><a name="Call"></a><span class='hs-keyword'>type</span> <span class='hs-conid'>Call</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-conid'>ValueEnv</span><span class='hs-layout'>,</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>CoreArg</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-12"></a> <span class='hs-comment'>-- The arguments of the call, together with the</span>
<a name="line-13"></a> <span class='hs-comment'>-- env giving the constructor bindings at the call site</span>
<a name="line-14"></a>
<a name="line-15"></a><a name="nullUsage"></a><span class='hs-definition'>nullUsage</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ScUsage</span>
<a name="line-16"></a><span class='hs-definition'>nullUsage</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>SCU</span> <span class='hs-layout'>{</span> <span class='hs-varid'>scu_calls</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>emptyVarEnv</span><span class='hs-layout'>,</span> <span class='hs-varid'>scu_occs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>emptyVarEnv</span> <span class='hs-layout'>}</span>
<a name="line-17"></a>
<a name="line-18"></a><a name="combineCalls"></a><span class='hs-definition'>combineCalls</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>CallEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CallEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CallEnv</span>
<a name="line-19"></a><span class='hs-definition'>combineCalls</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>plusVarEnv_C</span> <span class='hs-layout'>(</span><span class='hs-varop'>++</span><span class='hs-layout'>)</span>
<a name="line-20"></a>
<a name="line-21"></a><a name="combineUsage"></a><span class='hs-definition'>combineUsage</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ScUsage</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ScUsage</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ScUsage</span>
<a name="line-22"></a><span class='hs-definition'>combineUsage</span> <span class='hs-varid'>u1</span> <span class='hs-varid'>u2</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>SCU</span> <span class='hs-layout'>{</span> <span class='hs-varid'>scu_calls</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>combineCalls</span> <span class='hs-layout'>(</span><span class='hs-varid'>scu_calls</span> <span class='hs-varid'>u1</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>scu_calls</span> <span class='hs-varid'>u2</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span>
<a name="line-23"></a> <span class='hs-varid'>scu_occs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>plusVarEnv_C</span> <span class='hs-varid'>combineOcc</span> <span class='hs-layout'>(</span><span class='hs-varid'>scu_occs</span> <span class='hs-varid'>u1</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>scu_occs</span> <span class='hs-varid'>u2</span><span class='hs-layout'>)</span> <span class='hs-layout'>}</span>
<a name="line-24"></a>
<a name="line-25"></a><a name="combineUsages"></a><span class='hs-definition'>combineUsages</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>ScUsage</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ScUsage</span>
<a name="line-26"></a><span class='hs-definition'>combineUsages</span> <span class='hs-conid'>[]</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nullUsage</span>
<a name="line-27"></a><span class='hs-definition'>combineUsages</span> <span class='hs-varid'>us</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>foldr1</span> <span class='hs-varid'>combineUsage</span> <span class='hs-varid'>us</span>
<a name="line-28"></a>
<a name="line-29"></a><a name="lookupOcc"></a><span class='hs-definition'>lookupOcc</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ScUsage</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>OutVar</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>ScUsage</span><span class='hs-layout'>,</span> <span class='hs-conid'>ArgOcc</span><span class='hs-layout'>)</span>
<a name="line-30"></a><span class='hs-definition'>lookupOcc</span> <span class='hs-layout'>(</span><span class='hs-conid'>SCU</span> <span class='hs-layout'>{</span> <span class='hs-varid'>scu_calls</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>sc_calls</span><span class='hs-layout'>,</span> <span class='hs-varid'>scu_occs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>sc_occs</span> <span class='hs-layout'>}</span><span class='hs-layout'>)</span> <span class='hs-varid'>bndr</span>
<a name="line-31"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-conid'>SCU</span> <span class='hs-layout'>{</span><span class='hs-varid'>scu_calls</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>sc_calls</span><span class='hs-layout'>,</span> <span class='hs-varid'>scu_occs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>delVarEnv</span> <span class='hs-varid'>sc_occs</span> <span class='hs-varid'>bndr</span><span class='hs-layout'>}</span><span class='hs-layout'>,</span>
<a name="line-32"></a> <span class='hs-varid'>lookupVarEnv</span> <span class='hs-varid'>sc_occs</span> <span class='hs-varid'>bndr</span> <span class='hs-varop'>`orElse`</span> <span class='hs-conid'>NoOcc</span><span class='hs-layout'>)</span>
<a name="line-33"></a>
<a name="line-34"></a><a name="lookupOccs"></a><span class='hs-definition'>lookupOccs</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ScUsage</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>OutVar</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>ScUsage</span><span class='hs-layout'>,</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>ArgOcc</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-35"></a><span class='hs-definition'>lookupOccs</span> <span class='hs-layout'>(</span><span class='hs-conid'>SCU</span> <span class='hs-layout'>{</span> <span class='hs-varid'>scu_calls</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>sc_calls</span><span class='hs-layout'>,</span> <span class='hs-varid'>scu_occs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>sc_occs</span> <span class='hs-layout'>}</span><span class='hs-layout'>)</span> <span class='hs-varid'>bndrs</span>
<a name="line-36"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-conid'>SCU</span> <span class='hs-layout'>{</span><span class='hs-varid'>scu_calls</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>sc_calls</span><span class='hs-layout'>,</span> <span class='hs-varid'>scu_occs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>delVarEnvList</span> <span class='hs-varid'>sc_occs</span> <span class='hs-varid'>bndrs</span><span class='hs-layout'>}</span><span class='hs-layout'>,</span>
<a name="line-37"></a> <span class='hs-keyglyph'>[</span><span class='hs-varid'>lookupVarEnv</span> <span class='hs-varid'>sc_occs</span> <span class='hs-varid'>b</span> <span class='hs-varop'>`orElse`</span> <span class='hs-conid'>NoOcc</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>b</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>bndrs</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-38"></a>
<a name="line-39"></a><a name="ArgOcc"></a><span class='hs-keyword'>data</span> <span class='hs-conid'>ArgOcc</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>NoOcc</span> <span class='hs-comment'>-- Doesn't occur at all; or a type argument</span>
<a name="line-40"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>UnkOcc</span> <span class='hs-comment'>-- Used in some unknown way</span>
<a name="line-41"></a>
<a name="line-42"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>ScrutOcc</span> <span class='hs-layout'>(</span><span class='hs-conid'>UniqFM</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>ArgOcc</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- See Note [ScrutOcc]</span>
<a name="line-43"></a>
<a name="line-44"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>BothOcc</span> <span class='hs-comment'>-- Definitely taken apart, *and* perhaps used in some other way</span>
<a name="line-45"></a>
<a name="line-46"></a><span class='hs-comment'>{- Note [ScrutOcc]
<a name="line-47"></a>
<a name="line-48"></a>An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
<a name="line-49"></a>is *only* taken apart or applied.
<a name="line-50"></a>
<a name="line-51"></a> Functions, literal: ScrutOcc emptyUFM
<a name="line-52"></a> Data constructors: ScrutOcc subs,
<a name="line-53"></a>
<a name="line-54"></a>where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
<a name="line-55"></a>The domain of the UniqFM is the Unique of the data constructor
<a name="line-56"></a>
<a name="line-57"></a>The [ArgOcc] is the occurrences of the *pattern-bound* components
<a name="line-58"></a>of the data structure. E.g.
<a name="line-59"></a> data T a = forall b. MkT a b (b->a)
<a name="line-60"></a>A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
<a name="line-61"></a>
<a name="line-62"></a>-}</span>
<a name="line-63"></a>
<a name="line-64"></a><span class='hs-keyword'>instance</span> <span class='hs-conid'>Outputable</span> <span class='hs-conid'>ArgOcc</span> <span class='hs-keyword'>where</span>
<a name="line-65"></a> <span class='hs-varid'>ppr</span> <span class='hs-layout'>(</span><span class='hs-conid'>ScrutOcc</span> <span class='hs-varid'>xs</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>ptext</span> <span class='hs-layout'>(</span><span class='hs-varid'>sLit</span> <span class='hs-str'>"scrut-occ"</span><span class='hs-layout'>)</span> <span class='hs-varop'><></span> <span class='hs-varid'>ppr</span> <span class='hs-varid'>xs</span>
<a name="line-66"></a> <span class='hs-varid'>ppr</span> <span class='hs-conid'>UnkOcc</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>ptext</span> <span class='hs-layout'>(</span><span class='hs-varid'>sLit</span> <span class='hs-str'>"unk-occ"</span><span class='hs-layout'>)</span>
<a name="line-67"></a> <span class='hs-varid'>ppr</span> <span class='hs-conid'>BothOcc</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>ptext</span> <span class='hs-layout'>(</span><span class='hs-varid'>sLit</span> <span class='hs-str'>"both-occ"</span><span class='hs-layout'>)</span>
<a name="line-68"></a> <span class='hs-varid'>ppr</span> <span class='hs-conid'>NoOcc</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>ptext</span> <span class='hs-layout'>(</span><span class='hs-varid'>sLit</span> <span class='hs-str'>"no-occ"</span><span class='hs-layout'>)</span>
<a name="line-69"></a>
<a name="line-70"></a><a name="combineOcc"></a><span class='hs-comment'>-- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so</span>
<a name="line-71"></a><span class='hs-comment'>-- that if the thing is scrutinised anywhere then we get to see that</span>
<a name="line-72"></a><span class='hs-comment'>-- in the overall result, even if it's also used in a boxed way</span>
<a name="line-73"></a><span class='hs-comment'>-- This might be too agressive; see Note [Reboxing] Alternative 3</span>
<a name="line-74"></a><span class='hs-definition'>combineOcc</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ArgOcc</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ArgOcc</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ArgOcc</span>
<a name="line-75"></a><span class='hs-definition'>combineOcc</span> <span class='hs-conid'>NoOcc</span> <span class='hs-varid'>occ</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>occ</span>
<a name="line-76"></a><span class='hs-definition'>combineOcc</span> <span class='hs-varid'>occ</span> <span class='hs-conid'>NoOcc</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>occ</span>
<a name="line-77"></a><span class='hs-definition'>combineOcc</span> <span class='hs-layout'>(</span><span class='hs-conid'>ScrutOcc</span> <span class='hs-varid'>xs</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>ScrutOcc</span> <span class='hs-varid'>ys</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ScrutOcc</span> <span class='hs-layout'>(</span><span class='hs-varid'>plusUFM_C</span> <span class='hs-varid'>combineOccs</span> <span class='hs-varid'>xs</span> <span class='hs-varid'>ys</span><span class='hs-layout'>)</span>
<a name="line-78"></a><span class='hs-definition'>combineOcc</span> <span class='hs-sel'>_occ</span> <span class='hs-layout'>(</span><span class='hs-conid'>ScrutOcc</span> <span class='hs-varid'>ys</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ScrutOcc</span> <span class='hs-varid'>ys</span>
<a name="line-79"></a><span class='hs-definition'>combineOcc</span> <span class='hs-layout'>(</span><span class='hs-conid'>ScrutOcc</span> <span class='hs-varid'>xs</span><span class='hs-layout'>)</span> <span class='hs-sel'>_occ</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ScrutOcc</span> <span class='hs-varid'>xs</span>
<a name="line-80"></a><span class='hs-definition'>combineOcc</span> <span class='hs-conid'>UnkOcc</span> <span class='hs-conid'>UnkOcc</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>UnkOcc</span>
<a name="line-81"></a><span class='hs-definition'>combineOcc</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>BothOcc</span>
<a name="line-82"></a>
<a name="line-83"></a><a name="combineOccs"></a><span class='hs-definition'>combineOccs</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>ArgOcc</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>ArgOcc</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>ArgOcc</span><span class='hs-keyglyph'>]</span>
<a name="line-84"></a><span class='hs-definition'>combineOccs</span> <span class='hs-varid'>xs</span> <span class='hs-varid'>ys</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>zipWithEqual</span> <span class='hs-str'>"combineOccs"</span> <span class='hs-varid'>combineOcc</span> <span class='hs-varid'>xs</span> <span class='hs-varid'>ys</span>
<a name="line-85"></a>
<a name="line-86"></a><a name="setScrutOcc"></a><span class='hs-definition'>setScrutOcc</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ScEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ScUsage</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>OutExpr</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ArgOcc</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ScUsage</span>
<a name="line-87"></a><span class='hs-comment'>-- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee</span>
<a name="line-88"></a><span class='hs-comment'>-- is a variable, and an interesting variable</span>
<a name="line-89"></a><span class='hs-definition'>setScrutOcc</span> <span class='hs-varid'>env</span> <span class='hs-varid'>usg</span> <span class='hs-layout'>(</span><span class='hs-conid'>Cast</span> <span class='hs-varid'>e</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-varid'>occ</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>setScrutOcc</span> <span class='hs-varid'>env</span> <span class='hs-varid'>usg</span> <span class='hs-varid'>e</span> <span class='hs-varid'>occ</span>
<a name="line-90"></a><span class='hs-definition'>setScrutOcc</span> <span class='hs-varid'>env</span> <span class='hs-varid'>usg</span> <span class='hs-layout'>(</span><span class='hs-conid'>Note</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>e</span><span class='hs-layout'>)</span> <span class='hs-varid'>occ</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>setScrutOcc</span> <span class='hs-varid'>env</span> <span class='hs-varid'>usg</span> <span class='hs-varid'>e</span> <span class='hs-varid'>occ</span>
<a name="line-91"></a><span class='hs-definition'>setScrutOcc</span> <span class='hs-varid'>env</span> <span class='hs-varid'>usg</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>v</span><span class='hs-layout'>)</span> <span class='hs-varid'>occ</span>
<a name="line-92"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>Just</span> <span class='hs-conid'>RecArg</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lookupHowBound</span> <span class='hs-varid'>env</span> <span class='hs-varid'>v</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>usg</span> <span class='hs-layout'>{</span> <span class='hs-varid'>scu_occs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendVarEnv</span> <span class='hs-layout'>(</span><span class='hs-varid'>scu_occs</span> <span class='hs-varid'>usg</span><span class='hs-layout'>)</span> <span class='hs-varid'>v</span> <span class='hs-varid'>occ</span> <span class='hs-layout'>}</span>
<a name="line-93"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>usg</span>
<a name="line-94"></a><span class='hs-definition'>setScrutOcc</span> <span class='hs-sel'>_env</span> <span class='hs-varid'>usg</span> <span class='hs-sel'>_other</span> <span class='hs-sel'>_occ</span> <span class='hs-comment'>-- Catch-all</span>
<a name="line-95"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>usg</span>
<a name="line-96"></a>
<a name="line-97"></a><a name="conArgOccs"></a><span class='hs-definition'>conArgOccs</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ArgOcc</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>AltCon</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>ArgOcc</span><span class='hs-keyglyph'>]</span>
<a name="line-98"></a><span class='hs-comment'>-- Find usage of components of data con; returns [UnkOcc...] if unknown</span>
<a name="line-99"></a><span class='hs-comment'>-- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case</span>
<a name="line-100"></a>
<a name="line-101"></a><span class='hs-definition'>conArgOccs</span> <span class='hs-layout'>(</span><span class='hs-conid'>ScrutOcc</span> <span class='hs-varid'>fm</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>DataAlt</span> <span class='hs-varid'>dc</span><span class='hs-layout'>)</span>
<a name="line-102"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>Just</span> <span class='hs-varid'>pat_arg_occs</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lookupUFM</span> <span class='hs-varid'>fm</span> <span class='hs-varid'>dc</span>
<a name="line-103"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>UnkOcc</span> <span class='hs-keyglyph'>|</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>dataConUnivTyVars</span> <span class='hs-varid'>dc</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'>++</span> <span class='hs-varid'>pat_arg_occs</span>
<a name="line-104"></a>
<a name="line-105"></a><span class='hs-definition'>conArgOccs</span> <span class='hs-sel'>_other</span> <span class='hs-sel'>_con</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>repeat</span> <span class='hs-conid'>UnkOcc</span>
</pre>\end{code}
%************************************************************************
%* *
\subsection{The main recursive function}
%* *
%************************************************************************
The main recursive function gathers up usage information, and
creates specialised versions of functions.
\begin{code}
<pre><a name="line-1"></a><a name="scExpr"></a><span class='hs-definition'>scExpr</span><span class='hs-layout'>,</span> <span class='hs-varid'>scExpr'</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ScEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>UniqSM</span> <span class='hs-layout'>(</span><span class='hs-conid'>ScUsage</span><span class='hs-layout'>,</span> <span class='hs-conid'>CoreExpr</span><span class='hs-layout'>)</span>
<a name="line-2"></a> <span class='hs-comment'>-- The unique supply is needed when we invent</span>
<a name="line-3"></a> <span class='hs-comment'>-- a new name for the specialised function and its args</span>
<a name="line-4"></a>
<a name="line-5"></a><span class='hs-definition'>scExpr</span> <span class='hs-varid'>env</span> <span class='hs-varid'>e</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>scExpr'</span> <span class='hs-varid'>env</span> <span class='hs-varid'>e</span>
<a name="line-6"></a>
<a name="line-7"></a>
<a name="line-8"></a><a name="scExpr'"></a><span class='hs-definition'>scExpr'</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>v</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>case</span> <span class='hs-varid'>scSubstId</span> <span class='hs-varid'>env</span> <span class='hs-varid'>v</span> <span class='hs-keyword'>of</span>
<a name="line-9"></a> <span class='hs-conid'>Var</span> <span class='hs-varid'>v'</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>varUsage</span> <span class='hs-varid'>env</span> <span class='hs-varid'>v'</span> <span class='hs-conid'>UnkOcc</span><span class='hs-layout'>,</span> <span class='hs-conid'>Var</span> <span class='hs-varid'>v'</span><span class='hs-layout'>)</span>
<a name="line-10"></a> <span class='hs-varid'>e'</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>scExpr</span> <span class='hs-layout'>(</span><span class='hs-varid'>zapScSubst</span> <span class='hs-varid'>env</span><span class='hs-layout'>)</span> <span class='hs-varid'>e'</span>
<a name="line-11"></a>
<a name="line-12"></a><span class='hs-definition'>scExpr'</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-conid'>Type</span> <span class='hs-varid'>t</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>nullUsage</span><span class='hs-layout'>,</span> <span class='hs-conid'>Type</span> <span class='hs-layout'>(</span><span class='hs-varid'>scSubstTy</span> <span class='hs-varid'>env</span> <span class='hs-varid'>t</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-13"></a><span class='hs-definition'>scExpr'</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>e</span><span class='hs-keyglyph'>@</span><span class='hs-layout'>(</span><span class='hs-conid'>Lit</span> <span class='hs-layout'>{</span><span class='hs-layout'>}</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>nullUsage</span><span class='hs-layout'>,</span> <span class='hs-varid'>e</span><span class='hs-layout'>)</span>
<a name="line-14"></a><span class='hs-definition'>scExpr'</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-conid'>Note</span> <span class='hs-varid'>n</span> <span class='hs-varid'>e</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-layout'>(</span><span class='hs-varid'>usg</span><span class='hs-layout'>,</span><span class='hs-varid'>e'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>scExpr</span> <span class='hs-varid'>env</span> <span class='hs-varid'>e</span>
<a name="line-15"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>usg</span><span class='hs-layout'>,</span> <span class='hs-conid'>Note</span> <span class='hs-varid'>n</span> <span class='hs-varid'>e'</span><span class='hs-layout'>)</span>
<a name="line-16"></a><span class='hs-definition'>scExpr'</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-conid'>Cast</span> <span class='hs-varid'>e</span> <span class='hs-varid'>co</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-layout'>(</span><span class='hs-varid'>usg</span><span class='hs-layout'>,</span> <span class='hs-varid'>e'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>scExpr</span> <span class='hs-varid'>env</span> <span class='hs-varid'>e</span>
<a name="line-17"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>usg</span><span class='hs-layout'>,</span> <span class='hs-conid'>Cast</span> <span class='hs-varid'>e'</span> <span class='hs-layout'>(</span><span class='hs-varid'>scSubstTy</span> <span class='hs-varid'>env</span> <span class='hs-varid'>co</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-18"></a><span class='hs-definition'>scExpr'</span> <span class='hs-varid'>env</span> <span class='hs-varid'>e</span><span class='hs-keyglyph'>@</span><span class='hs-layout'>(</span><span class='hs-conid'>App</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>scApp</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-varid'>collectArgs</span> <span class='hs-varid'>e</span><span class='hs-layout'>)</span>
<a name="line-19"></a><span class='hs-definition'>scExpr'</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-conid'>Lam</span> <span class='hs-varid'>b</span> <span class='hs-varid'>e</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-keyword'>let</span> <span class='hs-layout'>(</span><span class='hs-varid'>env'</span><span class='hs-layout'>,</span> <span class='hs-varid'>b'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendBndr</span> <span class='hs-varid'>env</span> <span class='hs-varid'>b</span>
<a name="line-20"></a> <span class='hs-layout'>(</span><span class='hs-varid'>usg</span><span class='hs-layout'>,</span> <span class='hs-varid'>e'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>scExpr</span> <span class='hs-varid'>env'</span> <span class='hs-varid'>e</span>
<a name="line-21"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>usg</span><span class='hs-layout'>,</span> <span class='hs-conid'>Lam</span> <span class='hs-varid'>b'</span> <span class='hs-varid'>e'</span><span class='hs-layout'>)</span>
<a name="line-22"></a>
<a name="line-23"></a><span class='hs-definition'>scExpr'</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-conid'>Case</span> <span class='hs-varid'>scrut</span> <span class='hs-varid'>b</span> <span class='hs-varid'>ty</span> <span class='hs-varid'>alts</span><span class='hs-layout'>)</span>
<a name="line-24"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-layout'>{</span> <span class='hs-layout'>(</span><span class='hs-varid'>scrut_usg</span><span class='hs-layout'>,</span> <span class='hs-varid'>scrut'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>scExpr</span> <span class='hs-varid'>env</span> <span class='hs-varid'>scrut</span>
<a name="line-25"></a> <span class='hs-layout'>;</span> <span class='hs-keyword'>case</span> <span class='hs-varid'>isValue</span> <span class='hs-layout'>(</span><span class='hs-varid'>sc_vals</span> <span class='hs-varid'>env</span><span class='hs-layout'>)</span> <span class='hs-varid'>scrut'</span> <span class='hs-keyword'>of</span>
<a name="line-26"></a> <span class='hs-conid'>Just</span> <span class='hs-layout'>(</span><span class='hs-conid'>ConVal</span> <span class='hs-varid'>con</span> <span class='hs-varid'>args</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>sc_con_app</span> <span class='hs-varid'>con</span> <span class='hs-varid'>args</span> <span class='hs-varid'>scrut'</span>
<a name="line-27"></a> <span class='hs-sel'>_other</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>sc_vanilla</span> <span class='hs-varid'>scrut_usg</span> <span class='hs-varid'>scrut'</span>
<a name="line-28"></a> <span class='hs-layout'>}</span>
<a name="line-29"></a> <span class='hs-keyword'>where</span>
<a name="line-30"></a> <span class='hs-varid'>sc_con_app</span> <span class='hs-varid'>con</span> <span class='hs-varid'>args</span> <span class='hs-varid'>scrut'</span> <span class='hs-comment'>-- Known constructor; simplify</span>
<a name="line-31"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-layout'>{</span> <span class='hs-keyword'>let</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-varid'>bs</span><span class='hs-layout'>,</span> <span class='hs-varid'>rhs</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>findAlt</span> <span class='hs-varid'>con</span> <span class='hs-varid'>alts</span>
<a name="line-32"></a> <span class='hs-varop'>`orElse`</span> <span class='hs-layout'>(</span><span class='hs-conid'>DEFAULT</span><span class='hs-layout'>,</span> <span class='hs-conid'>[]</span><span class='hs-layout'>,</span> <span class='hs-varid'>mkImpossibleExpr</span> <span class='hs-layout'>(</span><span class='hs-varid'>coreAltsType</span> <span class='hs-varid'>alts</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-33"></a> <span class='hs-varid'>alt_env'</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendScSubstList</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-layout'>(</span><span class='hs-varid'>b</span><span class='hs-layout'>,</span><span class='hs-varid'>scrut'</span><span class='hs-layout'>)</span> <span class='hs-conop'>:</span> <span class='hs-varid'>bs</span> <span class='hs-varop'>`zip`</span> <span class='hs-varid'>trimConArgs</span> <span class='hs-varid'>con</span> <span class='hs-varid'>args</span><span class='hs-layout'>)</span>
<a name="line-34"></a> <span class='hs-layout'>;</span> <span class='hs-varid'>scExpr</span> <span class='hs-varid'>alt_env'</span> <span class='hs-varid'>rhs</span> <span class='hs-layout'>}</span>
<a name="line-35"></a>
<a name="line-36"></a> <span class='hs-varid'>sc_vanilla</span> <span class='hs-varid'>scrut_usg</span> <span class='hs-varid'>scrut'</span> <span class='hs-comment'>-- Normal case</span>
<a name="line-37"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-layout'>{</span> <span class='hs-keyword'>let</span> <span class='hs-layout'>(</span><span class='hs-varid'>alt_env</span><span class='hs-layout'>,</span><span class='hs-varid'>b'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendBndrWith</span> <span class='hs-conid'>RecArg</span> <span class='hs-varid'>env</span> <span class='hs-varid'>b</span>
<a name="line-38"></a> <span class='hs-comment'>-- Record RecArg for the components</span>
<a name="line-39"></a>
<a name="line-40"></a> <span class='hs-layout'>;</span> <span class='hs-layout'>(</span><span class='hs-varid'>alt_usgs</span><span class='hs-layout'>,</span> <span class='hs-varid'>alt_occs</span><span class='hs-layout'>,</span> <span class='hs-varid'>alts'</span><span class='hs-layout'>)</span>
<a name="line-41"></a> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapAndUnzip3M</span> <span class='hs-layout'>(</span><span class='hs-varid'>sc_alt</span> <span class='hs-varid'>alt_env</span> <span class='hs-varid'>scrut'</span> <span class='hs-varid'>b'</span><span class='hs-layout'>)</span> <span class='hs-varid'>alts</span>
<a name="line-42"></a>
<a name="line-43"></a> <span class='hs-layout'>;</span> <span class='hs-keyword'>let</span> <span class='hs-layout'>(</span><span class='hs-varid'>alt_usg</span><span class='hs-layout'>,</span> <span class='hs-varid'>b_occ</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>lookupOcc</span> <span class='hs-layout'>(</span><span class='hs-varid'>combineUsages</span> <span class='hs-varid'>alt_usgs</span><span class='hs-layout'>)</span> <span class='hs-varid'>b'</span>
<a name="line-44"></a> <span class='hs-varid'>scrut_occ</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>foldr</span> <span class='hs-varid'>combineOcc</span> <span class='hs-varid'>b_occ</span> <span class='hs-varid'>alt_occs</span>
<a name="line-45"></a> <span class='hs-varid'>scrut_usg'</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>setScrutOcc</span> <span class='hs-varid'>env</span> <span class='hs-varid'>scrut_usg</span> <span class='hs-varid'>scrut'</span> <span class='hs-varid'>scrut_occ</span>
<a name="line-46"></a> <span class='hs-comment'>-- The combined usage of the scrutinee is given</span>
<a name="line-47"></a> <span class='hs-comment'>-- by scrut_occ, which is passed to scScrut, which</span>
<a name="line-48"></a> <span class='hs-comment'>-- in turn treats a bare-variable scrutinee specially</span>
<a name="line-49"></a>
<a name="line-50"></a> <span class='hs-layout'>;</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>alt_usg</span> <span class='hs-varop'>`combineUsage`</span> <span class='hs-varid'>scrut_usg'</span><span class='hs-layout'>,</span>
<a name="line-51"></a> <span class='hs-conid'>Case</span> <span class='hs-varid'>scrut'</span> <span class='hs-varid'>b'</span> <span class='hs-layout'>(</span><span class='hs-varid'>scSubstTy</span> <span class='hs-varid'>env</span> <span class='hs-varid'>ty</span><span class='hs-layout'>)</span> <span class='hs-varid'>alts'</span><span class='hs-layout'>)</span> <span class='hs-layout'>}</span>
<a name="line-52"></a>
<a name="line-53"></a> <span class='hs-varid'>sc_alt</span> <span class='hs-varid'>env</span> <span class='hs-sel'>_scrut'</span> <span class='hs-varid'>b'</span> <span class='hs-layout'>(</span><span class='hs-varid'>con</span><span class='hs-layout'>,</span><span class='hs-varid'>bs</span><span class='hs-layout'>,</span><span class='hs-varid'>rhs</span><span class='hs-layout'>)</span>
<a name="line-54"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-layout'>{</span> <span class='hs-keyword'>let</span> <span class='hs-layout'>(</span><span class='hs-varid'>env1</span><span class='hs-layout'>,</span> <span class='hs-varid'>bs1</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendBndrsWith</span> <span class='hs-conid'>RecArg</span> <span class='hs-varid'>env</span> <span class='hs-varid'>bs</span>
<a name="line-55"></a> <span class='hs-layout'>(</span><span class='hs-varid'>env2</span><span class='hs-layout'>,</span> <span class='hs-varid'>bs2</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendCaseBndrs</span> <span class='hs-varid'>env1</span> <span class='hs-varid'>b'</span> <span class='hs-varid'>con</span> <span class='hs-varid'>bs1</span>
<a name="line-56"></a> <span class='hs-layout'>;</span> <span class='hs-layout'>(</span><span class='hs-varid'>usg</span><span class='hs-layout'>,</span><span class='hs-varid'>rhs'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>scExpr</span> <span class='hs-varid'>env2</span> <span class='hs-varid'>rhs</span>
<a name="line-57"></a> <span class='hs-layout'>;</span> <span class='hs-keyword'>let</span> <span class='hs-layout'>(</span><span class='hs-varid'>usg'</span><span class='hs-layout'>,</span> <span class='hs-varid'>arg_occs</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>lookupOccs</span> <span class='hs-varid'>usg</span> <span class='hs-varid'>bs2</span>
<a name="line-58"></a> <span class='hs-varid'>scrut_occ</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>case</span> <span class='hs-varid'>con</span> <span class='hs-keyword'>of</span>
<a name="line-59"></a> <span class='hs-conid'>DataAlt</span> <span class='hs-varid'>dc</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ScrutOcc</span> <span class='hs-layout'>(</span><span class='hs-varid'>unitUFM</span> <span class='hs-varid'>dc</span> <span class='hs-varid'>arg_occs</span><span class='hs-layout'>)</span>
<a name="line-60"></a> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ScrutOcc</span> <span class='hs-varid'>emptyUFM</span>
<a name="line-61"></a> <span class='hs-layout'>;</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>usg'</span><span class='hs-layout'>,</span> <span class='hs-varid'>scrut_occ</span><span class='hs-layout'>,</span> <span class='hs-layout'>(</span><span class='hs-varid'>con</span><span class='hs-layout'>,</span> <span class='hs-varid'>bs2</span><span class='hs-layout'>,</span> <span class='hs-varid'>rhs'</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-layout'>}</span>
<a name="line-62"></a>
<a name="line-63"></a><span class='hs-definition'>scExpr'</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-conid'>Let</span> <span class='hs-layout'>(</span><span class='hs-conid'>NonRec</span> <span class='hs-varid'>bndr</span> <span class='hs-varid'>rhs</span><span class='hs-layout'>)</span> <span class='hs-varid'>body</span><span class='hs-layout'>)</span>
<a name="line-64"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isTyVar</span> <span class='hs-varid'>bndr</span> <span class='hs-comment'>-- Type-lets may be created by doBeta</span>
<a name="line-65"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>scExpr'</span> <span class='hs-layout'>(</span><span class='hs-varid'>extendScSubst</span> <span class='hs-varid'>env</span> <span class='hs-varid'>bndr</span> <span class='hs-varid'>rhs</span><span class='hs-layout'>)</span> <span class='hs-varid'>body</span>
<a name="line-66"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span>
<a name="line-67"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-layout'>{</span> <span class='hs-keyword'>let</span> <span class='hs-layout'>(</span><span class='hs-varid'>body_env</span><span class='hs-layout'>,</span> <span class='hs-varid'>bndr'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendBndr</span> <span class='hs-varid'>env</span> <span class='hs-varid'>bndr</span>
<a name="line-68"></a> <span class='hs-layout'>;</span> <span class='hs-layout'>(</span><span class='hs-varid'>rhs_usg</span><span class='hs-layout'>,</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-varid'>args'</span><span class='hs-layout'>,</span> <span class='hs-varid'>rhs_body'</span><span class='hs-layout'>,</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>scRecRhs</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-varid'>bndr'</span><span class='hs-layout'>,</span><span class='hs-varid'>rhs</span><span class='hs-layout'>)</span>
<a name="line-69"></a> <span class='hs-layout'>;</span> <span class='hs-keyword'>let</span> <span class='hs-varid'>rhs'</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkLams</span> <span class='hs-varid'>args'</span> <span class='hs-varid'>rhs_body'</span>
<a name="line-70"></a>
<a name="line-71"></a> <span class='hs-layout'>;</span> <span class='hs-keyword'>if</span> <span class='hs-varid'>not</span> <span class='hs-varid'>opt_SpecInlineJoinPoints</span> <span class='hs-varop'>||</span> <span class='hs-varid'>null</span> <span class='hs-varid'>args'</span> <span class='hs-varop'>||</span> <span class='hs-varid'>isEmptyVarEnv</span> <span class='hs-layout'>(</span><span class='hs-varid'>scu_calls</span> <span class='hs-varid'>rhs_usg</span><span class='hs-layout'>)</span> <span class='hs-keyword'>then</span> <span class='hs-keyword'>do</span>
<a name="line-72"></a> <span class='hs-keyword'>do</span> <span class='hs-layout'>{</span> <span class='hs-comment'>-- Vanilla case</span>
<a name="line-73"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>body_env2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendValEnv</span> <span class='hs-varid'>body_env</span> <span class='hs-varid'>bndr'</span> <span class='hs-layout'>(</span><span class='hs-varid'>isValue</span> <span class='hs-layout'>(</span><span class='hs-varid'>sc_vals</span> <span class='hs-varid'>env</span><span class='hs-layout'>)</span> <span class='hs-varid'>rhs'</span><span class='hs-layout'>)</span>
<a name="line-74"></a> <span class='hs-comment'>-- Record if the RHS is a value</span>
<a name="line-75"></a> <span class='hs-layout'>;</span> <span class='hs-layout'>(</span><span class='hs-varid'>body_usg</span><span class='hs-layout'>,</span> <span class='hs-varid'>body'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>scExpr</span> <span class='hs-varid'>body_env2</span> <span class='hs-varid'>body</span>
<a name="line-76"></a> <span class='hs-layout'>;</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>body_usg</span> <span class='hs-varop'>`combineUsage`</span> <span class='hs-varid'>rhs_usg</span><span class='hs-layout'>,</span> <span class='hs-conid'>Let</span> <span class='hs-layout'>(</span><span class='hs-conid'>NonRec</span> <span class='hs-varid'>bndr'</span> <span class='hs-varid'>rhs'</span><span class='hs-layout'>)</span> <span class='hs-varid'>body'</span><span class='hs-layout'>)</span> <span class='hs-layout'>}</span>
<a name="line-77"></a> <span class='hs-keyword'>else</span> <span class='hs-comment'>-- For now, just brutally inline the join point</span>
<a name="line-78"></a> <span class='hs-keyword'>do</span> <span class='hs-layout'>{</span> <span class='hs-keyword'>let</span> <span class='hs-varid'>body_env2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendScSubst</span> <span class='hs-varid'>env</span> <span class='hs-varid'>bndr</span> <span class='hs-varid'>rhs'</span>
<a name="line-79"></a> <span class='hs-layout'>;</span> <span class='hs-varid'>scExpr</span> <span class='hs-varid'>body_env2</span> <span class='hs-varid'>body</span> <span class='hs-layout'>}</span> <span class='hs-layout'>}</span>
<a name="line-80"></a>
<a name="line-81"></a>
<a name="line-82"></a><span class='hs-comment'>{- Old code
<a name="line-83"></a> do { -- Join-point case
<a name="line-84"></a> let body_env2 = extendHowBound body_env [bndr'] RecFun
<a name="line-85"></a> -- If the RHS of this 'let' contains calls
<a name="line-86"></a> -- to recursive functions that we're trying
<a name="line-87"></a> -- to specialise, then treat this let too
<a name="line-88"></a> -- as one to specialise
<a name="line-89"></a> ; (body_usg, body') <- scExpr body_env2 body
<a name="line-90"></a>
<a name="line-91"></a> ; (spec_usg, _, specs) <- specialise env (scu_calls body_usg) ([], rhs_info)
<a name="line-92"></a>
<a name="line-93"></a> ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
<a name="line-94"></a> `combineUsage` rhs_usg `combineUsage` spec_usg,
<a name="line-95"></a> mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body')
<a name="line-96"></a> }
<a name="line-97"></a>-}</span>
<a name="line-98"></a>
<a name="line-99"></a><span class='hs-comment'>-- A *local* recursive group: see Note [Local recursive groups]</span>
<a name="line-100"></a><span class='hs-definition'>scExpr'</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-conid'>Let</span> <span class='hs-layout'>(</span><span class='hs-conid'>Rec</span> <span class='hs-varid'>prs</span><span class='hs-layout'>)</span> <span class='hs-varid'>body</span><span class='hs-layout'>)</span>
<a name="line-101"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-layout'>{</span> <span class='hs-keyword'>let</span> <span class='hs-layout'>(</span><span class='hs-varid'>bndrs</span><span class='hs-layout'>,</span><span class='hs-varid'>rhss</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>unzip</span> <span class='hs-varid'>prs</span>
<a name="line-102"></a> <span class='hs-layout'>(</span><span class='hs-varid'>rhs_env1</span><span class='hs-layout'>,</span><span class='hs-varid'>bndrs'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendRecBndrs</span> <span class='hs-varid'>env</span> <span class='hs-varid'>bndrs</span>
<a name="line-103"></a> <span class='hs-varid'>rhs_env2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendHowBound</span> <span class='hs-varid'>rhs_env1</span> <span class='hs-varid'>bndrs'</span> <span class='hs-conid'>RecFun</span>
<a name="line-104"></a>
<a name="line-105"></a> <span class='hs-layout'>;</span> <span class='hs-layout'>(</span><span class='hs-varid'>rhs_usgs</span><span class='hs-layout'>,</span> <span class='hs-varid'>rhs_infos</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapAndUnzipM</span> <span class='hs-layout'>(</span><span class='hs-varid'>scRecRhs</span> <span class='hs-varid'>rhs_env2</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>bndrs'</span> <span class='hs-varop'>`zip`</span> <span class='hs-varid'>rhss</span><span class='hs-layout'>)</span>
<a name="line-106"></a> <span class='hs-layout'>;</span> <span class='hs-layout'>(</span><span class='hs-varid'>body_usg</span><span class='hs-layout'>,</span> <span class='hs-varid'>body'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>scExpr</span> <span class='hs-varid'>rhs_env2</span> <span class='hs-varid'>body</span>
<a name="line-107"></a>
<a name="line-108"></a> <span class='hs-comment'>-- NB: start specLoop from body_usg</span>
<a name="line-109"></a> <span class='hs-layout'>;</span> <span class='hs-layout'>(</span><span class='hs-varid'>spec_usg</span><span class='hs-layout'>,</span> <span class='hs-varid'>specs</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>specLoop</span> <span class='hs-varid'>rhs_env2</span> <span class='hs-layout'>(</span><span class='hs-varid'>scu_calls</span> <span class='hs-varid'>body_usg</span><span class='hs-layout'>)</span> <span class='hs-varid'>rhs_infos</span> <span class='hs-varid'>nullUsage</span>
<a name="line-110"></a> <span class='hs-keyglyph'>[</span><span class='hs-conid'>SI</span> <span class='hs-conid'>[]</span> <span class='hs-num'>0</span> <span class='hs-layout'>(</span><span class='hs-conid'>Just</span> <span class='hs-varid'>usg</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>usg</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>rhs_usgs</span><span class='hs-keyglyph'>]</span>
<a name="line-111"></a>
<a name="line-112"></a> <span class='hs-layout'>;</span> <span class='hs-keyword'>let</span> <span class='hs-varid'>all_usg</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>spec_usg</span> <span class='hs-varop'>`combineUsage`</span> <span class='hs-varid'>body_usg</span>
<a name="line-113"></a> <span class='hs-varid'>bind'</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Rec</span> <span class='hs-layout'>(</span><span class='hs-varid'>concat</span> <span class='hs-layout'>(</span><span class='hs-varid'>zipWith</span> <span class='hs-varid'>specInfoBinds</span> <span class='hs-varid'>rhs_infos</span> <span class='hs-varid'>specs</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-114"></a>
<a name="line-115"></a> <span class='hs-layout'>;</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>all_usg</span> <span class='hs-layout'>{</span> <span class='hs-varid'>scu_calls</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>scu_calls</span> <span class='hs-varid'>all_usg</span> <span class='hs-varop'>`delVarEnvList`</span> <span class='hs-varid'>bndrs'</span> <span class='hs-layout'>}</span><span class='hs-layout'>,</span>
<a name="line-116"></a> <span class='hs-conid'>Let</span> <span class='hs-varid'>bind'</span> <span class='hs-varid'>body'</span><span class='hs-layout'>)</span> <span class='hs-layout'>}</span>
<a name="line-117"></a>
<a name="line-118"></a><a name="scApp"></a><span class='hs-comment'>-----------------------------------</span>
<a name="line-119"></a><span class='hs-definition'>scApp</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ScEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>InExpr</span><span class='hs-layout'>,</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>InExpr</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>UniqSM</span> <span class='hs-layout'>(</span><span class='hs-conid'>ScUsage</span><span class='hs-layout'>,</span> <span class='hs-conid'>CoreExpr</span><span class='hs-layout'>)</span>
<a name="line-120"></a>
<a name="line-121"></a><span class='hs-definition'>scApp</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>fn</span><span class='hs-layout'>,</span> <span class='hs-varid'>args</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- Function is a variable</span>
<a name="line-122"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ASSERT</span><span class='hs-layout'>(</span> <span class='hs-varid'>not</span> <span class='hs-layout'>(</span><span class='hs-varid'>null</span> <span class='hs-varid'>args</span><span class='hs-layout'>)</span> <span class='hs-layout'>)</span>
<a name="line-123"></a> <span class='hs-keyword'>do</span> <span class='hs-layout'>{</span> <span class='hs-varid'>args_w_usgs</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapM</span> <span class='hs-layout'>(</span><span class='hs-varid'>scExpr</span> <span class='hs-varid'>env</span><span class='hs-layout'>)</span> <span class='hs-varid'>args</span>
<a name="line-124"></a> <span class='hs-layout'>;</span> <span class='hs-keyword'>let</span> <span class='hs-layout'>(</span><span class='hs-varid'>arg_usgs</span><span class='hs-layout'>,</span> <span class='hs-varid'>args'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>unzip</span> <span class='hs-varid'>args_w_usgs</span>
<a name="line-125"></a> <span class='hs-varid'>arg_usg</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>combineUsages</span> <span class='hs-varid'>arg_usgs</span>
<a name="line-126"></a> <span class='hs-layout'>;</span> <span class='hs-keyword'>case</span> <span class='hs-varid'>scSubstId</span> <span class='hs-varid'>env</span> <span class='hs-varid'>fn</span> <span class='hs-keyword'>of</span>
<a name="line-127"></a> <span class='hs-varid'>fn'</span><span class='hs-keyglyph'>@</span><span class='hs-layout'>(</span><span class='hs-conid'>Lam</span> <span class='hs-layout'>{</span><span class='hs-layout'>}</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>scExpr</span> <span class='hs-layout'>(</span><span class='hs-varid'>zapScSubst</span> <span class='hs-varid'>env</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>doBeta</span> <span class='hs-varid'>fn'</span> <span class='hs-varid'>args'</span><span class='hs-layout'>)</span>
<a name="line-128"></a> <span class='hs-comment'>-- Do beta-reduction and try again</span>
<a name="line-129"></a>
<a name="line-130"></a> <span class='hs-conid'>Var</span> <span class='hs-varid'>fn'</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>arg_usg</span> <span class='hs-varop'>`combineUsage`</span> <span class='hs-varid'>fn_usg</span><span class='hs-layout'>,</span> <span class='hs-varid'>mkApps</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>fn'</span><span class='hs-layout'>)</span> <span class='hs-varid'>args'</span><span class='hs-layout'>)</span>
<a name="line-131"></a> <span class='hs-keyword'>where</span>
<a name="line-132"></a> <span class='hs-varid'>fn_usg</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>case</span> <span class='hs-varid'>lookupHowBound</span> <span class='hs-varid'>env</span> <span class='hs-varid'>fn'</span> <span class='hs-keyword'>of</span>
<a name="line-133"></a> <span class='hs-conid'>Just</span> <span class='hs-conid'>RecFun</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>SCU</span> <span class='hs-layout'>{</span> <span class='hs-varid'>scu_calls</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>unitVarEnv</span> <span class='hs-varid'>fn'</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>sc_vals</span> <span class='hs-varid'>env</span><span class='hs-layout'>,</span> <span class='hs-varid'>args'</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span>
<a name="line-134"></a> <span class='hs-varid'>scu_occs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>emptyVarEnv</span> <span class='hs-layout'>}</span>
<a name="line-135"></a> <span class='hs-conid'>Just</span> <span class='hs-conid'>RecArg</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>SCU</span> <span class='hs-layout'>{</span> <span class='hs-varid'>scu_calls</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>emptyVarEnv</span><span class='hs-layout'>,</span>
<a name="line-136"></a> <span class='hs-varid'>scu_occs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>unitVarEnv</span> <span class='hs-varid'>fn'</span> <span class='hs-layout'>(</span><span class='hs-conid'>ScrutOcc</span> <span class='hs-varid'>emptyUFM</span><span class='hs-layout'>)</span> <span class='hs-layout'>}</span>
<a name="line-137"></a> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>nullUsage</span>
<a name="line-138"></a>
<a name="line-139"></a>
<a name="line-140"></a> <span class='hs-varid'>other_fn'</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>arg_usg</span><span class='hs-layout'>,</span> <span class='hs-varid'>mkApps</span> <span class='hs-varid'>other_fn'</span> <span class='hs-varid'>args'</span><span class='hs-layout'>)</span> <span class='hs-layout'>}</span>
<a name="line-141"></a> <span class='hs-comment'>-- NB: doing this ignores any usage info from the substituted</span>
<a name="line-142"></a> <span class='hs-comment'>-- function, but I don't think that matters. If it does</span>
<a name="line-143"></a> <span class='hs-comment'>-- we can fix it.</span>
<a name="line-144"></a> <span class='hs-keyword'>where</span>
<a name="line-145"></a> <span class='hs-varid'>doBeta</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>OutExpr</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>OutExpr</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>OutExpr</span>
<a name="line-146"></a> <span class='hs-comment'>-- ToDo: adjust for System IF</span>
<a name="line-147"></a> <span class='hs-varid'>doBeta</span> <span class='hs-layout'>(</span><span class='hs-conid'>Lam</span> <span class='hs-varid'>bndr</span> <span class='hs-varid'>body</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>arg</span> <span class='hs-conop'>:</span> <span class='hs-varid'>args</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Let</span> <span class='hs-layout'>(</span><span class='hs-conid'>NonRec</span> <span class='hs-varid'>bndr</span> <span class='hs-varid'>arg</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>doBeta</span> <span class='hs-varid'>body</span> <span class='hs-varid'>args</span><span class='hs-layout'>)</span>
<a name="line-148"></a> <span class='hs-varid'>doBeta</span> <span class='hs-varid'>fn</span> <span class='hs-varid'>args</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkApps</span> <span class='hs-varid'>fn</span> <span class='hs-varid'>args</span>
<a name="line-149"></a>
<a name="line-150"></a><span class='hs-comment'>-- The function is almost always a variable, but not always. </span>
<a name="line-151"></a><span class='hs-comment'>-- In particular, if this pass follows float-in,</span>
<a name="line-152"></a><span class='hs-comment'>-- which it may, we can get </span>
<a name="line-153"></a><span class='hs-comment'>-- (let f = ...f... in f) arg1 arg2</span>
<a name="line-154"></a><span class='hs-definition'>scApp</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-varid'>other_fn</span><span class='hs-layout'>,</span> <span class='hs-varid'>args</span><span class='hs-layout'>)</span>
<a name="line-155"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-layout'>{</span> <span class='hs-layout'>(</span><span class='hs-varid'>fn_usg</span><span class='hs-layout'>,</span> <span class='hs-varid'>fn'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>scExpr</span> <span class='hs-varid'>env</span> <span class='hs-varid'>other_fn</span>
<a name="line-156"></a> <span class='hs-layout'>;</span> <span class='hs-layout'>(</span><span class='hs-varid'>arg_usgs</span><span class='hs-layout'>,</span> <span class='hs-varid'>args'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapAndUnzipM</span> <span class='hs-layout'>(</span><span class='hs-varid'>scExpr</span> <span class='hs-varid'>env</span><span class='hs-layout'>)</span> <span class='hs-varid'>args</span>
<a name="line-157"></a> <span class='hs-layout'>;</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>combineUsages</span> <span class='hs-varid'>arg_usgs</span> <span class='hs-varop'>`combineUsage`</span> <span class='hs-varid'>fn_usg</span><span class='hs-layout'>,</span> <span class='hs-varid'>mkApps</span> <span class='hs-varid'>fn'</span> <span class='hs-varid'>args'</span><span class='hs-layout'>)</span> <span class='hs-layout'>}</span>
<a name="line-158"></a>
<a name="line-159"></a><a name="scTopBind"></a><span class='hs-comment'>----------------------</span>
<a name="line-160"></a><span class='hs-definition'>scTopBind</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ScEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreBind</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>UniqSM</span> <span class='hs-layout'>(</span><span class='hs-conid'>ScEnv</span><span class='hs-layout'>,</span> <span class='hs-conid'>CoreBind</span><span class='hs-layout'>)</span>
<a name="line-161"></a><span class='hs-definition'>scTopBind</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-conid'>Rec</span> <span class='hs-varid'>prs</span><span class='hs-layout'>)</span>
<a name="line-162"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>Just</span> <span class='hs-varid'>threshold</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>sc_size</span> <span class='hs-varid'>env</span>
<a name="line-163"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>not</span> <span class='hs-layout'>(</span><span class='hs-varid'>all</span> <span class='hs-layout'>(</span><span class='hs-varid'>couldBeSmallEnoughToInline</span> <span class='hs-varid'>threshold</span><span class='hs-layout'>)</span> <span class='hs-varid'>rhss</span><span class='hs-layout'>)</span>
<a name="line-164"></a> <span class='hs-comment'>-- No specialisation</span>
<a name="line-165"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-layout'>{</span> <span class='hs-keyword'>let</span> <span class='hs-layout'>(</span><span class='hs-varid'>rhs_env</span><span class='hs-layout'>,</span><span class='hs-varid'>bndrs'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendRecBndrs</span> <span class='hs-varid'>env</span> <span class='hs-varid'>bndrs</span>
<a name="line-166"></a> <span class='hs-layout'>;</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-varid'>rhss'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapAndUnzipM</span> <span class='hs-layout'>(</span><span class='hs-varid'>scExpr</span> <span class='hs-varid'>rhs_env</span><span class='hs-layout'>)</span> <span class='hs-varid'>rhss</span>
<a name="line-167"></a> <span class='hs-layout'>;</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>rhs_env</span><span class='hs-layout'>,</span> <span class='hs-conid'>Rec</span> <span class='hs-layout'>(</span><span class='hs-varid'>bndrs'</span> <span class='hs-varop'>`zip`</span> <span class='hs-varid'>rhss'</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-layout'>}</span>
<a name="line-168"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-comment'>-- Do specialisation</span>
<a name="line-169"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-layout'>{</span> <span class='hs-keyword'>let</span> <span class='hs-layout'>(</span><span class='hs-varid'>rhs_env1</span><span class='hs-layout'>,</span><span class='hs-varid'>bndrs'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendRecBndrs</span> <span class='hs-varid'>env</span> <span class='hs-varid'>bndrs</span>
<a name="line-170"></a> <span class='hs-varid'>rhs_env2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendHowBound</span> <span class='hs-varid'>rhs_env1</span> <span class='hs-varid'>bndrs'</span> <span class='hs-conid'>RecFun</span>
<a name="line-171"></a>
<a name="line-172"></a> <span class='hs-layout'>;</span> <span class='hs-layout'>(</span><span class='hs-varid'>rhs_usgs</span><span class='hs-layout'>,</span> <span class='hs-varid'>rhs_infos</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapAndUnzipM</span> <span class='hs-layout'>(</span><span class='hs-varid'>scRecRhs</span> <span class='hs-varid'>rhs_env2</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>bndrs'</span> <span class='hs-varop'>`zip`</span> <span class='hs-varid'>rhss</span><span class='hs-layout'>)</span>
<a name="line-173"></a> <span class='hs-layout'>;</span> <span class='hs-keyword'>let</span> <span class='hs-varid'>rhs_usg</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>combineUsages</span> <span class='hs-varid'>rhs_usgs</span>
<a name="line-174"></a>
<a name="line-175"></a> <span class='hs-layout'>;</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-varid'>specs</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>specLoop</span> <span class='hs-varid'>rhs_env2</span> <span class='hs-layout'>(</span><span class='hs-varid'>scu_calls</span> <span class='hs-varid'>rhs_usg</span><span class='hs-layout'>)</span> <span class='hs-varid'>rhs_infos</span> <span class='hs-varid'>nullUsage</span>
<a name="line-176"></a> <span class='hs-keyglyph'>[</span><span class='hs-conid'>SI</span> <span class='hs-conid'>[]</span> <span class='hs-num'>0</span> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>|</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>bndrs</span><span class='hs-keyglyph'>]</span>
<a name="line-177"></a>
<a name="line-178"></a> <span class='hs-layout'>;</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>rhs_env1</span><span class='hs-layout'>,</span> <span class='hs-comment'>-- For the body of the letrec, delete the RecFun business</span>
<a name="line-179"></a> <span class='hs-conid'>Rec</span> <span class='hs-layout'>(</span><span class='hs-varid'>concat</span> <span class='hs-layout'>(</span><span class='hs-varid'>zipWith</span> <span class='hs-varid'>specInfoBinds</span> <span class='hs-varid'>rhs_infos</span> <span class='hs-varid'>specs</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-layout'>}</span>
<a name="line-180"></a> <span class='hs-keyword'>where</span>
<a name="line-181"></a> <span class='hs-layout'>(</span><span class='hs-varid'>bndrs</span><span class='hs-layout'>,</span><span class='hs-varid'>rhss</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>unzip</span> <span class='hs-varid'>prs</span>
<a name="line-182"></a>
<a name="line-183"></a><span class='hs-definition'>scTopBind</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-conid'>NonRec</span> <span class='hs-varid'>bndr</span> <span class='hs-varid'>rhs</span><span class='hs-layout'>)</span>
<a name="line-184"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-layout'>{</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-varid'>rhs'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>scExpr</span> <span class='hs-varid'>env</span> <span class='hs-varid'>rhs</span>
<a name="line-185"></a> <span class='hs-layout'>;</span> <span class='hs-keyword'>let</span> <span class='hs-layout'>(</span><span class='hs-varid'>env1</span><span class='hs-layout'>,</span> <span class='hs-varid'>bndr'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendBndr</span> <span class='hs-varid'>env</span> <span class='hs-varid'>bndr</span>
<a name="line-186"></a> <span class='hs-varid'>env2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendValEnv</span> <span class='hs-varid'>env1</span> <span class='hs-varid'>bndr'</span> <span class='hs-layout'>(</span><span class='hs-varid'>isValue</span> <span class='hs-layout'>(</span><span class='hs-varid'>sc_vals</span> <span class='hs-varid'>env</span><span class='hs-layout'>)</span> <span class='hs-varid'>rhs'</span><span class='hs-layout'>)</span>
<a name="line-187"></a> <span class='hs-layout'>;</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>env2</span><span class='hs-layout'>,</span> <span class='hs-conid'>NonRec</span> <span class='hs-varid'>bndr'</span> <span class='hs-varid'>rhs'</span><span class='hs-layout'>)</span> <span class='hs-layout'>}</span>
<a name="line-188"></a>
<a name="line-189"></a><a name="scRecRhs"></a><span class='hs-comment'>----------------------</span>
<a name="line-190"></a><span class='hs-definition'>scRecRhs</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ScEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>OutId</span><span class='hs-layout'>,</span> <span class='hs-conid'>InExpr</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>UniqSM</span> <span class='hs-layout'>(</span><span class='hs-conid'>ScUsage</span><span class='hs-layout'>,</span> <span class='hs-conid'>RhsInfo</span><span class='hs-layout'>)</span>
<a name="line-191"></a><span class='hs-definition'>scRecRhs</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-varid'>bndr</span><span class='hs-layout'>,</span><span class='hs-varid'>rhs</span><span class='hs-layout'>)</span>
<a name="line-192"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-layout'>{</span> <span class='hs-keyword'>let</span> <span class='hs-layout'>(</span><span class='hs-varid'>arg_bndrs</span><span class='hs-layout'>,</span><span class='hs-varid'>body</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>collectBinders</span> <span class='hs-varid'>rhs</span>
<a name="line-193"></a> <span class='hs-layout'>(</span><span class='hs-varid'>body_env</span><span class='hs-layout'>,</span> <span class='hs-varid'>arg_bndrs'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendBndrsWith</span> <span class='hs-conid'>RecArg</span> <span class='hs-varid'>env</span> <span class='hs-varid'>arg_bndrs</span>
<a name="line-194"></a> <span class='hs-layout'>;</span> <span class='hs-layout'>(</span><span class='hs-varid'>body_usg</span><span class='hs-layout'>,</span> <span class='hs-varid'>body'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>scExpr</span> <span class='hs-varid'>body_env</span> <span class='hs-varid'>body</span>
<a name="line-195"></a> <span class='hs-layout'>;</span> <span class='hs-keyword'>let</span> <span class='hs-layout'>(</span><span class='hs-varid'>rhs_usg</span><span class='hs-layout'>,</span> <span class='hs-varid'>arg_occs</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>lookupOccs</span> <span class='hs-varid'>body_usg</span> <span class='hs-varid'>arg_bndrs'</span>
<a name="line-196"></a> <span class='hs-layout'>;</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>rhs_usg</span><span class='hs-layout'>,</span> <span class='hs-layout'>(</span><span class='hs-varid'>bndr</span><span class='hs-layout'>,</span> <span class='hs-varid'>arg_bndrs'</span><span class='hs-layout'>,</span> <span class='hs-varid'>body'</span><span class='hs-layout'>,</span> <span class='hs-varid'>arg_occs</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-layout'>}</span>
<a name="line-197"></a>
<a name="line-198"></a> <span class='hs-comment'>-- The arg_occs says how the visible,</span>
<a name="line-199"></a> <span class='hs-comment'>-- lambda-bound binders of the RHS are used</span>
<a name="line-200"></a> <span class='hs-comment'>-- (including the TyVar binders)</span>
<a name="line-201"></a> <span class='hs-comment'>-- Two pats are the same if they match both ways</span>
<a name="line-202"></a>
<a name="line-203"></a><a name="specInfoBinds"></a><span class='hs-comment'>----------------------</span>
<a name="line-204"></a><span class='hs-definition'>specInfoBinds</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>RhsInfo</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>SpecInfo</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>Id</span><span class='hs-layout'>,</span><span class='hs-conid'>CoreExpr</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-205"></a><span class='hs-definition'>specInfoBinds</span> <span class='hs-layout'>(</span><span class='hs-varid'>fn</span><span class='hs-layout'>,</span> <span class='hs-varid'>args</span><span class='hs-layout'>,</span> <span class='hs-varid'>body</span><span class='hs-layout'>,</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>SI</span> <span class='hs-varid'>specs</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span>
<a name="line-206"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>id</span><span class='hs-layout'>,</span><span class='hs-varid'>rhs</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>OS</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>id</span> <span class='hs-varid'>rhs</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>specs</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'>++</span>
<a name="line-207"></a> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>fn</span> <span class='hs-varop'>`addIdSpecialisations`</span> <span class='hs-varid'>rules</span><span class='hs-layout'>,</span> <span class='hs-varid'>mkLams</span> <span class='hs-varid'>args</span> <span class='hs-varid'>body</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-208"></a> <span class='hs-keyword'>where</span>
<a name="line-209"></a> <span class='hs-varid'>rules</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>r</span> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>OS</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>r</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>specs</span><span class='hs-keyglyph'>]</span>
<a name="line-210"></a>
<a name="line-211"></a><a name="varUsage"></a><span class='hs-comment'>----------------------</span>
<a name="line-212"></a><span class='hs-definition'>varUsage</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ScEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>OutVar</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ArgOcc</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ScUsage</span>
<a name="line-213"></a><span class='hs-definition'>varUsage</span> <span class='hs-varid'>env</span> <span class='hs-varid'>v</span> <span class='hs-varid'>use</span>
<a name="line-214"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>Just</span> <span class='hs-conid'>RecArg</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lookupHowBound</span> <span class='hs-varid'>env</span> <span class='hs-varid'>v</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>SCU</span> <span class='hs-layout'>{</span> <span class='hs-varid'>scu_calls</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>emptyVarEnv</span>
<a name="line-215"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>scu_occs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>unitVarEnv</span> <span class='hs-varid'>v</span> <span class='hs-varid'>use</span> <span class='hs-layout'>}</span>
<a name="line-216"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nullUsage</span>
</pre>\end{code}
%************************************************************************
%* *
The specialiser itself
%* *
%************************************************************************
\begin{code}
<pre><a name="line-1"></a><a name="RhsInfo"></a><span class='hs-keyword'>type</span> <span class='hs-conid'>RhsInfo</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-conid'>OutId</span><span class='hs-layout'>,</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>OutVar</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-conid'>OutExpr</span><span class='hs-layout'>,</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>ArgOcc</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-2"></a> <span class='hs-comment'>-- Info about the *original* RHS of a binding we are specialising</span>
<a name="line-3"></a> <span class='hs-comment'>-- Original binding f = \xs.body</span>
<a name="line-4"></a> <span class='hs-comment'>-- Plus info about usage of arguments</span>
<a name="line-5"></a>
<a name="line-6"></a><a name="SpecInfo"></a><span class='hs-keyword'>data</span> <span class='hs-conid'>SpecInfo</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>SI</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>OneSpec</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- The specialisations we have generated</span>
<a name="line-7"></a> <span class='hs-conid'>Int</span> <span class='hs-comment'>-- Length of specs; used for numbering them</span>
<a name="line-8"></a> <span class='hs-layout'>(</span><span class='hs-conid'>Maybe</span> <span class='hs-conid'>ScUsage</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- Nothing => we have generated specialisations</span>
<a name="line-9"></a> <span class='hs-comment'>-- from calls in the *original* RHS</span>
<a name="line-10"></a> <span class='hs-comment'>-- Just cs => we haven't, and this is the usage</span>
<a name="line-11"></a> <span class='hs-comment'>-- of the original RHS</span>
<a name="line-12"></a>
<a name="line-13"></a> <span class='hs-comment'>-- One specialisation: Rule plus definition</span>
<a name="line-14"></a><a name="OneSpec"></a><span class='hs-keyword'>data</span> <span class='hs-conid'>OneSpec</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>OS</span> <span class='hs-conid'>CallPat</span> <span class='hs-comment'>-- Call pattern that generated this specialisation</span>
<a name="line-15"></a> <span class='hs-conid'>CoreRule</span> <span class='hs-comment'>-- Rule connecting original id with the specialisation</span>
<a name="line-16"></a> <span class='hs-conid'>OutId</span> <span class='hs-conid'>OutExpr</span> <span class='hs-comment'>-- Spec id + its rhs</span>
<a name="line-17"></a>
<a name="line-18"></a>
<a name="line-19"></a><a name="specLoop"></a><span class='hs-definition'>specLoop</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ScEnv</span>
<a name="line-20"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CallEnv</span>
<a name="line-21"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>RhsInfo</span><span class='hs-keyglyph'>]</span>
<a name="line-22"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ScUsage</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>SpecInfo</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- One per binder; acccumulating parameter</span>
<a name="line-23"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>UniqSM</span> <span class='hs-layout'>(</span><span class='hs-conid'>ScUsage</span><span class='hs-layout'>,</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>SpecInfo</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- ...ditto...</span>
<a name="line-24"></a><span class='hs-definition'>specLoop</span> <span class='hs-varid'>env</span> <span class='hs-varid'>all_calls</span> <span class='hs-varid'>rhs_infos</span> <span class='hs-varid'>usg_so_far</span> <span class='hs-varid'>specs_so_far</span>
<a name="line-25"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-layout'>{</span> <span class='hs-varid'>specs_w_usg</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>zipWithM</span> <span class='hs-layout'>(</span><span class='hs-varid'>specialise</span> <span class='hs-varid'>env</span> <span class='hs-varid'>all_calls</span><span class='hs-layout'>)</span> <span class='hs-varid'>rhs_infos</span> <span class='hs-varid'>specs_so_far</span>
<a name="line-26"></a> <span class='hs-layout'>;</span> <span class='hs-keyword'>let</span> <span class='hs-layout'>(</span><span class='hs-varid'>new_usg_s</span><span class='hs-layout'>,</span> <span class='hs-varid'>all_specs</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>unzip</span> <span class='hs-varid'>specs_w_usg</span>
<a name="line-27"></a> <span class='hs-varid'>new_usg</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>combineUsages</span> <span class='hs-varid'>new_usg_s</span>
<a name="line-28"></a> <span class='hs-varid'>new_calls</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>scu_calls</span> <span class='hs-varid'>new_usg</span>
<a name="line-29"></a> <span class='hs-varid'>all_usg</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>usg_so_far</span> <span class='hs-varop'>`combineUsage`</span> <span class='hs-varid'>new_usg</span>
<a name="line-30"></a> <span class='hs-layout'>;</span> <span class='hs-keyword'>if</span> <span class='hs-varid'>isEmptyVarEnv</span> <span class='hs-varid'>new_calls</span> <span class='hs-keyword'>then</span>
<a name="line-31"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>all_usg</span><span class='hs-layout'>,</span> <span class='hs-varid'>all_specs</span><span class='hs-layout'>)</span>
<a name="line-32"></a> <span class='hs-keyword'>else</span>
<a name="line-33"></a> <span class='hs-varid'>specLoop</span> <span class='hs-varid'>env</span> <span class='hs-varid'>new_calls</span> <span class='hs-varid'>rhs_infos</span> <span class='hs-varid'>all_usg</span> <span class='hs-varid'>all_specs</span> <span class='hs-layout'>}</span>
<a name="line-34"></a>
<a name="line-35"></a><a name="specialise"></a><span class='hs-definition'>specialise</span>
<a name="line-36"></a> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ScEnv</span>
<a name="line-37"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CallEnv</span> <span class='hs-comment'>-- Info on calls</span>
<a name="line-38"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>RhsInfo</span>
<a name="line-39"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>SpecInfo</span> <span class='hs-comment'>-- Original RHS plus patterns dealt with</span>
<a name="line-40"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>UniqSM</span> <span class='hs-layout'>(</span><span class='hs-conid'>ScUsage</span><span class='hs-layout'>,</span> <span class='hs-conid'>SpecInfo</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- New specialised versions and their usage</span>
<a name="line-41"></a>
<a name="line-42"></a><span class='hs-comment'>-- Note: the rhs here is the optimised version of the original rhs</span>
<a name="line-43"></a><span class='hs-comment'>-- So when we make a specialised copy of the RHS, we're starting</span>
<a name="line-44"></a><span class='hs-comment'>-- from an RHS whose nested functions have been optimised already.</span>
<a name="line-45"></a>
<a name="line-46"></a><span class='hs-definition'>specialise</span> <span class='hs-varid'>env</span> <span class='hs-varid'>bind_calls</span> <span class='hs-layout'>(</span><span class='hs-varid'>fn</span><span class='hs-layout'>,</span> <span class='hs-varid'>arg_bndrs</span><span class='hs-layout'>,</span> <span class='hs-varid'>body</span><span class='hs-layout'>,</span> <span class='hs-varid'>arg_occs</span><span class='hs-layout'>)</span>
<a name="line-47"></a> <span class='hs-varid'>spec_info</span><span class='hs-keyglyph'>@</span><span class='hs-layout'>(</span><span class='hs-conid'>SI</span> <span class='hs-varid'>specs</span> <span class='hs-varid'>spec_count</span> <span class='hs-varid'>mb_unspec</span><span class='hs-layout'>)</span>
<a name="line-48"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>not</span> <span class='hs-layout'>(</span><span class='hs-varid'>isBottomingId</span> <span class='hs-varid'>fn</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- Note [Do not specialise diverging functions]</span>
<a name="line-49"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>notNull</span> <span class='hs-varid'>arg_bndrs</span> <span class='hs-comment'>-- Only specialise functions</span>
<a name="line-50"></a> <span class='hs-layout'>,</span> <span class='hs-conid'>Just</span> <span class='hs-varid'>all_calls</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lookupVarEnv</span> <span class='hs-varid'>bind_calls</span> <span class='hs-varid'>fn</span>
<a name="line-51"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-layout'>{</span> <span class='hs-layout'>(</span><span class='hs-varid'>boring_call</span><span class='hs-layout'>,</span> <span class='hs-varid'>pats</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>callsToPats</span> <span class='hs-varid'>env</span> <span class='hs-varid'>specs</span> <span class='hs-varid'>arg_occs</span> <span class='hs-varid'>all_calls</span>
<a name="line-52"></a><span class='hs-comment'>-- ; pprTrace "specialise" (vcat [ppr fn <+> ppr arg_occs,</span>
<a name="line-53"></a><span class='hs-comment'>-- text "calls" <+> ppr all_calls,</span>
<a name="line-54"></a><span class='hs-comment'>-- text "good pats" <+> ppr pats]) $</span>
<a name="line-55"></a><span class='hs-comment'>-- return ()</span>
<a name="line-56"></a>
<a name="line-57"></a> <span class='hs-comment'>-- Bale out if too many specialisations</span>
<a name="line-58"></a> <span class='hs-comment'>-- Rather a hacky way to do so, but it'll do for now</span>
<a name="line-59"></a> <span class='hs-layout'>;</span> <span class='hs-keyword'>let</span> <span class='hs-varid'>spec_count'</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>length</span> <span class='hs-varid'>pats</span> <span class='hs-varop'>+</span> <span class='hs-varid'>spec_count</span>
<a name="line-60"></a> <span class='hs-layout'>;</span> <span class='hs-keyword'>case</span> <span class='hs-varid'>sc_count</span> <span class='hs-varid'>env</span> <span class='hs-keyword'>of</span>
<a name="line-61"></a> <span class='hs-conid'>Just</span> <span class='hs-varid'>max</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>spec_count'</span> <span class='hs-varop'>></span> <span class='hs-varid'>max</span>
<a name="line-62"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>WARN</span><span class='hs-layout'>(</span> <span class='hs-conid'>True</span><span class='hs-layout'>,</span> <span class='hs-varid'>msg</span> <span class='hs-layout'>)</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>nullUsage</span><span class='hs-layout'>,</span> <span class='hs-varid'>spec_info</span><span class='hs-layout'>)</span>
<a name="line-63"></a> <span class='hs-keyword'>where</span>
<a name="line-64"></a> <span class='hs-varid'>msg</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>vcat</span> <span class='hs-keyglyph'>[</span> <span class='hs-varid'>sep</span> <span class='hs-keyglyph'>[</span> <span class='hs-varid'>ptext</span> <span class='hs-layout'>(</span><span class='hs-varid'>sLit</span> <span class='hs-str'>"SpecConstr: specialisation of"</span><span class='hs-layout'>)</span> <span class='hs-varop'><+></span> <span class='hs-varid'>quotes</span> <span class='hs-layout'>(</span><span class='hs-varid'>ppr</span> <span class='hs-varid'>fn</span><span class='hs-layout'>)</span>
<a name="line-65"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>nest</span> <span class='hs-num'>2</span> <span class='hs-layout'>(</span><span class='hs-varid'>ptext</span> <span class='hs-layout'>(</span><span class='hs-varid'>sLit</span> <span class='hs-str'>"limited by bound of"</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-varop'><+></span> <span class='hs-varid'>int</span> <span class='hs-varid'>max</span> <span class='hs-keyglyph'>]</span>
<a name="line-66"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>ptext</span> <span class='hs-layout'>(</span><span class='hs-varid'>sLit</span> <span class='hs-str'>"Use -fspec-constr-count=n to set the bound"</span><span class='hs-layout'>)</span>
<a name="line-67"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>extra</span> <span class='hs-keyglyph'>]</span>
<a name="line-68"></a> <span class='hs-varid'>extra</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>not</span> <span class='hs-varid'>opt_PprStyle_Debug</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>ptext</span> <span class='hs-layout'>(</span><span class='hs-varid'>sLit</span> <span class='hs-str'>"Use -dppr-debug to see specialisations"</span><span class='hs-layout'>)</span>
<a name="line-69"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>ptext</span> <span class='hs-layout'>(</span><span class='hs-varid'>sLit</span> <span class='hs-str'>"Specialisations:"</span><span class='hs-layout'>)</span> <span class='hs-varop'><+></span> <span class='hs-varid'>ppr</span> <span class='hs-layout'>(</span><span class='hs-varid'>pats</span> <span class='hs-varop'>++</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>p</span> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>OS</span> <span class='hs-varid'>p</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>specs</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-70"></a>
<a name="line-71"></a> <span class='hs-sel'>_normal_case</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>do</span> <span class='hs-layout'>{</span>
<a name="line-72"></a>
<a name="line-73"></a> <span class='hs-layout'>(</span><span class='hs-varid'>spec_usgs</span><span class='hs-layout'>,</span> <span class='hs-varid'>new_specs</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapAndUnzipM</span> <span class='hs-layout'>(</span><span class='hs-varid'>spec_one</span> <span class='hs-varid'>env</span> <span class='hs-varid'>fn</span> <span class='hs-varid'>arg_bndrs</span> <span class='hs-varid'>body</span><span class='hs-layout'>)</span>
<a name="line-74"></a> <span class='hs-layout'>(</span><span class='hs-varid'>pats</span> <span class='hs-varop'>`zip`</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>spec_count</span><span class='hs-keyglyph'>..</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-75"></a>
<a name="line-76"></a> <span class='hs-layout'>;</span> <span class='hs-keyword'>let</span> <span class='hs-varid'>spec_usg</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>combineUsages</span> <span class='hs-varid'>spec_usgs</span>
<a name="line-77"></a> <span class='hs-layout'>(</span><span class='hs-varid'>new_usg</span><span class='hs-layout'>,</span> <span class='hs-varid'>mb_unspec'</span><span class='hs-layout'>)</span>
<a name="line-78"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>case</span> <span class='hs-varid'>mb_unspec</span> <span class='hs-keyword'>of</span>
<a name="line-79"></a> <span class='hs-conid'>Just</span> <span class='hs-varid'>rhs_usg</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>boring_call</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-varid'>spec_usg</span> <span class='hs-varop'>`combineUsage`</span> <span class='hs-varid'>rhs_usg</span><span class='hs-layout'>,</span> <span class='hs-conid'>Nothing</span><span class='hs-layout'>)</span>
<a name="line-80"></a> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-varid'>spec_usg</span><span class='hs-layout'>,</span> <span class='hs-varid'>mb_unspec</span><span class='hs-layout'>)</span>
<a name="line-81"></a>
<a name="line-82"></a> <span class='hs-layout'>;</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>new_usg</span><span class='hs-layout'>,</span> <span class='hs-conid'>SI</span> <span class='hs-layout'>(</span><span class='hs-varid'>new_specs</span> <span class='hs-varop'>++</span> <span class='hs-varid'>specs</span><span class='hs-layout'>)</span> <span class='hs-varid'>spec_count'</span> <span class='hs-varid'>mb_unspec'</span><span class='hs-layout'>)</span> <span class='hs-layout'>}</span> <span class='hs-layout'>}</span>
<a name="line-83"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span>
<a name="line-84"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>nullUsage</span><span class='hs-layout'>,</span> <span class='hs-varid'>spec_info</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- The boring case</span>
<a name="line-85"></a>
<a name="line-86"></a>
<a name="line-87"></a><a name="spec_one"></a><span class='hs-comment'>---------------------</span>
<a name="line-88"></a><span class='hs-definition'>spec_one</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ScEnv</span>
<a name="line-89"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>OutId</span> <span class='hs-comment'>-- Function</span>
<a name="line-90"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Var</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- Lambda-binders of RHS; should match patterns</span>
<a name="line-91"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span> <span class='hs-comment'>-- Body of the original function</span>
<a name="line-92"></a> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>CallPat</span><span class='hs-layout'>,</span> <span class='hs-conid'>Int</span><span class='hs-layout'>)</span>
<a name="line-93"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>UniqSM</span> <span class='hs-layout'>(</span><span class='hs-conid'>ScUsage</span><span class='hs-layout'>,</span> <span class='hs-conid'>OneSpec</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- Rule and binding</span>
<a name="line-94"></a>
<a name="line-95"></a><span class='hs-comment'>-- spec_one creates a specialised copy of the function, together</span>
<a name="line-96"></a><span class='hs-comment'>-- with a rule for using it. I'm very proud of how short this</span>
<a name="line-97"></a><span class='hs-comment'>-- function is, considering what it does :-).</span>
<a name="line-98"></a>
<a name="line-99"></a><span class='hs-comment'>{-
<a name="line-100"></a> Example
<a name="line-101"></a>
<a name="line-102"></a> In-scope: a, x::a
<a name="line-103"></a> f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
<a name="line-104"></a> [c::*, v::(b,c) are presumably bound by the (...) part]
<a name="line-105"></a> ==>
<a name="line-106"></a> f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
<a name="line-107"></a> (...entire body of f...) [b -> (b,c),
<a name="line-108"></a> y -> ((:) (a,(b,c)) (x,v) hw)]
<a name="line-109"></a>
<a name="line-110"></a> RULE: forall b::* c::*, -- Note, *not* forall a, x
<a name="line-111"></a> v::(b,c),
<a name="line-112"></a> hw::[(a,(b,c))] .
<a name="line-113"></a>
<a name="line-114"></a> f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
<a name="line-115"></a>-}</span>
<a name="line-116"></a>
<a name="line-117"></a><span class='hs-definition'>spec_one</span> <span class='hs-varid'>env</span> <span class='hs-varid'>fn</span> <span class='hs-varid'>arg_bndrs</span> <span class='hs-varid'>body</span> <span class='hs-layout'>(</span><span class='hs-varid'>call_pat</span><span class='hs-keyglyph'>@</span><span class='hs-layout'>(</span><span class='hs-varid'>qvars</span><span class='hs-layout'>,</span> <span class='hs-varid'>pats</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-varid'>rule_number</span><span class='hs-layout'>)</span>
<a name="line-118"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-layout'>{</span> <span class='hs-comment'>-- Specialise the body</span>
<a name="line-119"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>spec_env</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendScSubstList</span> <span class='hs-layout'>(</span><span class='hs-varid'>extendScInScope</span> <span class='hs-varid'>env</span> <span class='hs-varid'>qvars</span><span class='hs-layout'>)</span>
<a name="line-120"></a> <span class='hs-layout'>(</span><span class='hs-varid'>arg_bndrs</span> <span class='hs-varop'>`zip`</span> <span class='hs-varid'>pats</span><span class='hs-layout'>)</span>
<a name="line-121"></a> <span class='hs-layout'>;</span> <span class='hs-layout'>(</span><span class='hs-varid'>spec_usg</span><span class='hs-layout'>,</span> <span class='hs-varid'>spec_body</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>scExpr</span> <span class='hs-varid'>spec_env</span> <span class='hs-varid'>body</span>
<a name="line-122"></a>
<a name="line-123"></a><span class='hs-comment'>-- ; pprTrace "spec_one" (ppr fn <+> vcat [text "pats" <+> ppr pats,</span>
<a name="line-124"></a><span class='hs-comment'>-- text "calls" <+> (ppr (scu_calls spec_usg))])</span>
<a name="line-125"></a><span class='hs-comment'>-- (return ())</span>
<a name="line-126"></a>
<a name="line-127"></a> <span class='hs-comment'>-- And build the results</span>
<a name="line-128"></a> <span class='hs-layout'>;</span> <span class='hs-varid'>spec_uniq</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>getUniqueUs</span>
<a name="line-129"></a> <span class='hs-layout'>;</span> <span class='hs-keyword'>let</span> <span class='hs-layout'>(</span><span class='hs-varid'>spec_lam_args</span><span class='hs-layout'>,</span> <span class='hs-varid'>spec_call_args</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkWorkerArgs</span> <span class='hs-varid'>qvars</span> <span class='hs-varid'>body_ty</span>
<a name="line-130"></a> <span class='hs-comment'>-- Usual w/w hack to avoid generating </span>
<a name="line-131"></a> <span class='hs-comment'>-- a spec_rhs of unlifted type and no args</span>
<a name="line-132"></a>
<a name="line-133"></a> <span class='hs-varid'>fn_name</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>idName</span> <span class='hs-varid'>fn</span>
<a name="line-134"></a> <span class='hs-varid'>fn_loc</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>nameSrcSpan</span> <span class='hs-varid'>fn_name</span>
<a name="line-135"></a> <span class='hs-varid'>spec_occ</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkSpecOcc</span> <span class='hs-layout'>(</span><span class='hs-varid'>nameOccName</span> <span class='hs-varid'>fn_name</span><span class='hs-layout'>)</span>
<a name="line-136"></a> <span class='hs-varid'>rule_name</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkFastString</span> <span class='hs-layout'>(</span><span class='hs-str'>"SC:"</span> <span class='hs-varop'>++</span> <span class='hs-varid'>showSDoc</span> <span class='hs-layout'>(</span><span class='hs-varid'>ppr</span> <span class='hs-varid'>fn</span> <span class='hs-varop'><></span> <span class='hs-varid'>int</span> <span class='hs-varid'>rule_number</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-137"></a> <span class='hs-varid'>spec_rhs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkLams</span> <span class='hs-varid'>spec_lam_args</span> <span class='hs-varid'>spec_body</span>
<a name="line-138"></a> <span class='hs-varid'>spec_str</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>calcSpecStrictness</span> <span class='hs-varid'>fn</span> <span class='hs-varid'>spec_lam_args</span> <span class='hs-varid'>pats</span>
<a name="line-139"></a> <span class='hs-varid'>spec_id</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkUserLocal</span> <span class='hs-varid'>spec_occ</span> <span class='hs-varid'>spec_uniq</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkPiTypes</span> <span class='hs-varid'>spec_lam_args</span> <span class='hs-varid'>body_ty</span><span class='hs-layout'>)</span> <span class='hs-varid'>fn_loc</span>
<a name="line-140"></a> <span class='hs-varop'>`setIdNewStrictness`</span> <span class='hs-varid'>spec_str</span> <span class='hs-comment'>-- See Note [Transfer strictness]</span>
<a name="line-141"></a> <span class='hs-varop'>`setIdArity`</span> <span class='hs-varid'>count</span> <span class='hs-varid'>isId</span> <span class='hs-varid'>spec_lam_args</span>
<a name="line-142"></a> <span class='hs-varid'>body_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>exprType</span> <span class='hs-varid'>spec_body</span>
<a name="line-143"></a> <span class='hs-varid'>rule_rhs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkVarApps</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>spec_id</span><span class='hs-layout'>)</span> <span class='hs-varid'>spec_call_args</span>
<a name="line-144"></a> <span class='hs-varid'>rule</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkLocalRule</span> <span class='hs-varid'>rule_name</span> <span class='hs-varid'>specConstrActivation</span> <span class='hs-varid'>fn_name</span> <span class='hs-varid'>qvars</span> <span class='hs-varid'>pats</span> <span class='hs-varid'>rule_rhs</span>
<a name="line-145"></a> <span class='hs-layout'>;</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>spec_usg</span><span class='hs-layout'>,</span> <span class='hs-conid'>OS</span> <span class='hs-varid'>call_pat</span> <span class='hs-varid'>rule</span> <span class='hs-varid'>spec_id</span> <span class='hs-varid'>spec_rhs</span><span class='hs-layout'>)</span> <span class='hs-layout'>}</span>
<a name="line-146"></a>
<a name="line-147"></a><a name="calcSpecStrictness"></a><span class='hs-definition'>calcSpecStrictness</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Id</span> <span class='hs-comment'>-- The original function</span>
<a name="line-148"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Var</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>CoreExpr</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- Call pattern</span>
<a name="line-149"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>StrictSig</span> <span class='hs-comment'>-- Strictness of specialised thing</span>
<a name="line-150"></a><span class='hs-comment'>-- See Note [Transfer strictness]</span>
<a name="line-151"></a><span class='hs-definition'>calcSpecStrictness</span> <span class='hs-varid'>fn</span> <span class='hs-varid'>qvars</span> <span class='hs-varid'>pats</span>
<a name="line-152"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>StrictSig</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkTopDmdType</span> <span class='hs-varid'>spec_dmds</span> <span class='hs-conid'>TopRes</span><span class='hs-layout'>)</span>
<a name="line-153"></a> <span class='hs-keyword'>where</span>
<a name="line-154"></a> <span class='hs-varid'>spec_dmds</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span> <span class='hs-varid'>lookupVarEnv</span> <span class='hs-varid'>dmd_env</span> <span class='hs-varid'>qv</span> <span class='hs-varop'>`orElse`</span> <span class='hs-varid'>lazyDmd</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>qv</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>qvars</span><span class='hs-layout'>,</span> <span class='hs-varid'>isId</span> <span class='hs-varid'>qv</span> <span class='hs-keyglyph'>]</span>
<a name="line-155"></a> <span class='hs-conid'>StrictSig</span> <span class='hs-layout'>(</span><span class='hs-conid'>DmdType</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>dmds</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>idNewStrictness</span> <span class='hs-varid'>fn</span>
<a name="line-156"></a>
<a name="line-157"></a> <span class='hs-varid'>dmd_env</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>go</span> <span class='hs-varid'>emptyVarEnv</span> <span class='hs-varid'>dmds</span> <span class='hs-varid'>pats</span>
<a name="line-158"></a>
<a name="line-159"></a> <span class='hs-varid'>go</span> <span class='hs-varid'>env</span> <span class='hs-varid'>ds</span> <span class='hs-layout'>(</span><span class='hs-conid'>Type</span> <span class='hs-layout'>{</span><span class='hs-layout'>}</span> <span class='hs-conop'>:</span> <span class='hs-varid'>pats</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>go</span> <span class='hs-varid'>env</span> <span class='hs-varid'>ds</span> <span class='hs-varid'>pats</span>
<a name="line-160"></a> <span class='hs-varid'>go</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-varid'>d</span><span class='hs-conop'>:</span><span class='hs-varid'>ds</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>pat</span> <span class='hs-conop'>:</span> <span class='hs-varid'>pats</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>go</span> <span class='hs-layout'>(</span><span class='hs-varid'>go_one</span> <span class='hs-varid'>env</span> <span class='hs-varid'>d</span> <span class='hs-varid'>pat</span><span class='hs-layout'>)</span> <span class='hs-varid'>ds</span> <span class='hs-varid'>pats</span>
<a name="line-161"></a> <span class='hs-varid'>go</span> <span class='hs-varid'>env</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>env</span>
<a name="line-162"></a>
<a name="line-163"></a> <span class='hs-varid'>go_one</span> <span class='hs-varid'>env</span> <span class='hs-varid'>d</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>v</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendVarEnv_C</span> <span class='hs-varid'>both</span> <span class='hs-varid'>env</span> <span class='hs-varid'>v</span> <span class='hs-varid'>d</span>
<a name="line-164"></a> <span class='hs-varid'>go_one</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-conid'>Box</span> <span class='hs-varid'>d</span><span class='hs-layout'>)</span> <span class='hs-varid'>e</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>go_one</span> <span class='hs-varid'>env</span> <span class='hs-varid'>d</span> <span class='hs-varid'>e</span>
<a name="line-165"></a> <span class='hs-varid'>go_one</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-conid'>Eval</span> <span class='hs-layout'>(</span><span class='hs-conid'>Prod</span> <span class='hs-varid'>ds</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-varid'>e</span>
<a name="line-166"></a> <span class='hs-keyglyph'>|</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-varid'>args</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>collectArgs</span> <span class='hs-varid'>e</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>go</span> <span class='hs-varid'>env</span> <span class='hs-varid'>ds</span> <span class='hs-varid'>args</span>
<a name="line-167"></a> <span class='hs-varid'>go_one</span> <span class='hs-varid'>env</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>env</span>
<a name="line-168"></a>
<a name="line-169"></a><a name="specConstrActivation"></a><span class='hs-comment'>-- In which phase should the specialise-constructor rules be active?</span>
<a name="line-170"></a><span class='hs-comment'>-- Originally I made them always-active, but Manuel found that</span>
<a name="line-171"></a><span class='hs-comment'>-- this defeated some clever user-written rules. So Plan B</span>
<a name="line-172"></a><span class='hs-comment'>-- is to make them active only in Phase 0; after all, currently,</span>
<a name="line-173"></a><span class='hs-comment'>-- the specConstr transformation is only run after the simplifier</span>
<a name="line-174"></a><span class='hs-comment'>-- has reached Phase 0. In general one would want it to be </span>
<a name="line-175"></a><span class='hs-comment'>-- flag-controllable, but for now I'm leaving it baked in</span>
<a name="line-176"></a><span class='hs-comment'>-- [SLPJ Oct 01]</span>
<a name="line-177"></a><span class='hs-definition'>specConstrActivation</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Activation</span>
<a name="line-178"></a><span class='hs-definition'>specConstrActivation</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ActiveAfter</span> <span class='hs-num'>0</span> <span class='hs-comment'>-- Baked in; see comments above</span>
</pre>\end{code}
Note [Transfer strictness]
~~~~~~~~~~~~~~~~~~~~~~~~~~
We must transfer strictness information from the original function to
the specialised one. Suppose, for example
f has strictness SS
and a RULE f (a:as) b = f_spec a as b
Now we want f_spec to have strictess LLS, otherwise we'll use call-by-need
when calling f_spec instead of call-by-value. And that can result in
unbounded worsening in space (cf the classic foldl vs foldl')
See Trac #3437 for a good example.
The function calcSpecStrictness performs the calculation.
%************************************************************************
%* *
\subsection{Argument analysis}
%* *
%************************************************************************
This code deals with analysing call-site arguments to see whether
they are constructor applications.
\begin{code}
<pre><a name="line-1"></a><a name="CallPat"></a><span class='hs-keyword'>type</span> <span class='hs-conid'>CallPat</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-conid'>Var</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>CoreExpr</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- Quantified variables and arguments</span>
<a name="line-2"></a>
<a name="line-3"></a>
<a name="line-4"></a><a name="callsToPats"></a><span class='hs-definition'>callsToPats</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ScEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>OneSpec</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>ArgOcc</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Call</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>UniqSM</span> <span class='hs-layout'>(</span><span class='hs-conid'>Bool</span><span class='hs-layout'>,</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>CallPat</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-5"></a> <span class='hs-comment'>-- Result has no duplicate patterns, </span>
<a name="line-6"></a> <span class='hs-comment'>-- nor ones mentioned in done_pats</span>
<a name="line-7"></a> <span class='hs-comment'>-- Bool indicates that there was at least one boring pattern</span>
<a name="line-8"></a><span class='hs-definition'>callsToPats</span> <span class='hs-varid'>env</span> <span class='hs-varid'>done_specs</span> <span class='hs-varid'>bndr_occs</span> <span class='hs-varid'>calls</span>
<a name="line-9"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-layout'>{</span> <span class='hs-varid'>mb_pats</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapM</span> <span class='hs-layout'>(</span><span class='hs-varid'>callToPats</span> <span class='hs-varid'>env</span> <span class='hs-varid'>bndr_occs</span><span class='hs-layout'>)</span> <span class='hs-varid'>calls</span>
<a name="line-10"></a>
<a name="line-11"></a> <span class='hs-layout'>;</span> <span class='hs-keyword'>let</span> <span class='hs-varid'>good_pats</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-conid'>Var</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>CoreArg</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-12"></a> <span class='hs-varid'>good_pats</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>catMaybes</span> <span class='hs-varid'>mb_pats</span>
<a name="line-13"></a> <span class='hs-varid'>done_pats</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>p</span> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>OS</span> <span class='hs-varid'>p</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>done_specs</span><span class='hs-keyglyph'>]</span>
<a name="line-14"></a> <span class='hs-varid'>is_done</span> <span class='hs-varid'>p</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>any</span> <span class='hs-layout'>(</span><span class='hs-varid'>samePat</span> <span class='hs-varid'>p</span><span class='hs-layout'>)</span> <span class='hs-varid'>done_pats</span>
<a name="line-15"></a>
<a name="line-16"></a> <span class='hs-layout'>;</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>any</span> <span class='hs-varid'>isNothing</span> <span class='hs-varid'>mb_pats</span><span class='hs-layout'>,</span>
<a name="line-17"></a> <span class='hs-varid'>filterOut</span> <span class='hs-varid'>is_done</span> <span class='hs-layout'>(</span><span class='hs-varid'>nubBy</span> <span class='hs-varid'>samePat</span> <span class='hs-varid'>good_pats</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-layout'>}</span>
<a name="line-18"></a>
<a name="line-19"></a><a name="callToPats"></a><span class='hs-definition'>callToPats</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ScEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>ArgOcc</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Call</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>UniqSM</span> <span class='hs-layout'>(</span><span class='hs-conid'>Maybe</span> <span class='hs-conid'>CallPat</span><span class='hs-layout'>)</span>
<a name="line-20"></a> <span class='hs-comment'>-- The [Var] is the variables to quantify over in the rule</span>
<a name="line-21"></a> <span class='hs-comment'>-- Type variables come first, since they may scope </span>
<a name="line-22"></a> <span class='hs-comment'>-- over the following term variables</span>
<a name="line-23"></a> <span class='hs-comment'>-- The [CoreExpr] are the argument patterns for the rule</span>
<a name="line-24"></a><span class='hs-definition'>callToPats</span> <span class='hs-varid'>env</span> <span class='hs-varid'>bndr_occs</span> <span class='hs-layout'>(</span><span class='hs-varid'>con_env</span><span class='hs-layout'>,</span> <span class='hs-varid'>args</span><span class='hs-layout'>)</span>
<a name="line-25"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>length</span> <span class='hs-varid'>args</span> <span class='hs-varop'><</span> <span class='hs-varid'>length</span> <span class='hs-varid'>bndr_occs</span> <span class='hs-comment'>-- Check saturated</span>
<a name="line-26"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-conid'>Nothing</span>
<a name="line-27"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span>
<a name="line-28"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-layout'>{</span> <span class='hs-keyword'>let</span> <span class='hs-varid'>in_scope</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>substInScope</span> <span class='hs-layout'>(</span><span class='hs-varid'>sc_subst</span> <span class='hs-varid'>env</span><span class='hs-layout'>)</span>
<a name="line-29"></a> <span class='hs-layout'>;</span> <span class='hs-varid'>prs</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>argsToPats</span> <span class='hs-varid'>in_scope</span> <span class='hs-varid'>con_env</span> <span class='hs-layout'>(</span><span class='hs-varid'>args</span> <span class='hs-varop'>`zip`</span> <span class='hs-varid'>bndr_occs</span><span class='hs-layout'>)</span>
<a name="line-30"></a> <span class='hs-layout'>;</span> <span class='hs-keyword'>let</span> <span class='hs-layout'>(</span><span class='hs-varid'>interesting_s</span><span class='hs-layout'>,</span> <span class='hs-varid'>pats</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>unzip</span> <span class='hs-varid'>prs</span>
<a name="line-31"></a> <span class='hs-varid'>pat_fvs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>varSetElems</span> <span class='hs-layout'>(</span><span class='hs-varid'>exprsFreeVars</span> <span class='hs-varid'>pats</span><span class='hs-layout'>)</span>
<a name="line-32"></a> <span class='hs-varid'>qvars</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>filterOut</span> <span class='hs-layout'>(</span><span class='hs-varop'>`elemInScopeSet`</span> <span class='hs-varid'>in_scope</span><span class='hs-layout'>)</span> <span class='hs-varid'>pat_fvs</span>
<a name="line-33"></a> <span class='hs-comment'>-- Quantify over variables that are not in sccpe</span>
<a name="line-34"></a> <span class='hs-comment'>-- at the call site</span>
<a name="line-35"></a> <span class='hs-comment'>-- See Note [Shadowing] at the top</span>
<a name="line-36"></a>
<a name="line-37"></a> <span class='hs-layout'>(</span><span class='hs-varid'>tvs</span><span class='hs-layout'>,</span> <span class='hs-varid'>ids</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>partition</span> <span class='hs-varid'>isTyVar</span> <span class='hs-varid'>qvars</span>
<a name="line-38"></a> <span class='hs-varid'>qvars'</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>tvs</span> <span class='hs-varop'>++</span> <span class='hs-varid'>ids</span>
<a name="line-39"></a> <span class='hs-comment'>-- Put the type variables first; the type of a term</span>
<a name="line-40"></a> <span class='hs-comment'>-- variable may mention a type variable</span>
<a name="line-41"></a>
<a name="line-42"></a> <span class='hs-layout'>;</span> <span class='hs-comment'>-- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $</span>
<a name="line-43"></a> <span class='hs-keyword'>if</span> <span class='hs-varid'>or</span> <span class='hs-varid'>interesting_s</span>
<a name="line-44"></a> <span class='hs-keyword'>then</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>Just</span> <span class='hs-layout'>(</span><span class='hs-varid'>qvars'</span><span class='hs-layout'>,</span> <span class='hs-varid'>pats</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-45"></a> <span class='hs-keyword'>else</span> <span class='hs-varid'>return</span> <span class='hs-conid'>Nothing</span> <span class='hs-layout'>}</span>
<a name="line-46"></a>
<a name="line-47"></a> <span class='hs-comment'>-- argToPat takes an actual argument, and returns an abstracted</span>
<a name="line-48"></a> <span class='hs-comment'>-- version, consisting of just the "constructor skeleton" of the</span>
<a name="line-49"></a> <span class='hs-comment'>-- argument, with non-constructor sub-expression replaced by new</span>
<a name="line-50"></a> <span class='hs-comment'>-- placeholder variables. For example:</span>
<a name="line-51"></a> <span class='hs-comment'>-- C a (D (f x) (g y)) ==> C p1 (D p2 p3)</span>
<a name="line-52"></a>
<a name="line-53"></a><a name="argToPat"></a><span class='hs-definition'>argToPat</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>InScopeSet</span> <span class='hs-comment'>-- What's in scope at the fn defn site</span>
<a name="line-54"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ValueEnv</span> <span class='hs-comment'>-- ValueEnv at the call site</span>
<a name="line-55"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreArg</span> <span class='hs-comment'>-- A call arg (or component thereof)</span>
<a name="line-56"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ArgOcc</span>
<a name="line-57"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>UniqSM</span> <span class='hs-layout'>(</span><span class='hs-conid'>Bool</span><span class='hs-layout'>,</span> <span class='hs-conid'>CoreArg</span><span class='hs-layout'>)</span>
<a name="line-58"></a><span class='hs-comment'>-- Returns (interesting, pat), </span>
<a name="line-59"></a><span class='hs-comment'>-- where pat is the pattern derived from the argument</span>
<a name="line-60"></a><span class='hs-comment'>-- intersting=True if the pattern is non-trivial (not a variable or type)</span>
<a name="line-61"></a><span class='hs-comment'>-- E.g. x:xs --> (True, x:xs)</span>
<a name="line-62"></a><span class='hs-comment'>-- f xs --> (False, w) where w is a fresh wildcard</span>
<a name="line-63"></a><span class='hs-comment'>-- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard</span>
<a name="line-64"></a><span class='hs-comment'>-- \x. x+y --> (True, \x. x+y)</span>
<a name="line-65"></a><span class='hs-comment'>-- lvl7 --> (True, lvl7) if lvl7 is bound </span>
<a name="line-66"></a><span class='hs-comment'>-- somewhere further out</span>
<a name="line-67"></a>
<a name="line-68"></a><span class='hs-definition'>argToPat</span> <span class='hs-sel'>_in_scope</span> <span class='hs-sel'>_val_env</span> <span class='hs-varid'>arg</span><span class='hs-keyglyph'>@</span><span class='hs-layout'>(</span><span class='hs-conid'>Type</span> <span class='hs-layout'>{</span><span class='hs-layout'>}</span><span class='hs-layout'>)</span> <span class='hs-sel'>_arg_occ</span>
<a name="line-69"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>False</span><span class='hs-layout'>,</span> <span class='hs-varid'>arg</span><span class='hs-layout'>)</span>
<a name="line-70"></a>
<a name="line-71"></a><span class='hs-definition'>argToPat</span> <span class='hs-varid'>in_scope</span> <span class='hs-varid'>val_env</span> <span class='hs-layout'>(</span><span class='hs-conid'>Note</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>arg</span><span class='hs-layout'>)</span> <span class='hs-varid'>arg_occ</span>
<a name="line-72"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>argToPat</span> <span class='hs-varid'>in_scope</span> <span class='hs-varid'>val_env</span> <span class='hs-varid'>arg</span> <span class='hs-varid'>arg_occ</span>
<a name="line-73"></a> <span class='hs-comment'>-- Note [Notes in call patterns]</span>
<a name="line-74"></a> <span class='hs-comment'>-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~</span>
<a name="line-75"></a> <span class='hs-comment'>-- Ignore Notes. In particular, we want to ignore any InlineMe notes</span>
<a name="line-76"></a> <span class='hs-comment'>-- Perhaps we should not ignore profiling notes, but I'm going to</span>
<a name="line-77"></a> <span class='hs-comment'>-- ride roughshod over them all for now.</span>
<a name="line-78"></a> <span class='hs-comment'>--- See Note [Notes in RULE matching] in Rules</span>
<a name="line-79"></a>
<a name="line-80"></a><span class='hs-definition'>argToPat</span> <span class='hs-varid'>in_scope</span> <span class='hs-varid'>val_env</span> <span class='hs-layout'>(</span><span class='hs-conid'>Let</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>arg</span><span class='hs-layout'>)</span> <span class='hs-varid'>arg_occ</span>
<a name="line-81"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>argToPat</span> <span class='hs-varid'>in_scope</span> <span class='hs-varid'>val_env</span> <span class='hs-varid'>arg</span> <span class='hs-varid'>arg_occ</span>
<a name="line-82"></a> <span class='hs-comment'>-- Look through let expressions</span>
<a name="line-83"></a> <span class='hs-comment'>-- e.g. f (let v = rhs in \y -> ...v...)</span>
<a name="line-84"></a> <span class='hs-comment'>-- Here we can specialise for f (\y -> ...)</span>
<a name="line-85"></a> <span class='hs-comment'>-- because the rule-matcher will look through the let.</span>
<a name="line-86"></a>
<a name="line-87"></a><span class='hs-definition'>argToPat</span> <span class='hs-varid'>in_scope</span> <span class='hs-varid'>val_env</span> <span class='hs-layout'>(</span><span class='hs-conid'>Cast</span> <span class='hs-varid'>arg</span> <span class='hs-varid'>co</span><span class='hs-layout'>)</span> <span class='hs-varid'>arg_occ</span>
<a name="line-88"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-layout'>{</span> <span class='hs-layout'>(</span><span class='hs-varid'>interesting</span><span class='hs-layout'>,</span> <span class='hs-varid'>arg'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>argToPat</span> <span class='hs-varid'>in_scope</span> <span class='hs-varid'>val_env</span> <span class='hs-varid'>arg</span> <span class='hs-varid'>arg_occ</span>
<a name="line-89"></a> <span class='hs-layout'>;</span> <span class='hs-keyword'>let</span> <span class='hs-layout'>(</span><span class='hs-varid'>ty1</span><span class='hs-layout'>,</span><span class='hs-varid'>ty2</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>coercionKind</span> <span class='hs-varid'>co</span>
<a name="line-90"></a> <span class='hs-layout'>;</span> <span class='hs-keyword'>if</span> <span class='hs-varid'>not</span> <span class='hs-varid'>interesting</span> <span class='hs-keyword'>then</span>
<a name="line-91"></a> <span class='hs-varid'>wildCardPat</span> <span class='hs-varid'>ty2</span>
<a name="line-92"></a> <span class='hs-keyword'>else</span> <span class='hs-keyword'>do</span>
<a name="line-93"></a> <span class='hs-layout'>{</span> <span class='hs-comment'>-- Make a wild-card pattern for the coercion</span>
<a name="line-94"></a> <span class='hs-varid'>uniq</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>getUniqueUs</span>
<a name="line-95"></a> <span class='hs-layout'>;</span> <span class='hs-keyword'>let</span> <span class='hs-varid'>co_name</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkSysTvName</span> <span class='hs-varid'>uniq</span> <span class='hs-layout'>(</span><span class='hs-varid'>fsLit</span> <span class='hs-str'>"sg"</span><span class='hs-layout'>)</span>
<a name="line-96"></a> <span class='hs-varid'>co_var</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkCoVar</span> <span class='hs-varid'>co_name</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkCoKind</span> <span class='hs-varid'>ty1</span> <span class='hs-varid'>ty2</span><span class='hs-layout'>)</span>
<a name="line-97"></a> <span class='hs-layout'>;</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>interesting</span><span class='hs-layout'>,</span> <span class='hs-conid'>Cast</span> <span class='hs-varid'>arg'</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkTyVarTy</span> <span class='hs-varid'>co_var</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-layout'>}</span> <span class='hs-layout'>}</span>
<a name="line-98"></a>
<a name="line-99"></a><span class='hs-comment'>{- Disabling lambda specialisation for now
<a name="line-100"></a> It's fragile, and the spec_loop can be infinite
<a name="line-101"></a>argToPat in_scope val_env arg arg_occ
<a name="line-102"></a> | is_value_lam arg
<a name="line-103"></a> = return (True, arg)
<a name="line-104"></a> where
<a name="line-105"></a> is_value_lam (Lam v e) -- Spot a value lambda, even if
<a name="line-106"></a> | isId v = True -- it is inside a type lambda
<a name="line-107"></a> | otherwise = is_value_lam e
<a name="line-108"></a> is_value_lam other = False
<a name="line-109"></a>-}</span>
<a name="line-110"></a>
<a name="line-111"></a> <span class='hs-comment'>-- Check for a constructor application</span>
<a name="line-112"></a> <span class='hs-comment'>-- NB: this *precedes* the Var case, so that we catch nullary constrs</span>
<a name="line-113"></a><span class='hs-definition'>argToPat</span> <span class='hs-varid'>in_scope</span> <span class='hs-varid'>val_env</span> <span class='hs-varid'>arg</span> <span class='hs-varid'>arg_occ</span>
<a name="line-114"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>Just</span> <span class='hs-layout'>(</span><span class='hs-conid'>ConVal</span> <span class='hs-varid'>dc</span> <span class='hs-varid'>args</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>isValue</span> <span class='hs-varid'>val_env</span> <span class='hs-varid'>arg</span>
<a name="line-115"></a> <span class='hs-layout'>,</span> <span class='hs-keyword'>case</span> <span class='hs-varid'>arg_occ</span> <span class='hs-keyword'>of</span>
<a name="line-116"></a> <span class='hs-conid'>ScrutOcc</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>True</span> <span class='hs-comment'>-- Used only by case scrutinee</span>
<a name="line-117"></a> <span class='hs-conid'>BothOcc</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>case</span> <span class='hs-varid'>arg</span> <span class='hs-keyword'>of</span> <span class='hs-comment'>-- Used elsewhere</span>
<a name="line-118"></a> <span class='hs-conid'>App</span> <span class='hs-layout'>{</span><span class='hs-layout'>}</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>True</span> <span class='hs-comment'>-- see Note [Reboxing]</span>
<a name="line-119"></a> <span class='hs-sel'>_other</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>False</span>
<a name="line-120"></a> <span class='hs-sel'>_other</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>False</span> <span class='hs-comment'>-- No point; the arg is not decomposed</span>
<a name="line-121"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-layout'>{</span> <span class='hs-varid'>args'</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>argsToPats</span> <span class='hs-varid'>in_scope</span> <span class='hs-varid'>val_env</span> <span class='hs-layout'>(</span><span class='hs-varid'>args</span> <span class='hs-varop'>`zip`</span> <span class='hs-varid'>conArgOccs</span> <span class='hs-varid'>arg_occ</span> <span class='hs-varid'>dc</span><span class='hs-layout'>)</span>
<a name="line-122"></a> <span class='hs-layout'>;</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>True</span><span class='hs-layout'>,</span> <span class='hs-varid'>mk_con_app</span> <span class='hs-varid'>dc</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>snd</span> <span class='hs-varid'>args'</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-layout'>}</span>
<a name="line-123"></a>
<a name="line-124"></a> <span class='hs-comment'>-- Check if the argument is a variable that </span>
<a name="line-125"></a> <span class='hs-comment'>-- is in scope at the function definition site</span>
<a name="line-126"></a> <span class='hs-comment'>-- It's worth specialising on this if</span>
<a name="line-127"></a> <span class='hs-comment'>-- (a) it's used in an interesting way in the body</span>
<a name="line-128"></a> <span class='hs-comment'>-- (b) we know what its value is</span>
<a name="line-129"></a><span class='hs-definition'>argToPat</span> <span class='hs-varid'>in_scope</span> <span class='hs-varid'>val_env</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>v</span><span class='hs-layout'>)</span> <span class='hs-varid'>arg_occ</span>
<a name="line-130"></a> <span class='hs-keyglyph'>|</span> <span class='hs-keyword'>case</span> <span class='hs-varid'>arg_occ</span> <span class='hs-keyword'>of</span> <span class='hs-layout'>{</span> <span class='hs-conid'>UnkOcc</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>False</span><span class='hs-layout'>;</span> <span class='hs-sel'>_other</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>True</span> <span class='hs-layout'>}</span><span class='hs-layout'>,</span> <span class='hs-comment'>-- (a)</span>
<a name="line-131"></a> <span class='hs-varid'>is_value</span> <span class='hs-comment'>-- (b)</span>
<a name="line-132"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>True</span><span class='hs-layout'>,</span> <span class='hs-conid'>Var</span> <span class='hs-varid'>v</span><span class='hs-layout'>)</span>
<a name="line-133"></a> <span class='hs-keyword'>where</span>
<a name="line-134"></a> <span class='hs-varid'>is_value</span>
<a name="line-135"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isLocalId</span> <span class='hs-varid'>v</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>v</span> <span class='hs-varop'>`elemInScopeSet`</span> <span class='hs-varid'>in_scope</span>
<a name="line-136"></a> <span class='hs-varop'>&&</span> <span class='hs-varid'>isJust</span> <span class='hs-layout'>(</span><span class='hs-varid'>lookupVarEnv</span> <span class='hs-varid'>val_env</span> <span class='hs-varid'>v</span><span class='hs-layout'>)</span>
<a name="line-137"></a> <span class='hs-comment'>-- Local variables have values in val_env</span>
<a name="line-138"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>isValueUnfolding</span> <span class='hs-layout'>(</span><span class='hs-varid'>idUnfolding</span> <span class='hs-varid'>v</span><span class='hs-layout'>)</span>
<a name="line-139"></a> <span class='hs-comment'>-- Imports have unfoldings</span>
<a name="line-140"></a>
<a name="line-141"></a><span class='hs-comment'>-- I'm really not sure what this comment means</span>
<a name="line-142"></a><span class='hs-comment'>-- And by not wild-carding we tend to get forall'd </span>
<a name="line-143"></a><span class='hs-comment'>-- variables that are in soope, which in turn can</span>
<a name="line-144"></a><span class='hs-comment'>-- expose the weakness in let-matching</span>
<a name="line-145"></a><span class='hs-comment'>-- See Note [Matching lets] in Rules</span>
<a name="line-146"></a>
<a name="line-147"></a> <span class='hs-comment'>-- Check for a variable bound inside the function. </span>
<a name="line-148"></a> <span class='hs-comment'>-- Don't make a wild-card, because we may usefully share</span>
<a name="line-149"></a> <span class='hs-comment'>-- e.g. f a = let x = ... in f (x,x)</span>
<a name="line-150"></a> <span class='hs-comment'>-- NB: this case follows the lambda and con-app cases!!</span>
<a name="line-151"></a><span class='hs-comment'>-- argToPat _in_scope _val_env (Var v) _arg_occ</span>
<a name="line-152"></a><span class='hs-comment'>-- = return (False, Var v)</span>
<a name="line-153"></a> <span class='hs-comment'>-- SLPJ : disabling this to avoid proliferation of versions</span>
<a name="line-154"></a> <span class='hs-comment'>-- also works badly when thinking about seeding the loop</span>
<a name="line-155"></a> <span class='hs-comment'>-- from the body of the let</span>
<a name="line-156"></a> <span class='hs-comment'>-- f x y = letrec g z = ... in g (x,y)</span>
<a name="line-157"></a> <span class='hs-comment'>-- We don't want to specialise for that *particular* x,y</span>
<a name="line-158"></a>
<a name="line-159"></a> <span class='hs-comment'>-- The default case: make a wild-card</span>
<a name="line-160"></a><span class='hs-definition'>argToPat</span> <span class='hs-sel'>_in_scope</span> <span class='hs-sel'>_val_env</span> <span class='hs-varid'>arg</span> <span class='hs-sel'>_arg_occ</span>
<a name="line-161"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>wildCardPat</span> <span class='hs-layout'>(</span><span class='hs-varid'>exprType</span> <span class='hs-varid'>arg</span><span class='hs-layout'>)</span>
<a name="line-162"></a>
<a name="line-163"></a><a name="wildCardPat"></a><span class='hs-definition'>wildCardPat</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Type</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>UniqSM</span> <span class='hs-layout'>(</span><span class='hs-conid'>Bool</span><span class='hs-layout'>,</span> <span class='hs-conid'>CoreArg</span><span class='hs-layout'>)</span>
<a name="line-164"></a><span class='hs-definition'>wildCardPat</span> <span class='hs-varid'>ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-layout'>{</span> <span class='hs-varid'>uniq</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>getUniqueUs</span>
<a name="line-165"></a> <span class='hs-layout'>;</span> <span class='hs-keyword'>let</span> <span class='hs-varid'>id</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkSysLocal</span> <span class='hs-layout'>(</span><span class='hs-varid'>fsLit</span> <span class='hs-str'>"sc"</span><span class='hs-layout'>)</span> <span class='hs-varid'>uniq</span> <span class='hs-varid'>ty</span>
<a name="line-166"></a> <span class='hs-layout'>;</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>False</span><span class='hs-layout'>,</span> <span class='hs-conid'>Var</span> <span class='hs-varid'>id</span><span class='hs-layout'>)</span> <span class='hs-layout'>}</span>
<a name="line-167"></a>
<a name="line-168"></a><a name="argsToPats"></a><span class='hs-definition'>argsToPats</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>InScopeSet</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ValueEnv</span>
<a name="line-169"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>CoreArg</span><span class='hs-layout'>,</span> <span class='hs-conid'>ArgOcc</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-170"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>UniqSM</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>Bool</span><span class='hs-layout'>,</span> <span class='hs-conid'>CoreArg</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-171"></a><span class='hs-definition'>argsToPats</span> <span class='hs-varid'>in_scope</span> <span class='hs-varid'>val_env</span> <span class='hs-varid'>args</span>
<a name="line-172"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mapM</span> <span class='hs-varid'>do_one</span> <span class='hs-varid'>args</span>
<a name="line-173"></a> <span class='hs-keyword'>where</span>
<a name="line-174"></a> <span class='hs-varid'>do_one</span> <span class='hs-layout'>(</span><span class='hs-varid'>arg</span><span class='hs-layout'>,</span><span class='hs-varid'>occ</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>argToPat</span> <span class='hs-varid'>in_scope</span> <span class='hs-varid'>val_env</span> <span class='hs-varid'>arg</span> <span class='hs-varid'>occ</span>
</pre>\end{code}
\begin{code}
<pre><a name="line-1"></a><a name="isValue"></a><span class='hs-definition'>isValue</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ValueEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Maybe</span> <span class='hs-conid'>Value</span>
<a name="line-2"></a><span class='hs-definition'>isValue</span> <span class='hs-sel'>_env</span> <span class='hs-layout'>(</span><span class='hs-conid'>Lit</span> <span class='hs-varid'>lit</span><span class='hs-layout'>)</span>
<a name="line-3"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Just</span> <span class='hs-layout'>(</span><span class='hs-conid'>ConVal</span> <span class='hs-layout'>(</span><span class='hs-conid'>LitAlt</span> <span class='hs-varid'>lit</span><span class='hs-layout'>)</span> <span class='hs-conid'>[]</span><span class='hs-layout'>)</span>
<a name="line-4"></a>
<a name="line-5"></a><span class='hs-definition'>isValue</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>v</span><span class='hs-layout'>)</span>
<a name="line-6"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>Just</span> <span class='hs-varid'>stuff</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lookupVarEnv</span> <span class='hs-varid'>env</span> <span class='hs-varid'>v</span>
<a name="line-7"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Just</span> <span class='hs-varid'>stuff</span> <span class='hs-comment'>-- You might think we could look in the idUnfolding here</span>
<a name="line-8"></a> <span class='hs-comment'>-- but that doesn't take account of which branch of a </span>
<a name="line-9"></a> <span class='hs-comment'>-- case we are in, which is the whole point</span>
<a name="line-10"></a>
<a name="line-11"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>not</span> <span class='hs-layout'>(</span><span class='hs-varid'>isLocalId</span> <span class='hs-varid'>v</span><span class='hs-layout'>)</span> <span class='hs-varop'>&&</span> <span class='hs-varid'>isCheapUnfolding</span> <span class='hs-varid'>unf</span>
<a name="line-12"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>isValue</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-varid'>unfoldingTemplate</span> <span class='hs-varid'>unf</span><span class='hs-layout'>)</span>
<a name="line-13"></a> <span class='hs-keyword'>where</span>
<a name="line-14"></a> <span class='hs-varid'>unf</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>idUnfolding</span> <span class='hs-varid'>v</span>
<a name="line-15"></a> <span class='hs-comment'>-- However we do want to consult the unfolding </span>
<a name="line-16"></a> <span class='hs-comment'>-- as well, for let-bound constructors!</span>
<a name="line-17"></a>
<a name="line-18"></a><span class='hs-definition'>isValue</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-conid'>Lam</span> <span class='hs-varid'>b</span> <span class='hs-varid'>e</span><span class='hs-layout'>)</span>
<a name="line-19"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isTyVar</span> <span class='hs-varid'>b</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>case</span> <span class='hs-varid'>isValue</span> <span class='hs-varid'>env</span> <span class='hs-varid'>e</span> <span class='hs-keyword'>of</span>
<a name="line-20"></a> <span class='hs-conid'>Just</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Just</span> <span class='hs-conid'>LambdaVal</span>
<a name="line-21"></a> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Nothing</span>
<a name="line-22"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Just</span> <span class='hs-conid'>LambdaVal</span>
<a name="line-23"></a>
<a name="line-24"></a><span class='hs-definition'>isValue</span> <span class='hs-sel'>_env</span> <span class='hs-varid'>expr</span> <span class='hs-comment'>-- Maybe it's a constructor application</span>
<a name="line-25"></a> <span class='hs-keyglyph'>|</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>fun</span><span class='hs-layout'>,</span> <span class='hs-varid'>args</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>collectArgs</span> <span class='hs-varid'>expr</span>
<a name="line-26"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>case</span> <span class='hs-varid'>isDataConWorkId_maybe</span> <span class='hs-varid'>fun</span> <span class='hs-keyword'>of</span>
<a name="line-27"></a>
<a name="line-28"></a> <span class='hs-conid'>Just</span> <span class='hs-varid'>con</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>args</span> <span class='hs-varop'>`lengthAtLeast`</span> <span class='hs-varid'>dataConRepArity</span> <span class='hs-varid'>con</span>
<a name="line-29"></a> <span class='hs-comment'>-- Check saturated; might be > because the </span>
<a name="line-30"></a> <span class='hs-comment'>-- arity excludes type args</span>
<a name="line-31"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Just</span> <span class='hs-layout'>(</span><span class='hs-conid'>ConVal</span> <span class='hs-layout'>(</span><span class='hs-conid'>DataAlt</span> <span class='hs-varid'>con</span><span class='hs-layout'>)</span> <span class='hs-varid'>args</span><span class='hs-layout'>)</span>
<a name="line-32"></a>
<a name="line-33"></a> <span class='hs-sel'>_other</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>valArgCount</span> <span class='hs-varid'>args</span> <span class='hs-varop'><</span> <span class='hs-varid'>idArity</span> <span class='hs-varid'>fun</span>
<a name="line-34"></a> <span class='hs-comment'>-- Under-applied function</span>
<a name="line-35"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Just</span> <span class='hs-conid'>LambdaVal</span> <span class='hs-comment'>-- Partial application</span>
<a name="line-36"></a>
<a name="line-37"></a> <span class='hs-sel'>_other</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Nothing</span>
<a name="line-38"></a>
<a name="line-39"></a><span class='hs-definition'>isValue</span> <span class='hs-sel'>_env</span> <span class='hs-sel'>_expr</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Nothing</span>
<a name="line-40"></a>
<a name="line-41"></a><a name="mk_con_app"></a><span class='hs-definition'>mk_con_app</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>AltCon</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>CoreArg</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExpr</span>
<a name="line-42"></a><span class='hs-definition'>mk_con_app</span> <span class='hs-layout'>(</span><span class='hs-conid'>LitAlt</span> <span class='hs-varid'>lit</span><span class='hs-layout'>)</span> <span class='hs-conid'>[]</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Lit</span> <span class='hs-varid'>lit</span>
<a name="line-43"></a><span class='hs-definition'>mk_con_app</span> <span class='hs-layout'>(</span><span class='hs-conid'>DataAlt</span> <span class='hs-varid'>con</span><span class='hs-layout'>)</span> <span class='hs-varid'>args</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkConApp</span> <span class='hs-varid'>con</span> <span class='hs-varid'>args</span>
<a name="line-44"></a><span class='hs-definition'>mk_con_app</span> <span class='hs-sel'>_other</span> <span class='hs-sel'>_args</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>panic</span> <span class='hs-str'>"SpecConstr.mk_con_app"</span>
<a name="line-45"></a>
<a name="line-46"></a><a name="samePat"></a><span class='hs-definition'>samePat</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>CallPat</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CallPat</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Bool</span>
<a name="line-47"></a><span class='hs-definition'>samePat</span> <span class='hs-layout'>(</span><span class='hs-varid'>vs1</span><span class='hs-layout'>,</span> <span class='hs-varid'>as1</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>vs2</span><span class='hs-layout'>,</span> <span class='hs-varid'>as2</span><span class='hs-layout'>)</span>
<a name="line-48"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>all2</span> <span class='hs-varid'>same</span> <span class='hs-varid'>as1</span> <span class='hs-varid'>as2</span>
<a name="line-49"></a> <span class='hs-keyword'>where</span>
<a name="line-50"></a> <span class='hs-varid'>same</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>v1</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>v2</span><span class='hs-layout'>)</span>
<a name="line-51"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>v1</span> <span class='hs-varop'>`elem`</span> <span class='hs-varid'>vs1</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>v2</span> <span class='hs-varop'>`elem`</span> <span class='hs-varid'>vs2</span>
<a name="line-52"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>v2</span> <span class='hs-varop'>`elem`</span> <span class='hs-varid'>vs2</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>False</span>
<a name="line-53"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>v1</span> <span class='hs-varop'>==</span> <span class='hs-varid'>v2</span>
<a name="line-54"></a>
<a name="line-55"></a> <span class='hs-varid'>same</span> <span class='hs-layout'>(</span><span class='hs-conid'>Lit</span> <span class='hs-varid'>l1</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>Lit</span> <span class='hs-varid'>l2</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>l1</span><span class='hs-varop'>==</span><span class='hs-varid'>l2</span>
<a name="line-56"></a> <span class='hs-varid'>same</span> <span class='hs-layout'>(</span><span class='hs-conid'>App</span> <span class='hs-varid'>f1</span> <span class='hs-varid'>a1</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>App</span> <span class='hs-varid'>f2</span> <span class='hs-varid'>a2</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>same</span> <span class='hs-varid'>f1</span> <span class='hs-varid'>f2</span> <span class='hs-varop'>&&</span> <span class='hs-varid'>same</span> <span class='hs-varid'>a1</span> <span class='hs-varid'>a2</span>
<a name="line-57"></a>
<a name="line-58"></a> <span class='hs-varid'>same</span> <span class='hs-layout'>(</span><span class='hs-conid'>Type</span> <span class='hs-layout'>{</span><span class='hs-layout'>}</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>Type</span> <span class='hs-layout'>{</span><span class='hs-layout'>}</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>True</span> <span class='hs-comment'>-- Note [Ignore type differences]</span>
<a name="line-59"></a> <span class='hs-varid'>same</span> <span class='hs-layout'>(</span><span class='hs-conid'>Note</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>e1</span><span class='hs-layout'>)</span> <span class='hs-varid'>e2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>same</span> <span class='hs-varid'>e1</span> <span class='hs-varid'>e2</span> <span class='hs-comment'>-- Ignore casts and notes</span>
<a name="line-60"></a> <span class='hs-varid'>same</span> <span class='hs-layout'>(</span><span class='hs-conid'>Cast</span> <span class='hs-varid'>e1</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-varid'>e2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>same</span> <span class='hs-varid'>e1</span> <span class='hs-varid'>e2</span>
<a name="line-61"></a> <span class='hs-varid'>same</span> <span class='hs-varid'>e1</span> <span class='hs-layout'>(</span><span class='hs-conid'>Note</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>e2</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>same</span> <span class='hs-varid'>e1</span> <span class='hs-varid'>e2</span>
<a name="line-62"></a> <span class='hs-varid'>same</span> <span class='hs-varid'>e1</span> <span class='hs-layout'>(</span><span class='hs-conid'>Cast</span> <span class='hs-varid'>e2</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>same</span> <span class='hs-varid'>e1</span> <span class='hs-varid'>e2</span>
<a name="line-63"></a>
<a name="line-64"></a> <span class='hs-varid'>same</span> <span class='hs-varid'>e1</span> <span class='hs-varid'>e2</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>WARN</span><span class='hs-layout'>(</span> <span class='hs-varid'>bad</span> <span class='hs-varid'>e1</span> <span class='hs-varop'>||</span> <span class='hs-varid'>bad</span> <span class='hs-varid'>e2</span><span class='hs-layout'>,</span> <span class='hs-varid'>ppr</span> <span class='hs-varid'>e1</span> <span class='hs-varop'>$$</span> <span class='hs-varid'>ppr</span> <span class='hs-varid'>e2</span><span class='hs-layout'>)</span>
<a name="line-65"></a> <span class='hs-conid'>False</span> <span class='hs-comment'>-- Let, lambda, case should not occur</span>
<a name="line-66"></a> <span class='hs-varid'>bad</span> <span class='hs-layout'>(</span><span class='hs-conid'>Case</span> <span class='hs-layout'>{</span><span class='hs-layout'>}</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>True</span>
<a name="line-67"></a> <span class='hs-varid'>bad</span> <span class='hs-layout'>(</span><span class='hs-conid'>Let</span> <span class='hs-layout'>{</span><span class='hs-layout'>}</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>True</span>
<a name="line-68"></a> <span class='hs-varid'>bad</span> <span class='hs-layout'>(</span><span class='hs-conid'>Lam</span> <span class='hs-layout'>{</span><span class='hs-layout'>}</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>True</span>
<a name="line-69"></a> <span class='hs-varid'>bad</span> <span class='hs-sel'>_other</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>False</span>
</pre>\end{code}
Note [Ignore type differences]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We do not want to generate specialisations where the call patterns
differ only in their type arguments! Not only is it utterly useless,
but it also means that (with polymorphic recursion) we can generate
an infinite number of specialisations. Example is Data.Sequence.adjustTree,
I think.
</body>
</html>
