<?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>simplCore/SetLevels.lhs</title>
<link type='text/css' rel='stylesheet' href='hscolour.css' />
</head>
<body>
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section{SetLevels}
***************************
Overview
***************************
1. We attach binding levels to Core bindings, in preparation for floating
outwards (@FloatOut@).
2. We also let-ify many expressions (notably case scrutinees), so they
will have a fighting chance of being floated sensible.
3. We clone the binders of any floatable let-binding, so that when it is
floated out it will be unique. (This used to be done by the simplifier
but the latter now only ensures that there's no shadowing; indeed, even
that may not be true.)
NOTE: this can't be done using the uniqAway idea, because the variable
must be unique in the whole program, not just its current scope,
because two variables in different scopes may float out to the
same top level place
NOTE: Very tiresomely, we must apply this substitution to
the rules stored inside a variable too.
We do *not* clone top-level bindings, because some of them must not change,
but we *do* clone bindings that are heading for the top level
4. In the expression
case x of wild { p -> ...wild... }
we substitute x for wild in the RHS of the case alternatives:
case x of wild { p -> ...x... }
This means that a sub-expression involving x is not "trapped" inside the RHS.
And it's not inconvenient because we already have a substitution.
Note that this is EXACTLY BACKWARDS from the what the simplifier does.
The simplifier tries to get rid of occurrences of x, in favour of wild,
in the hope that there will only be one remaining occurrence of x, namely
the scrutinee of the case, and we can inline it.
\begin{code}
<pre><a name="line-1"></a><span class='hs-keyword'>module</span> <span class='hs-conid'>SetLevels</span> <span class='hs-layout'>(</span>
<a name="line-2"></a> <span class='hs-varid'>setLevels</span><span class='hs-layout'>,</span>
<a name="line-3"></a>
<a name="line-4"></a> <span class='hs-conid'>Level</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>..</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-varid'>tOP_LEVEL</span><span class='hs-layout'>,</span>
<a name="line-5"></a> <span class='hs-conid'>LevelledBind</span><span class='hs-layout'>,</span> <span class='hs-conid'>LevelledExpr</span><span class='hs-layout'>,</span>
<a name="line-6"></a>
<a name="line-7"></a> <span class='hs-varid'>incMinorLvl</span><span class='hs-layout'>,</span> <span class='hs-varid'>ltMajLvl</span><span class='hs-layout'>,</span> <span class='hs-varid'>ltLvl</span><span class='hs-layout'>,</span> <span class='hs-varid'>isTopLvl</span><span class='hs-layout'>,</span> <span class='hs-varid'>isInlineCtxt</span>
<a name="line-8"></a> <span class='hs-layout'>)</span> <span class='hs-keyword'>where</span>
<a name="line-9"></a>
<a name="line-10"></a><span class='hs-cpp'>#include "HsVersions.h"</span>
<a name="line-11"></a>
<a name="line-12"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>CoreSyn</span>
<a name="line-13"></a>
<a name="line-14"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>DynFlags</span> <span class='hs-layout'>(</span> <span class='hs-conid'>FloatOutSwitches</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>..</span><span class='hs-layout'>)</span> <span class='hs-layout'>)</span>
<a name="line-15"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>CoreUtils</span> <span class='hs-layout'>(</span> <span class='hs-varid'>exprType</span><span class='hs-layout'>,</span> <span class='hs-varid'>exprIsTrivial</span><span class='hs-layout'>,</span> <span class='hs-varid'>mkPiTypes</span> <span class='hs-layout'>)</span>
<a name="line-16"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>CoreFVs</span> <span class='hs-comment'>-- all of it</span>
<a name="line-17"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>CoreSubst</span> <span class='hs-layout'>(</span> <span class='hs-conid'>Subst</span><span class='hs-layout'>,</span> <span class='hs-varid'>emptySubst</span><span class='hs-layout'>,</span> <span class='hs-varid'>extendInScope</span><span class='hs-layout'>,</span> <span class='hs-varid'>extendIdSubst</span><span class='hs-layout'>,</span>
<a name="line-18"></a> <span class='hs-varid'>cloneIdBndr</span><span class='hs-layout'>,</span> <span class='hs-varid'>cloneRecIdBndrs</span> <span class='hs-layout'>)</span>
<a name="line-19"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Id</span> <span class='hs-layout'>(</span> <span class='hs-varid'>idType</span><span class='hs-layout'>,</span> <span class='hs-varid'>mkSysLocal</span><span class='hs-layout'>,</span> <span class='hs-varid'>isOneShotLambda</span><span class='hs-layout'>,</span>
<a name="line-20"></a> <span class='hs-varid'>zapDemandIdInfo</span><span class='hs-layout'>,</span> <span class='hs-varid'>transferPolyIdInfo</span><span class='hs-layout'>,</span>
<a name="line-21"></a> <span class='hs-varid'>idSpecialisation</span><span class='hs-layout'>,</span> <span class='hs-varid'>idWorkerInfo</span><span class='hs-layout'>,</span> <span class='hs-varid'>setIdInfo</span>
<a name="line-22"></a> <span class='hs-layout'>)</span>
<a name="line-23"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>IdInfo</span>
<a name="line-24"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Var</span>
<a name="line-25"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>VarSet</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'>Name</span> <span class='hs-layout'>(</span> <span class='hs-varid'>getOccName</span> <span class='hs-layout'>)</span>
<a name="line-28"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>OccName</span> <span class='hs-layout'>(</span> <span class='hs-varid'>occNameString</span> <span class='hs-layout'>)</span>
<a name="line-29"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Type</span> <span class='hs-layout'>(</span> <span class='hs-varid'>isUnLiftedType</span><span class='hs-layout'>,</span> <span class='hs-conid'>Type</span> <span class='hs-layout'>)</span>
<a name="line-30"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>BasicTypes</span> <span class='hs-layout'>(</span> <span class='hs-conid'>TopLevelFlag</span><span class='hs-layout'>(</span><span class='hs-keyglyph'>..</span><span class='hs-layout'>)</span> <span class='hs-layout'>)</span>
<a name="line-31"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>UniqSupply</span>
<a name="line-32"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Util</span> <span class='hs-layout'>(</span> <span class='hs-varid'>sortLe</span><span class='hs-layout'>,</span> <span class='hs-varid'>isSingleton</span><span class='hs-layout'>,</span> <span class='hs-varid'>count</span> <span class='hs-layout'>)</span>
<a name="line-33"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Outputable</span>
<a name="line-34"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>FastString</span>
</pre>\end{code}
%************************************************************************
%* *
\subsection{Level numbers}
%* *
%************************************************************************
\begin{code}
<pre><a name="line-1"></a><a name="Level"></a><span class='hs-keyword'>data</span> <span class='hs-conid'>Level</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>InlineCtxt</span> <span class='hs-comment'>-- A level that's used only for</span>
<a name="line-2"></a> <span class='hs-comment'>-- the context parameter ctxt_lvl</span>
<a name="line-3"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>Level</span> <span class='hs-conid'>Int</span> <span class='hs-comment'>-- Level number of enclosing lambdas</span>
<a name="line-4"></a> <span class='hs-conid'>Int</span> <span class='hs-comment'>-- Number of big-lambda and/or case expressions between</span>
<a name="line-5"></a> <span class='hs-comment'>-- here and the nearest enclosing lambda</span>
</pre>\end{code}
The {\em level number} on a (type-)lambda-bound variable is the
nesting depth of the (type-)lambda which binds it. The outermost lambda
has level 1, so (Level 0 0) means that the variable is bound outside any lambda.
On an expression, it's the maximum level number of its free
(type-)variables. On a let(rec)-bound variable, it's the level of its
RHS. On a case-bound variable, it's the number of enclosing lambdas.
Top-level variables: level~0. Those bound on the RHS of a top-level
definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown
as ``subscripts'')...
\begin{verbatim}
a_0 = let b_? = ... in
x_1 = ... b ... in ...
\end{verbatim}
The main function @lvlExpr@ carries a ``context level'' (@ctxt_lvl@).
That's meant to be the level number of the enclosing binder in the
final (floated) program. If the level number of a sub-expression is
less than that of the context, then it might be worth let-binding the
sub-expression so that it will indeed float.
If you can float to level @Level 0 0@ worth doing so because then your
allocation becomes static instead of dynamic. We always start with
context @Level 0 0@.
Note [FloatOut inside INLINE]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@InlineCtxt@ very similar to @Level 0 0@, but is used for one purpose:
to say "don't float anything out of here". That's exactly what we
want for the body of an INLINE, where we don't want to float anything
out at all. See notes with lvlMFE below.
But, check this out:
-- At one time I tried the effect of not float anything out of an InlineMe,
-- but it sometimes works badly. For example, consider PrelArr.done. It
-- has the form __inline (\d. e)
-- where e doesn't mention d. If we float this to
-- __inline (let x = e in \d. x)
-- things are bad. The inliner doesn't even inline it because it doesn't look
-- like a head-normal form. So it seems a lesser evil to let things float.
-- In SetLevels we do set the context to (Level 0 0) when we get to an InlineMe
-- which discourages floating out.
So the conclusion is: don't do any floating at all inside an InlineMe.
(In the above example, don't float the {x=e} out of the \d.)
One particular case is that of workers: we don't want to float the
call to the worker outside the wrapper, otherwise the worker might get
inlined into the floated expression, and an importing module won't see
the worker at all.
\begin{code}
<pre><a name="line-1"></a><a name="LevelledExpr"></a><span class='hs-keyword'>type</span> <span class='hs-conid'>LevelledExpr</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>TaggedExpr</span> <span class='hs-conid'>Level</span>
<a name="line-2"></a><a name="LevelledBind"></a><span class='hs-keyword'>type</span> <span class='hs-conid'>LevelledBind</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>TaggedBind</span> <span class='hs-conid'>Level</span>
<a name="line-3"></a>
<a name="line-4"></a><a name="tOP_LEVEL"></a><span class='hs-definition'>tOP_LEVEL</span><span class='hs-layout'>,</span> <span class='hs-varid'>iNLINE_CTXT</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Level</span>
<a name="line-5"></a><span class='hs-definition'>tOP_LEVEL</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Level</span> <span class='hs-num'>0</span> <span class='hs-num'>0</span>
<a name="line-6"></a><a name="iNLINE_CTXT"></a><span class='hs-definition'>iNLINE_CTXT</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>InlineCtxt</span>
<a name="line-7"></a>
<a name="line-8"></a><a name="incMajorLvl"></a><span class='hs-definition'>incMajorLvl</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Level</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Level</span>
<a name="line-9"></a><span class='hs-comment'>-- For InlineCtxt we ignore any inc's; we don't want</span>
<a name="line-10"></a><span class='hs-comment'>-- to do any floating at all; see notes above</span>
<a name="line-11"></a><span class='hs-definition'>incMajorLvl</span> <span class='hs-conid'>InlineCtxt</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>InlineCtxt</span>
<a name="line-12"></a><span class='hs-definition'>incMajorLvl</span> <span class='hs-layout'>(</span><span class='hs-conid'>Level</span> <span class='hs-varid'>major</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Level</span> <span class='hs-layout'>(</span><span class='hs-varid'>major</span> <span class='hs-varop'>+</span> <span class='hs-num'>1</span><span class='hs-layout'>)</span> <span class='hs-num'>0</span>
<a name="line-13"></a>
<a name="line-14"></a><a name="incMinorLvl"></a><span class='hs-definition'>incMinorLvl</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Level</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Level</span>
<a name="line-15"></a><span class='hs-definition'>incMinorLvl</span> <span class='hs-conid'>InlineCtxt</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>InlineCtxt</span>
<a name="line-16"></a><span class='hs-definition'>incMinorLvl</span> <span class='hs-layout'>(</span><span class='hs-conid'>Level</span> <span class='hs-varid'>major</span> <span class='hs-varid'>minor</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Level</span> <span class='hs-varid'>major</span> <span class='hs-layout'>(</span><span class='hs-varid'>minor</span><span class='hs-varop'>+</span><span class='hs-num'>1</span><span class='hs-layout'>)</span>
<a name="line-17"></a>
<a name="line-18"></a><a name="maxLvl"></a><span class='hs-definition'>maxLvl</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Level</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Level</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Level</span>
<a name="line-19"></a><span class='hs-definition'>maxLvl</span> <span class='hs-conid'>InlineCtxt</span> <span class='hs-varid'>l2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>l2</span>
<a name="line-20"></a><span class='hs-definition'>maxLvl</span> <span class='hs-varid'>l1</span> <span class='hs-conid'>InlineCtxt</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>l1</span>
<a name="line-21"></a><span class='hs-definition'>maxLvl</span> <span class='hs-varid'>l1</span><span class='hs-keyglyph'>@</span><span class='hs-layout'>(</span><span class='hs-conid'>Level</span> <span class='hs-varid'>maj1</span> <span class='hs-varid'>min1</span><span class='hs-layout'>)</span> <span class='hs-varid'>l2</span><span class='hs-keyglyph'>@</span><span class='hs-layout'>(</span><span class='hs-conid'>Level</span> <span class='hs-varid'>maj2</span> <span class='hs-varid'>min2</span><span class='hs-layout'>)</span>
<a name="line-22"></a> <span class='hs-keyglyph'>|</span> <span class='hs-layout'>(</span><span class='hs-varid'>maj1</span> <span class='hs-varop'>></span> <span class='hs-varid'>maj2</span><span class='hs-layout'>)</span> <span class='hs-varop'>||</span> <span class='hs-layout'>(</span><span class='hs-varid'>maj1</span> <span class='hs-varop'>==</span> <span class='hs-varid'>maj2</span> <span class='hs-varop'>&&</span> <span class='hs-varid'>min1</span> <span class='hs-varop'>></span> <span class='hs-varid'>min2</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>l1</span>
<a name="line-23"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>l2</span>
<a name="line-24"></a>
<a name="line-25"></a><a name="ltLvl"></a><span class='hs-definition'>ltLvl</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Level</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Level</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Bool</span>
<a name="line-26"></a><span class='hs-definition'>ltLvl</span> <span class='hs-keyword'>_</span> <span class='hs-conid'>InlineCtxt</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>False</span>
<a name="line-27"></a><span class='hs-definition'>ltLvl</span> <span class='hs-conid'>InlineCtxt</span> <span class='hs-layout'>(</span><span class='hs-conid'>Level</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>True</span>
<a name="line-28"></a><span class='hs-definition'>ltLvl</span> <span class='hs-layout'>(</span><span class='hs-conid'>Level</span> <span class='hs-varid'>maj1</span> <span class='hs-varid'>min1</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>Level</span> <span class='hs-varid'>maj2</span> <span class='hs-varid'>min2</span><span class='hs-layout'>)</span>
<a name="line-29"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>maj1</span> <span class='hs-varop'><</span> <span class='hs-varid'>maj2</span><span class='hs-layout'>)</span> <span class='hs-varop'>||</span> <span class='hs-layout'>(</span><span class='hs-varid'>maj1</span> <span class='hs-varop'>==</span> <span class='hs-varid'>maj2</span> <span class='hs-varop'>&&</span> <span class='hs-varid'>min1</span> <span class='hs-varop'><</span> <span class='hs-varid'>min2</span><span class='hs-layout'>)</span>
<a name="line-30"></a>
<a name="line-31"></a><a name="ltMajLvl"></a><span class='hs-definition'>ltMajLvl</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Level</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Level</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Bool</span>
<a name="line-32"></a> <span class='hs-comment'>-- Tells if one level belongs to a difft *lambda* level to another</span>
<a name="line-33"></a><span class='hs-definition'>ltMajLvl</span> <span class='hs-keyword'>_</span> <span class='hs-conid'>InlineCtxt</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>False</span>
<a name="line-34"></a><span class='hs-definition'>ltMajLvl</span> <span class='hs-conid'>InlineCtxt</span> <span class='hs-layout'>(</span><span class='hs-conid'>Level</span> <span class='hs-varid'>maj2</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-num'>0</span> <span class='hs-varop'><</span> <span class='hs-varid'>maj2</span>
<a name="line-35"></a><span class='hs-definition'>ltMajLvl</span> <span class='hs-layout'>(</span><span class='hs-conid'>Level</span> <span class='hs-varid'>maj1</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>Level</span> <span class='hs-varid'>maj2</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>maj1</span> <span class='hs-varop'><</span> <span class='hs-varid'>maj2</span>
<a name="line-36"></a>
<a name="line-37"></a><a name="isTopLvl"></a><span class='hs-definition'>isTopLvl</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Level</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Bool</span>
<a name="line-38"></a><span class='hs-definition'>isTopLvl</span> <span class='hs-layout'>(</span><span class='hs-conid'>Level</span> <span class='hs-num'>0</span> <span class='hs-num'>0</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>True</span>
<a name="line-39"></a><span class='hs-definition'>isTopLvl</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>False</span>
<a name="line-40"></a>
<a name="line-41"></a><a name="isInlineCtxt"></a><span class='hs-definition'>isInlineCtxt</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Level</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Bool</span>
<a name="line-42"></a><span class='hs-definition'>isInlineCtxt</span> <span class='hs-conid'>InlineCtxt</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>True</span>
<a name="line-43"></a><span class='hs-definition'>isInlineCtxt</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>False</span>
<a name="line-44"></a>
<a name="line-45"></a><span class='hs-keyword'>instance</span> <span class='hs-conid'>Outputable</span> <span class='hs-conid'>Level</span> <span class='hs-keyword'>where</span>
<a name="line-46"></a> <span class='hs-varid'>ppr</span> <span class='hs-conid'>InlineCtxt</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>text</span> <span class='hs-str'>"<INLINE>"</span>
<a name="line-47"></a> <span class='hs-varid'>ppr</span> <span class='hs-layout'>(</span><span class='hs-conid'>Level</span> <span class='hs-varid'>maj</span> <span class='hs-varid'>min</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>hcat</span> <span class='hs-keyglyph'>[</span> <span class='hs-varid'>char</span> <span class='hs-chr'>'<'</span><span class='hs-layout'>,</span> <span class='hs-varid'>int</span> <span class='hs-varid'>maj</span><span class='hs-layout'>,</span> <span class='hs-varid'>char</span> <span class='hs-chr'>','</span><span class='hs-layout'>,</span> <span class='hs-varid'>int</span> <span class='hs-varid'>min</span><span class='hs-layout'>,</span> <span class='hs-varid'>char</span> <span class='hs-chr'>'>'</span> <span class='hs-keyglyph'>]</span>
<a name="line-48"></a>
<a name="line-49"></a><span class='hs-keyword'>instance</span> <span class='hs-conid'>Eq</span> <span class='hs-conid'>Level</span> <span class='hs-keyword'>where</span>
<a name="line-50"></a> <span class='hs-conid'>InlineCtxt</span> <span class='hs-varop'>==</span> <span class='hs-conid'>InlineCtxt</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>True</span>
<a name="line-51"></a> <span class='hs-layout'>(</span><span class='hs-conid'>Level</span> <span class='hs-varid'>maj1</span> <span class='hs-varid'>min1</span><span class='hs-layout'>)</span> <span class='hs-varop'>==</span> <span class='hs-layout'>(</span><span class='hs-conid'>Level</span> <span class='hs-varid'>maj2</span> <span class='hs-varid'>min2</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>maj1</span> <span class='hs-varop'>==</span> <span class='hs-varid'>maj2</span> <span class='hs-varop'>&&</span> <span class='hs-varid'>min1</span> <span class='hs-varop'>==</span> <span class='hs-varid'>min2</span>
<a name="line-52"></a> <span class='hs-keyword'>_</span> <span class='hs-varop'>==</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>False</span>
</pre>\end{code}
%************************************************************************
%* *
\subsection{Main level-setting code}
%* *
%************************************************************************
\begin{code}
<pre><a name="line-1"></a><a name="setLevels"></a><span class='hs-definition'>setLevels</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>FloatOutSwitches</span>
<a name="line-2"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>CoreBind</span><span class='hs-keyglyph'>]</span>
<a name="line-3"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>UniqSupply</span>
<a name="line-4"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>LevelledBind</span><span class='hs-keyglyph'>]</span>
<a name="line-5"></a>
<a name="line-6"></a><span class='hs-definition'>setLevels</span> <span class='hs-varid'>float_lams</span> <span class='hs-varid'>binds</span> <span class='hs-varid'>us</span>
<a name="line-7"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>initLvl</span> <span class='hs-varid'>us</span> <span class='hs-layout'>(</span><span class='hs-varid'>do_them</span> <span class='hs-varid'>binds</span><span class='hs-layout'>)</span>
<a name="line-8"></a> <span class='hs-keyword'>where</span>
<a name="line-9"></a> <span class='hs-comment'>-- "do_them"'s main business is to thread the monad along</span>
<a name="line-10"></a> <span class='hs-comment'>-- It gives each top binding the same empty envt, because</span>
<a name="line-11"></a> <span class='hs-comment'>-- things unbound in the envt have level number zero implicitly</span>
<a name="line-12"></a> <span class='hs-varid'>do_them</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-conid'>LvlM</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>LevelledBind</span><span class='hs-keyglyph'>]</span>
<a name="line-13"></a>
<a name="line-14"></a> <span class='hs-varid'>do_them</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-15"></a> <span class='hs-varid'>do_them</span> <span class='hs-layout'>(</span><span class='hs-varid'>b</span><span class='hs-conop'>:</span><span class='hs-varid'>bs</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-16"></a> <span class='hs-layout'>(</span><span class='hs-varid'>lvld_bind</span><span class='hs-layout'>,</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lvlTopBind</span> <span class='hs-varid'>init_env</span> <span class='hs-varid'>b</span>
<a name="line-17"></a> <span class='hs-varid'>lvld_binds</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>do_them</span> <span class='hs-varid'>bs</span>
<a name="line-18"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>lvld_bind</span> <span class='hs-conop'>:</span> <span class='hs-varid'>lvld_binds</span><span class='hs-layout'>)</span>
<a name="line-19"></a>
<a name="line-20"></a> <span class='hs-varid'>init_env</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>initialEnv</span> <span class='hs-varid'>float_lams</span>
<a name="line-21"></a>
<a name="line-22"></a><a name="lvlTopBind"></a><span class='hs-definition'>lvlTopBind</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>LevelEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Bind</span> <span class='hs-conid'>Id</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LvlM</span> <span class='hs-layout'>(</span><span class='hs-conid'>LevelledBind</span><span class='hs-layout'>,</span> <span class='hs-conid'>LevelEnv</span><span class='hs-layout'>)</span>
<a name="line-23"></a><span class='hs-definition'>lvlTopBind</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-conid'>NonRec</span> <span class='hs-varid'>binder</span> <span class='hs-varid'>rhs</span><span class='hs-layout'>)</span>
<a name="line-24"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>lvlBind</span> <span class='hs-conid'>TopLevel</span> <span class='hs-varid'>tOP_LEVEL</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-conid'>AnnNonRec</span> <span class='hs-varid'>binder</span> <span class='hs-layout'>(</span><span class='hs-varid'>freeVars</span> <span class='hs-varid'>rhs</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-25"></a> <span class='hs-comment'>-- Rhs can have no free vars!</span>
<a name="line-26"></a>
<a name="line-27"></a><span class='hs-definition'>lvlTopBind</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-conid'>Rec</span> <span class='hs-varid'>pairs</span><span class='hs-layout'>)</span>
<a name="line-28"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>lvlBind</span> <span class='hs-conid'>TopLevel</span> <span class='hs-varid'>tOP_LEVEL</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-conid'>AnnRec</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>b</span><span class='hs-layout'>,</span><span class='hs-varid'>freeVars</span> <span class='hs-varid'>rhs</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>|</span> <span class='hs-layout'>(</span><span class='hs-varid'>b</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'>pairs</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
</pre>\end{code}
%************************************************************************
%* *
\subsection{Setting expression levels}
%* *
%************************************************************************
\begin{code}
<pre><a name="line-1"></a><a name="lvlExpr"></a><span class='hs-definition'>lvlExpr</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Level</span> <span class='hs-comment'>-- ctxt_lvl: Level of enclosing expression</span>
<a name="line-2"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LevelEnv</span> <span class='hs-comment'>-- Level of in-scope names/tyvars</span>
<a name="line-3"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExprWithFVs</span> <span class='hs-comment'>-- input expression</span>
<a name="line-4"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LvlM</span> <span class='hs-conid'>LevelledExpr</span> <span class='hs-comment'>-- Result expression</span>
</pre>\end{code}
The @ctxt_lvl@ is, roughly, the level of the innermost enclosing
binder. Here's an example
v = \x -> ...\y -> let r = case (..x..) of
..x..
in ..
When looking at the rhs of @r@, @ctxt_lvl@ will be 1 because that's
the level of @r@, even though it's inside a level-2 @\y@. It's
important that @ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we
don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE
--- because it isn't a *maximal* free expression.
If there were another lambda in @r@'s rhs, it would get level-2 as well.
\begin{code}
<pre><a name="line-1"></a><a name="lvlExpr"></a><span class='hs-definition'>lvlExpr</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-layout'>(</span> <span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-conid'>AnnType</span> <span class='hs-varid'>ty</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-conid'>Type</span> <span class='hs-varid'>ty</span><span class='hs-layout'>)</span>
<a name="line-2"></a><span class='hs-definition'>lvlExpr</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-conid'>AnnVar</span> <span class='hs-varid'>v</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'>lookupVar</span> <span class='hs-varid'>env</span> <span class='hs-varid'>v</span><span class='hs-layout'>)</span>
<a name="line-3"></a><span class='hs-definition'>lvlExpr</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-conid'>AnnLit</span> <span class='hs-varid'>lit</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-conid'>Lit</span> <span class='hs-varid'>lit</span><span class='hs-layout'>)</span>
<a name="line-4"></a>
<a name="line-5"></a><span class='hs-definition'>lvlExpr</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-conid'>AnnApp</span> <span class='hs-varid'>fun</span> <span class='hs-varid'>arg</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-6"></a> <span class='hs-varid'>fun'</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lvl_fun</span> <span class='hs-varid'>fun</span>
<a name="line-7"></a> <span class='hs-varid'>arg'</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lvlMFE</span> <span class='hs-conid'>False</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>arg</span>
<a name="line-8"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>App</span> <span class='hs-varid'>fun'</span> <span class='hs-varid'>arg'</span><span class='hs-layout'>)</span>
<a name="line-9"></a> <span class='hs-keyword'>where</span>
<a name="line-10"></a><span class='hs-comment'>-- gaw 2004</span>
<a name="line-11"></a> <span class='hs-varid'>lvl_fun</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-conid'>AnnCase</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</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'>lvlMFE</span> <span class='hs-conid'>True</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>fun</span>
<a name="line-12"></a> <span class='hs-varid'>lvl_fun</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>lvlExpr</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>fun</span>
<a name="line-13"></a> <span class='hs-comment'>-- We don't do MFE on partial applications generally,</span>
<a name="line-14"></a> <span class='hs-comment'>-- but we do if the function is big and hairy, like a case</span>
<a name="line-15"></a>
<a name="line-16"></a><span class='hs-definition'>lvlExpr</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-conid'>AnnNote</span> <span class='hs-conid'>InlineMe</span> <span class='hs-varid'>expr</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-17"></a><span class='hs-comment'>-- Don't float anything out of an InlineMe; hence the iNLINE_CTXT</span>
<a name="line-18"></a> <span class='hs-varid'>expr'</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lvlExpr</span> <span class='hs-varid'>iNLINE_CTXT</span> <span class='hs-varid'>env</span> <span class='hs-varid'>expr</span>
<a name="line-19"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>Note</span> <span class='hs-conid'>InlineMe</span> <span class='hs-varid'>expr'</span><span class='hs-layout'>)</span>
<a name="line-20"></a>
<a name="line-21"></a><span class='hs-definition'>lvlExpr</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-conid'>AnnNote</span> <span class='hs-varid'>note</span> <span class='hs-varid'>expr</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-22"></a> <span class='hs-varid'>expr'</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lvlExpr</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>expr</span>
<a name="line-23"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>Note</span> <span class='hs-varid'>note</span> <span class='hs-varid'>expr'</span><span class='hs-layout'>)</span>
<a name="line-24"></a>
<a name="line-25"></a><span class='hs-definition'>lvlExpr</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-conid'>AnnCast</span> <span class='hs-varid'>expr</span> <span class='hs-varid'>co</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-26"></a> <span class='hs-varid'>expr'</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lvlExpr</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>expr</span>
<a name="line-27"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>Cast</span> <span class='hs-varid'>expr'</span> <span class='hs-varid'>co</span><span class='hs-layout'>)</span>
<a name="line-28"></a>
<a name="line-29"></a><span class='hs-comment'>-- We don't split adjacent lambdas. That is, given</span>
<a name="line-30"></a><span class='hs-comment'>-- \x y -> (x+1,y)</span>
<a name="line-31"></a><span class='hs-comment'>-- we don't float to give </span>
<a name="line-32"></a><span class='hs-comment'>-- \x -> let v = x+y in \y -> (v,y)</span>
<a name="line-33"></a><span class='hs-comment'>-- Why not? Because partial applications are fairly rare, and splitting</span>
<a name="line-34"></a><span class='hs-comment'>-- lambdas makes them more expensive.</span>
<a name="line-35"></a>
<a name="line-36"></a><span class='hs-definition'>lvlExpr</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>expr</span><span class='hs-keyglyph'>@</span><span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-conid'>AnnLam</span> <span class='hs-layout'>{</span><span class='hs-layout'>}</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-37"></a> <span class='hs-varid'>new_body</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lvlMFE</span> <span class='hs-conid'>True</span> <span class='hs-varid'>new_lvl</span> <span class='hs-varid'>new_env</span> <span class='hs-varid'>body</span>
<a name="line-38"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkLams</span> <span class='hs-varid'>new_bndrs</span> <span class='hs-varid'>new_body</span><span class='hs-layout'>)</span>
<a name="line-39"></a> <span class='hs-keyword'>where</span>
<a name="line-40"></a> <span class='hs-layout'>(</span><span class='hs-varid'>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'>collectAnnBndrs</span> <span class='hs-varid'>expr</span>
<a name="line-41"></a> <span class='hs-layout'>(</span><span class='hs-varid'>new_lvl</span><span class='hs-layout'>,</span> <span class='hs-varid'>new_bndrs</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>lvlLamBndrs</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>bndrs</span>
<a name="line-42"></a> <span class='hs-varid'>new_env</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendLvlEnv</span> <span class='hs-varid'>env</span> <span class='hs-varid'>new_bndrs</span>
<a name="line-43"></a> <span class='hs-comment'>-- At one time we called a special verion of collectBinders,</span>
<a name="line-44"></a> <span class='hs-comment'>-- which ignored coercions, because we don't want to split</span>
<a name="line-45"></a> <span class='hs-comment'>-- a lambda like this (\x -> coerce t (\s -> ...))</span>
<a name="line-46"></a> <span class='hs-comment'>-- This used to happen quite a bit in state-transformer programs,</span>
<a name="line-47"></a> <span class='hs-comment'>-- but not nearly so much now non-recursive newtypes are transparent.</span>
<a name="line-48"></a> <span class='hs-comment'>-- [See SetLevels rev 1.50 for a version with this approach.]</span>
<a name="line-49"></a>
<a name="line-50"></a><span class='hs-definition'>lvlExpr</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-conid'>AnnLet</span> <span class='hs-layout'>(</span><span class='hs-conid'>AnnNonRec</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-51"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isUnLiftedType</span> <span class='hs-layout'>(</span><span class='hs-varid'>idType</span> <span class='hs-varid'>bndr</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-52"></a> <span class='hs-comment'>-- Treat unlifted let-bindings (let x = b in e) just like (case b of x -> e)</span>
<a name="line-53"></a> <span class='hs-comment'>-- That is, leave it exactly where it is</span>
<a name="line-54"></a> <span class='hs-comment'>-- We used to float unlifted bindings too (e.g. to get a cheap primop</span>
<a name="line-55"></a> <span class='hs-comment'>-- outside a lambda (to see how, look at lvlBind in rev 1.58)</span>
<a name="line-56"></a> <span class='hs-comment'>-- but an unrelated change meant that these unlifed bindings</span>
<a name="line-57"></a> <span class='hs-comment'>-- could get to the top level which is bad. And there's not much point;</span>
<a name="line-58"></a> <span class='hs-comment'>-- unlifted bindings are always cheap, and so hardly worth floating.</span>
<a name="line-59"></a> <span class='hs-varid'>rhs'</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lvlExpr</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>rhs</span>
<a name="line-60"></a> <span class='hs-varid'>body'</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lvlExpr</span> <span class='hs-varid'>incd_lvl</span> <span class='hs-varid'>env'</span> <span class='hs-varid'>body</span>
<a name="line-61"></a> <span class='hs-varid'>return</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-62"></a> <span class='hs-keyword'>where</span>
<a name="line-63"></a> <span class='hs-varid'>incd_lvl</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>incMinorLvl</span> <span class='hs-varid'>ctxt_lvl</span>
<a name="line-64"></a> <span class='hs-varid'>bndr'</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>TB</span> <span class='hs-varid'>bndr</span> <span class='hs-varid'>incd_lvl</span>
<a name="line-65"></a> <span class='hs-varid'>env'</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendLvlEnv</span> <span class='hs-varid'>env</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>bndr'</span><span class='hs-keyglyph'>]</span>
<a name="line-66"></a>
<a name="line-67"></a><span class='hs-definition'>lvlExpr</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-conid'>AnnLet</span> <span class='hs-varid'>bind</span> <span class='hs-varid'>body</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-68"></a> <span class='hs-layout'>(</span><span class='hs-varid'>bind'</span><span class='hs-layout'>,</span> <span class='hs-varid'>new_env</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lvlBind</span> <span class='hs-conid'>NotTopLevel</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>bind</span>
<a name="line-69"></a> <span class='hs-varid'>body'</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lvlExpr</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>new_env</span> <span class='hs-varid'>body</span>
<a name="line-70"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>Let</span> <span class='hs-varid'>bind'</span> <span class='hs-varid'>body'</span><span class='hs-layout'>)</span>
<a name="line-71"></a>
<a name="line-72"></a><span class='hs-definition'>lvlExpr</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-conid'>AnnCase</span> <span class='hs-varid'>expr</span> <span class='hs-varid'>case_bndr</span> <span class='hs-varid'>ty</span> <span class='hs-varid'>alts</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-73"></a> <span class='hs-varid'>expr'</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lvlMFE</span> <span class='hs-conid'>True</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>expr</span>
<a name="line-74"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>alts_env</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendCaseBndrLvlEnv</span> <span class='hs-varid'>env</span> <span class='hs-varid'>expr'</span> <span class='hs-varid'>case_bndr</span> <span class='hs-varid'>incd_lvl</span>
<a name="line-75"></a> <span class='hs-varid'>alts'</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapM</span> <span class='hs-layout'>(</span><span class='hs-varid'>lvl_alt</span> <span class='hs-varid'>alts_env</span><span class='hs-layout'>)</span> <span class='hs-varid'>alts</span>
<a name="line-76"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>Case</span> <span class='hs-varid'>expr'</span> <span class='hs-layout'>(</span><span class='hs-conid'>TB</span> <span class='hs-varid'>case_bndr</span> <span class='hs-varid'>incd_lvl</span><span class='hs-layout'>)</span> <span class='hs-varid'>ty</span> <span class='hs-varid'>alts'</span><span class='hs-layout'>)</span>
<a name="line-77"></a> <span class='hs-keyword'>where</span>
<a name="line-78"></a> <span class='hs-varid'>incd_lvl</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>incMinorLvl</span> <span class='hs-varid'>ctxt_lvl</span>
<a name="line-79"></a>
<a name="line-80"></a> <span class='hs-varid'>lvl_alt</span> <span class='hs-varid'>alts_env</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> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-81"></a> <span class='hs-varid'>rhs'</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lvlMFE</span> <span class='hs-conid'>True</span> <span class='hs-varid'>incd_lvl</span> <span class='hs-varid'>new_env</span> <span class='hs-varid'>rhs</span>
<a name="line-82"></a> <span class='hs-varid'>return</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-83"></a> <span class='hs-keyword'>where</span>
<a name="line-84"></a> <span class='hs-varid'>bs'</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span> <span class='hs-conid'>TB</span> <span class='hs-varid'>b</span> <span class='hs-varid'>incd_lvl</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>b</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>bs</span> <span class='hs-keyglyph'>]</span>
<a name="line-85"></a> <span class='hs-varid'>new_env</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendLvlEnv</span> <span class='hs-varid'>alts_env</span> <span class='hs-varid'>bs'</span>
</pre>\end{code}
@lvlMFE@ is just like @lvlExpr@, except that it might let-bind
the expression, so that it can itself be floated.
Note [Unlifted MFEs]
~~~~~~~~~~~~~~~~~~~~~
We don't float unlifted MFEs, which potentially loses big opportunites.
For example:
\x -> f (h y)
where h :: Int -> Int# is expensive. We'd like to float the (h y) outside
the \x, but we don't because it's unboxed. Possible solution: box it.
Note [Case MFEs]
~~~~~~~~~~~~~~~~
We don't float a case expression as an MFE from a strict context. Why not?
Because in doing so we share a tiny bit of computation (the switch) but
in exchange we build a thunk, which is bad. This case reduces allocation
by 7% in spectral/puzzle (a rather strange benchmark) and 1.2% in real/fem.
Doesn't change any other allocation at all.
\begin{code}
<pre><a name="line-1"></a><a name="lvlMFE"></a><span class='hs-definition'>lvlMFE</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Bool</span> <span class='hs-comment'>-- True <=> strict context [body of case or let]</span>
<a name="line-2"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Level</span> <span class='hs-comment'>-- Level of innermost enclosing lambda/tylam</span>
<a name="line-3"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LevelEnv</span> <span class='hs-comment'>-- Level of in-scope names/tyvars</span>
<a name="line-4"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExprWithFVs</span> <span class='hs-comment'>-- input expression</span>
<a name="line-5"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LvlM</span> <span class='hs-conid'>LevelledExpr</span> <span class='hs-comment'>-- Result expression</span>
<a name="line-6"></a>
<a name="line-7"></a><span class='hs-definition'>lvlMFE</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-conid'>AnnType</span> <span class='hs-varid'>ty</span><span class='hs-layout'>)</span>
<a name="line-8"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>Type</span> <span class='hs-varid'>ty</span><span class='hs-layout'>)</span>
<a name="line-9"></a>
<a name="line-10"></a><span class='hs-comment'>-- No point in floating out an expression wrapped in a coercion;</span>
<a name="line-11"></a><span class='hs-comment'>-- If we do we'll transform lvl = e |> co </span>
<a name="line-12"></a><span class='hs-comment'>-- to lvl' = e; lvl = lvl' |> co</span>
<a name="line-13"></a><span class='hs-comment'>-- and then inline lvl. Better just to float out the payload.</span>
<a name="line-14"></a><span class='hs-definition'>lvlMFE</span> <span class='hs-varid'>strict_ctxt</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-conid'>AnnCast</span> <span class='hs-varid'>e</span> <span class='hs-varid'>co</span><span class='hs-layout'>)</span>
<a name="line-15"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-layout'>{</span> <span class='hs-varid'>expr'</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lvlMFE</span> <span class='hs-varid'>strict_ctxt</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>e</span>
<a name="line-16"></a> <span class='hs-layout'>;</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>Cast</span> <span class='hs-varid'>expr'</span> <span class='hs-varid'>co</span><span class='hs-layout'>)</span> <span class='hs-layout'>}</span>
<a name="line-17"></a>
<a name="line-18"></a><span class='hs-comment'>-- Note [Case MFEs]</span>
<a name="line-19"></a><span class='hs-definition'>lvlMFE</span> <span class='hs-conid'>True</span> <span class='hs-varid'>ctxt_lvl</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-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-conid'>AnnCase</span> <span class='hs-layout'>{</span><span class='hs-layout'>}</span><span class='hs-layout'>)</span>
<a name="line-20"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>lvlExpr</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>e</span> <span class='hs-comment'>-- Don't share cases</span>
<a name="line-21"></a>
<a name="line-22"></a><span class='hs-definition'>lvlMFE</span> <span class='hs-varid'>strict_ctxt</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>ann_expr</span><span class='hs-keyglyph'>@</span><span class='hs-layout'>(</span><span class='hs-varid'>fvs</span><span class='hs-layout'>,</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span>
<a name="line-23"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isUnLiftedType</span> <span class='hs-varid'>ty</span> <span class='hs-comment'>-- Can't let-bind it; see Note [Unlifted MFEs]</span>
<a name="line-24"></a> <span class='hs-varop'>||</span> <span class='hs-varid'>isInlineCtxt</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-comment'>-- Don't float out of an __inline__ context</span>
<a name="line-25"></a> <span class='hs-varop'>||</span> <span class='hs-varid'>exprIsTrivial</span> <span class='hs-varid'>expr</span> <span class='hs-comment'>-- Never float if it's trivial</span>
<a name="line-26"></a> <span class='hs-varop'>||</span> <span class='hs-varid'>not</span> <span class='hs-varid'>good_destination</span>
<a name="line-27"></a> <span class='hs-keyglyph'>=</span> <span class='hs-comment'>-- Don't float it out</span>
<a name="line-28"></a> <span class='hs-varid'>lvlExpr</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>ann_expr</span>
<a name="line-29"></a>
<a name="line-30"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-comment'>-- Float it out!</span>
<a name="line-31"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-varid'>expr'</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lvlFloatRhs</span> <span class='hs-varid'>abs_vars</span> <span class='hs-varid'>dest_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>ann_expr</span>
<a name="line-32"></a> <span class='hs-varid'>var</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newLvlVar</span> <span class='hs-str'>"lvl"</span> <span class='hs-varid'>abs_vars</span> <span class='hs-varid'>ty</span>
<a name="line-33"></a> <span class='hs-varid'>return</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-layout'>(</span><span class='hs-conid'>TB</span> <span class='hs-varid'>var</span> <span class='hs-varid'>dest_lvl</span><span class='hs-layout'>)</span> <span class='hs-varid'>expr'</span><span class='hs-layout'>)</span>
<a name="line-34"></a> <span class='hs-layout'>(</span><span class='hs-varid'>mkVarApps</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>var</span><span class='hs-layout'>)</span> <span class='hs-varid'>abs_vars</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-35"></a> <span class='hs-keyword'>where</span>
<a name="line-36"></a> <span class='hs-varid'>expr</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>deAnnotate</span> <span class='hs-varid'>ann_expr</span>
<a name="line-37"></a> <span class='hs-varid'>ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>exprType</span> <span class='hs-varid'>expr</span>
<a name="line-38"></a> <span class='hs-varid'>dest_lvl</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>destLevel</span> <span class='hs-varid'>env</span> <span class='hs-varid'>fvs</span> <span class='hs-layout'>(</span><span class='hs-varid'>isFunction</span> <span class='hs-varid'>ann_expr</span><span class='hs-layout'>)</span>
<a name="line-39"></a> <span class='hs-varid'>abs_vars</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>abstractVars</span> <span class='hs-varid'>dest_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>fvs</span>
<a name="line-40"></a>
<a name="line-41"></a> <span class='hs-comment'>-- A decision to float entails let-binding this thing, and we only do </span>
<a name="line-42"></a> <span class='hs-comment'>-- that if we'll escape a value lambda, or will go to the top level.</span>
<a name="line-43"></a> <span class='hs-varid'>good_destination</span>
<a name="line-44"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>dest_lvl</span> <span class='hs-varop'>`ltMajLvl`</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-comment'>-- Escapes a value lambda</span>
<a name="line-45"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>True</span>
<a name="line-46"></a> <span class='hs-comment'>-- OLD CODE: not (exprIsCheap expr) || isTopLvl dest_lvl</span>
<a name="line-47"></a> <span class='hs-comment'>-- see Note [Escaping a value lambda]</span>
<a name="line-48"></a>
<a name="line-49"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-comment'>-- Does not escape a value lambda</span>
<a name="line-50"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>isTopLvl</span> <span class='hs-varid'>dest_lvl</span> <span class='hs-comment'>-- Only float if we are going to the top level</span>
<a name="line-51"></a> <span class='hs-varop'>&&</span> <span class='hs-varid'>floatConsts</span> <span class='hs-varid'>env</span> <span class='hs-comment'>-- and the floatConsts flag is on</span>
<a name="line-52"></a> <span class='hs-varop'>&&</span> <span class='hs-varid'>not</span> <span class='hs-varid'>strict_ctxt</span> <span class='hs-comment'>-- Don't float from a strict context </span>
<a name="line-53"></a> <span class='hs-comment'>-- We are keen to float something to the top level, even if it does not</span>
<a name="line-54"></a> <span class='hs-comment'>-- escape a lambda, because then it needs no allocation. But it's controlled</span>
<a name="line-55"></a> <span class='hs-comment'>-- by a flag, because doing this too early loses opportunities for RULES</span>
<a name="line-56"></a> <span class='hs-comment'>-- which (needless to say) are important in some nofib programs</span>
<a name="line-57"></a> <span class='hs-comment'>-- (gcd is an example).</span>
<a name="line-58"></a> <span class='hs-comment'>--</span>
<a name="line-59"></a> <span class='hs-comment'>-- Beware:</span>
<a name="line-60"></a> <span class='hs-comment'>-- concat = /\ a -> foldr ..a.. (++) []</span>
<a name="line-61"></a> <span class='hs-comment'>-- was getting turned into</span>
<a name="line-62"></a> <span class='hs-comment'>-- concat = /\ a -> lvl a</span>
<a name="line-63"></a> <span class='hs-comment'>-- lvl = /\ a -> foldr ..a.. (++) []</span>
<a name="line-64"></a> <span class='hs-comment'>-- which is pretty stupid. Hence the strict_ctxt test</span>
</pre>\end{code}
Note [Escaping a value lambda]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We want to float even cheap expressions out of value lambdas,
because that saves allocation. Consider
f = \x. .. (\y.e) ...
Then we'd like to avoid allocating the (\y.e) every time we call f,
(assuming e does not mention x).
An example where this really makes a difference is simplrun009.
Another reason it's good is because it makes SpecContr fire on functions.
Consider
f = \x. ....(f (\y.e))....
After floating we get
lvl = \y.e
f = \x. ....(f lvl)...
and that is much easier for SpecConstr to generate a robust specialisation for.
The OLD CODE (given where this Note is referred to) prevents floating
of the example above, so I just don't understand the old code. I
don't understand the old comment either (which appears below). I
measured the effect on nofib of changing OLD CODE to 'True', and got
zeros everywhere, but a 4% win for 'puzzle'. Very small 0.5% loss for
'cse'; turns out to be because our arity analysis isn't good enough
yet (mentioned in Simon-nofib-notes).
OLD comment was:
Even if it escapes a value lambda, we only
float if it's not cheap (unless it'll get all the
way to the top). I've seen cases where we
float dozens of tiny free expressions, which cost
more to allocate than to evaluate.
NB: exprIsCheap is also true of bottom expressions, which
is good; we don't want to share them
It's only Really Bad to float a cheap expression out of a
strict context, because that builds a thunk that otherwise
would never be built. So another alternative would be to
add
|| (strict_ctxt && not (exprIsBottom expr))
to the condition above. We should really try this out.
%************************************************************************
%* *
\subsection{Bindings}
%* *
%************************************************************************
The binding stuff works for top level too.
\begin{code}
<pre><a name="line-1"></a><a name="lvlBind"></a><span class='hs-definition'>lvlBind</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>TopLevelFlag</span> <span class='hs-comment'>-- Used solely to decide whether to clone</span>
<a name="line-2"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Level</span> <span class='hs-comment'>-- Context level; might be Top even for bindings nested in the RHS</span>
<a name="line-3"></a> <span class='hs-comment'>-- of a top level binding</span>
<a name="line-4"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LevelEnv</span>
<a name="line-5"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreBindWithFVs</span>
<a name="line-6"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LvlM</span> <span class='hs-layout'>(</span><span class='hs-conid'>LevelledBind</span><span class='hs-layout'>,</span> <span class='hs-conid'>LevelEnv</span><span class='hs-layout'>)</span>
<a name="line-7"></a>
<a name="line-8"></a><span class='hs-definition'>lvlBind</span> <span class='hs-varid'>top_lvl</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-conid'>AnnNonRec</span> <span class='hs-varid'>bndr</span> <span class='hs-varid'>rhs</span><span class='hs-keyglyph'>@</span><span class='hs-layout'>(</span><span class='hs-varid'>rhs_fvs</span><span class='hs-layout'>,</span><span class='hs-keyword'>_</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-9"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isTyVar</span> <span class='hs-varid'>bndr</span> <span class='hs-comment'>-- Don't do anything for TyVar binders</span>
<a name="line-10"></a> <span class='hs-comment'>-- (simplifier gets rid of them pronto)</span>
<a name="line-11"></a> <span class='hs-varop'>||</span> <span class='hs-varid'>isInlineCtxt</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-comment'>-- Don't do anything inside InlineMe</span>
<a name="line-12"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-varid'>rhs'</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lvlExpr</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>rhs</span>
<a name="line-13"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>NonRec</span> <span class='hs-layout'>(</span><span class='hs-conid'>TB</span> <span class='hs-varid'>bndr</span> <span class='hs-varid'>ctxt_lvl</span><span class='hs-layout'>)</span> <span class='hs-varid'>rhs'</span><span class='hs-layout'>,</span> <span class='hs-varid'>env</span><span class='hs-layout'>)</span>
<a name="line-14"></a>
<a name="line-15"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>null</span> <span class='hs-varid'>abs_vars</span>
<a name="line-16"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-comment'>-- No type abstraction; clone existing binder</span>
<a name="line-17"></a> <span class='hs-varid'>rhs'</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lvlExpr</span> <span class='hs-varid'>dest_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>rhs</span>
<a name="line-18"></a> <span class='hs-layout'>(</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-keyglyph'><-</span> <span class='hs-varid'>cloneVar</span> <span class='hs-varid'>top_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>bndr</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>dest_lvl</span>
<a name="line-19"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>NonRec</span> <span class='hs-layout'>(</span><span class='hs-conid'>TB</span> <span class='hs-varid'>bndr'</span> <span class='hs-varid'>dest_lvl</span><span class='hs-layout'>)</span> <span class='hs-varid'>rhs'</span><span class='hs-layout'>,</span> <span class='hs-varid'>env'</span><span class='hs-layout'>)</span>
<a name="line-20"></a>
<a name="line-21"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span>
<a name="line-22"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-comment'>-- Yes, type abstraction; create a new binder, extend substitution, etc</span>
<a name="line-23"></a> <span class='hs-varid'>rhs'</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lvlFloatRhs</span> <span class='hs-varid'>abs_vars</span> <span class='hs-varid'>dest_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>rhs</span>
<a name="line-24"></a> <span class='hs-layout'>(</span><span class='hs-varid'>env'</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-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newPolyBndrs</span> <span class='hs-varid'>dest_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>abs_vars</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>bndr</span><span class='hs-keyglyph'>]</span>
<a name="line-25"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>NonRec</span> <span class='hs-layout'>(</span><span class='hs-conid'>TB</span> <span class='hs-varid'>bndr'</span> <span class='hs-varid'>dest_lvl</span><span class='hs-layout'>)</span> <span class='hs-varid'>rhs'</span><span class='hs-layout'>,</span> <span class='hs-varid'>env'</span><span class='hs-layout'>)</span>
<a name="line-26"></a>
<a name="line-27"></a> <span class='hs-keyword'>where</span>
<a name="line-28"></a> <span class='hs-varid'>bind_fvs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>rhs_fvs</span> <span class='hs-varop'>`unionVarSet`</span> <span class='hs-varid'>idFreeVars</span> <span class='hs-varid'>bndr</span>
<a name="line-29"></a> <span class='hs-varid'>abs_vars</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>abstractVars</span> <span class='hs-varid'>dest_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>bind_fvs</span>
<a name="line-30"></a> <span class='hs-varid'>dest_lvl</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>destLevel</span> <span class='hs-varid'>env</span> <span class='hs-varid'>bind_fvs</span> <span class='hs-layout'>(</span><span class='hs-varid'>isFunction</span> <span class='hs-varid'>rhs</span><span class='hs-layout'>)</span>
</pre>\end{code}
\begin{code}
<pre><a name="line-1"></a><a name="lvlBind"></a><span class='hs-definition'>lvlBind</span> <span class='hs-varid'>top_lvl</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-conid'>AnnRec</span> <span class='hs-varid'>pairs</span><span class='hs-layout'>)</span>
<a name="line-2"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isInlineCtxt</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-comment'>-- Don't do anything inside InlineMe</span>
<a name="line-3"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-varid'>rhss'</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapM</span> <span class='hs-layout'>(</span><span class='hs-varid'>lvlExpr</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>env</span><span class='hs-layout'>)</span> <span class='hs-varid'>rhss</span>
<a name="line-4"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>Rec</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-conid'>TB</span> <span class='hs-varid'>b</span> <span class='hs-varid'>ctxt_lvl</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-varop'>`zip`</span> <span class='hs-varid'>rhss'</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-varid'>env</span><span class='hs-layout'>)</span>
<a name="line-5"></a>
<a name="line-6"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>null</span> <span class='hs-varid'>abs_vars</span>
<a name="line-7"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-layout'>(</span><span class='hs-varid'>new_env</span><span class='hs-layout'>,</span> <span class='hs-varid'>new_bndrs</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>cloneRecVars</span> <span class='hs-varid'>top_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>bndrs</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>dest_lvl</span>
<a name="line-8"></a> <span class='hs-varid'>new_rhss</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapM</span> <span class='hs-layout'>(</span><span class='hs-varid'>lvlExpr</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>new_env</span><span class='hs-layout'>)</span> <span class='hs-varid'>rhss</span>
<a name="line-9"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>Rec</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-conid'>TB</span> <span class='hs-varid'>b</span> <span class='hs-varid'>dest_lvl</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>b</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>new_bndrs</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'>`zip`</span> <span class='hs-varid'>new_rhss</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-varid'>new_env</span><span class='hs-layout'>)</span>
<a name="line-10"></a>
<a name="line-11"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isSingleton</span> <span class='hs-varid'>pairs</span> <span class='hs-varop'>&&</span> <span class='hs-varid'>count</span> <span class='hs-varid'>isId</span> <span class='hs-varid'>abs_vars</span> <span class='hs-varop'>></span> <span class='hs-num'>1</span>
<a name="line-12"></a> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-comment'>-- Special case for self recursion where there are</span>
<a name="line-13"></a> <span class='hs-comment'>-- several variables carried around: build a local loop: </span>
<a name="line-14"></a> <span class='hs-comment'>-- poly_f = \abs_vars. \lam_vars . letrec f = \lam_vars. rhs in f lam_vars</span>
<a name="line-15"></a> <span class='hs-comment'>-- This just makes the closures a bit smaller. If we don't do</span>
<a name="line-16"></a> <span class='hs-comment'>-- this, allocation rises significantly on some programs</span>
<a name="line-17"></a> <span class='hs-comment'>--</span>
<a name="line-18"></a> <span class='hs-comment'>-- We could elaborate it for the case where there are several</span>
<a name="line-19"></a> <span class='hs-comment'>-- mutually functions, but it's quite a bit more complicated</span>
<a name="line-20"></a> <span class='hs-comment'>-- </span>
<a name="line-21"></a> <span class='hs-comment'>-- This all seems a bit ad hoc -- sigh</span>
<a name="line-22"></a> <span class='hs-keyword'>let</span>
<a name="line-23"></a> <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> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>head</span> <span class='hs-varid'>pairs</span>
<a name="line-24"></a> <span class='hs-layout'>(</span><span class='hs-varid'>rhs_lvl</span><span class='hs-layout'>,</span> <span class='hs-varid'>abs_vars_w_lvls</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>lvlLamBndrs</span> <span class='hs-varid'>dest_lvl</span> <span class='hs-varid'>abs_vars</span>
<a name="line-25"></a> <span class='hs-varid'>rhs_env</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendLvlEnv</span> <span class='hs-varid'>env</span> <span class='hs-varid'>abs_vars_w_lvls</span>
<a name="line-26"></a> <span class='hs-layout'>(</span><span class='hs-varid'>rhs_env'</span><span class='hs-layout'>,</span> <span class='hs-varid'>new_bndr</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>cloneVar</span> <span class='hs-conid'>NotTopLevel</span> <span class='hs-varid'>rhs_env</span> <span class='hs-varid'>bndr</span> <span class='hs-varid'>rhs_lvl</span> <span class='hs-varid'>rhs_lvl</span>
<a name="line-27"></a> <span class='hs-keyword'>let</span>
<a name="line-28"></a> <span class='hs-layout'>(</span><span class='hs-varid'>lam_bndrs</span><span class='hs-layout'>,</span> <span class='hs-varid'>rhs_body</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>collectAnnBndrs</span> <span class='hs-varid'>rhs</span>
<a name="line-29"></a> <span class='hs-layout'>(</span><span class='hs-varid'>body_lvl</span><span class='hs-layout'>,</span> <span class='hs-varid'>new_lam_bndrs</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>lvlLamBndrs</span> <span class='hs-varid'>rhs_lvl</span> <span class='hs-varid'>lam_bndrs</span>
<a name="line-30"></a> <span class='hs-varid'>body_env</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendLvlEnv</span> <span class='hs-varid'>rhs_env'</span> <span class='hs-varid'>new_lam_bndrs</span>
<a name="line-31"></a> <span class='hs-varid'>new_rhs_body</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lvlExpr</span> <span class='hs-varid'>body_lvl</span> <span class='hs-varid'>body_env</span> <span class='hs-varid'>rhs_body</span>
<a name="line-32"></a> <span class='hs-layout'>(</span><span class='hs-varid'>poly_env</span><span class='hs-layout'>,</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>poly_bndr</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newPolyBndrs</span> <span class='hs-varid'>dest_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>abs_vars</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>bndr</span><span class='hs-keyglyph'>]</span>
<a name="line-33"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>Rec</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>TB</span> <span class='hs-varid'>poly_bndr</span> <span class='hs-varid'>dest_lvl</span><span class='hs-layout'>,</span>
<a name="line-34"></a> <span class='hs-varid'>mkLams</span> <span class='hs-varid'>abs_vars_w_lvls</span> <span class='hs-varop'>$</span>
<a name="line-35"></a> <span class='hs-varid'>mkLams</span> <span class='hs-varid'>new_lam_bndrs</span> <span class='hs-varop'>$</span>
<a name="line-36"></a> <span class='hs-conid'>Let</span> <span class='hs-layout'>(</span><span class='hs-conid'>Rec</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>TB</span> <span class='hs-varid'>new_bndr</span> <span class='hs-varid'>rhs_lvl</span><span class='hs-layout'>,</span> <span class='hs-varid'>mkLams</span> <span class='hs-varid'>new_lam_bndrs</span> <span class='hs-varid'>new_rhs_body</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-37"></a> <span class='hs-layout'>(</span><span class='hs-varid'>mkVarApps</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>new_bndr</span><span class='hs-layout'>)</span> <span class='hs-varid'>lam_bndrs</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span>
<a name="line-38"></a> <span class='hs-varid'>poly_env</span><span class='hs-layout'>)</span>
<a name="line-39"></a>
<a name="line-40"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span> <span class='hs-comment'>-- Non-null abs_vars</span>
<a name="line-41"></a> <span class='hs-layout'>(</span><span class='hs-varid'>new_env</span><span class='hs-layout'>,</span> <span class='hs-varid'>new_bndrs</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>newPolyBndrs</span> <span class='hs-varid'>dest_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>abs_vars</span> <span class='hs-varid'>bndrs</span>
<a name="line-42"></a> <span class='hs-varid'>new_rhss</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>mapM</span> <span class='hs-layout'>(</span><span class='hs-varid'>lvlFloatRhs</span> <span class='hs-varid'>abs_vars</span> <span class='hs-varid'>dest_lvl</span> <span class='hs-varid'>new_env</span><span class='hs-layout'>)</span> <span class='hs-varid'>rhss</span>
<a name="line-43"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>Rec</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-conid'>TB</span> <span class='hs-varid'>b</span> <span class='hs-varid'>dest_lvl</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>b</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>new_bndrs</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'>`zip`</span> <span class='hs-varid'>new_rhss</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-varid'>new_env</span><span class='hs-layout'>)</span>
<a name="line-44"></a>
<a name="line-45"></a> <span class='hs-keyword'>where</span>
<a name="line-46"></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'>pairs</span>
<a name="line-47"></a>
<a name="line-48"></a> <span class='hs-comment'>-- Finding the free vars of the binding group is annoying</span>
<a name="line-49"></a> <span class='hs-varid'>bind_fvs</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>unionVarSets</span> <span class='hs-keyglyph'>[</span> <span class='hs-varid'>idFreeVars</span> <span class='hs-varid'>bndr</span> <span class='hs-varop'>`unionVarSet`</span> <span class='hs-varid'>rhs_fvs</span>
<a name="line-50"></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-layout'>(</span><span class='hs-varid'>rhs_fvs</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'>pairs</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-51"></a> <span class='hs-varop'>`minusVarSet`</span>
<a name="line-52"></a> <span class='hs-varid'>mkVarSet</span> <span class='hs-varid'>bndrs</span>
<a name="line-53"></a>
<a name="line-54"></a> <span class='hs-varid'>dest_lvl</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>destLevel</span> <span class='hs-varid'>env</span> <span class='hs-varid'>bind_fvs</span> <span class='hs-layout'>(</span><span class='hs-varid'>all</span> <span class='hs-varid'>isFunction</span> <span class='hs-varid'>rhss</span><span class='hs-layout'>)</span>
<a name="line-55"></a> <span class='hs-varid'>abs_vars</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>abstractVars</span> <span class='hs-varid'>dest_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>bind_fvs</span>
<a name="line-56"></a>
<a name="line-57"></a><span class='hs-comment'>----------------------------------------------------</span>
<a name="line-58"></a><span class='hs-comment'>-- Three help functons for the type-abstraction case</span>
<a name="line-59"></a>
<a name="line-60"></a><a name="lvlFloatRhs"></a><span class='hs-definition'>lvlFloatRhs</span> <span class='hs-keyglyph'>::</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>CoreBndr</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Level</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LevelEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CoreExprWithFVs</span>
<a name="line-61"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>UniqSM</span> <span class='hs-layout'>(</span><span class='hs-conid'>Expr</span> <span class='hs-layout'>(</span><span class='hs-conid'>TaggedBndr</span> <span class='hs-conid'>Level</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-62"></a><span class='hs-definition'>lvlFloatRhs</span> <span class='hs-varid'>abs_vars</span> <span class='hs-varid'>dest_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>rhs</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-63"></a> <span class='hs-varid'>rhs'</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lvlExpr</span> <span class='hs-varid'>rhs_lvl</span> <span class='hs-varid'>rhs_env</span> <span class='hs-varid'>rhs</span>
<a name="line-64"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkLams</span> <span class='hs-varid'>abs_vars_w_lvls</span> <span class='hs-varid'>rhs'</span><span class='hs-layout'>)</span>
<a name="line-65"></a> <span class='hs-keyword'>where</span>
<a name="line-66"></a> <span class='hs-layout'>(</span><span class='hs-varid'>rhs_lvl</span><span class='hs-layout'>,</span> <span class='hs-varid'>abs_vars_w_lvls</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>lvlLamBndrs</span> <span class='hs-varid'>dest_lvl</span> <span class='hs-varid'>abs_vars</span>
<a name="line-67"></a> <span class='hs-varid'>rhs_env</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendLvlEnv</span> <span class='hs-varid'>env</span> <span class='hs-varid'>abs_vars_w_lvls</span>
</pre>\end{code}
%************************************************************************
%* *
\subsection{Deciding floatability}
%* *
%************************************************************************
\begin{code}
<pre><a name="line-1"></a><a name="lvlLamBndrs"></a><span class='hs-definition'>lvlLamBndrs</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Level</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>CoreBndr</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>Level</span><span class='hs-layout'>,</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>TaggedBndr</span> <span class='hs-conid'>Level</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-2"></a><span class='hs-comment'>-- Compute the levels for the binders of a lambda group</span>
<a name="line-3"></a><span class='hs-comment'>-- The binders returned are exactly the same as the ones passed,</span>
<a name="line-4"></a><span class='hs-comment'>-- but they are now paired with a level</span>
<a name="line-5"></a><span class='hs-definition'>lvlLamBndrs</span> <span class='hs-varid'>lvl</span> <span class='hs-conid'>[]</span>
<a name="line-6"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>lvl</span><span class='hs-layout'>,</span> <span class='hs-conid'>[]</span><span class='hs-layout'>)</span>
<a name="line-7"></a>
<a name="line-8"></a><span class='hs-definition'>lvlLamBndrs</span> <span class='hs-varid'>lvl</span> <span class='hs-varid'>bndrs</span>
<a name="line-9"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>go</span> <span class='hs-layout'>(</span><span class='hs-varid'>incMinorLvl</span> <span class='hs-varid'>lvl</span><span class='hs-layout'>)</span>
<a name="line-10"></a> <span class='hs-conid'>False</span> <span class='hs-comment'>-- Havn't bumped major level in this group</span>
<a name="line-11"></a> <span class='hs-conid'>[]</span> <span class='hs-varid'>bndrs</span>
<a name="line-12"></a> <span class='hs-keyword'>where</span>
<a name="line-13"></a> <span class='hs-varid'>go</span> <span class='hs-varid'>old_lvl</span> <span class='hs-varid'>bumped_major</span> <span class='hs-varid'>rev_lvld_bndrs</span> <span class='hs-layout'>(</span><span class='hs-varid'>bndr</span><span class='hs-conop'>:</span><span class='hs-varid'>bndrs</span><span class='hs-layout'>)</span>
<a name="line-14"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isId</span> <span class='hs-varid'>bndr</span> <span class='hs-varop'>&&</span> <span class='hs-comment'>-- Go to the next major level if this is a value binder,</span>
<a name="line-15"></a> <span class='hs-varid'>not</span> <span class='hs-varid'>bumped_major</span> <span class='hs-varop'>&&</span> <span class='hs-comment'>-- and we havn't already gone to the next level (one jump per group)</span>
<a name="line-16"></a> <span class='hs-varid'>not</span> <span class='hs-layout'>(</span><span class='hs-varid'>isOneShotLambda</span> <span class='hs-varid'>bndr</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- and it isn't a one-shot lambda</span>
<a name="line-17"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>go</span> <span class='hs-varid'>new_lvl</span> <span class='hs-conid'>True</span> <span class='hs-layout'>(</span><span class='hs-conid'>TB</span> <span class='hs-varid'>bndr</span> <span class='hs-varid'>new_lvl</span> <span class='hs-conop'>:</span> <span class='hs-varid'>rev_lvld_bndrs</span><span class='hs-layout'>)</span> <span class='hs-varid'>bndrs</span>
<a name="line-18"></a>
<a name="line-19"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span>
<a name="line-20"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>go</span> <span class='hs-varid'>old_lvl</span> <span class='hs-varid'>bumped_major</span> <span class='hs-layout'>(</span><span class='hs-conid'>TB</span> <span class='hs-varid'>bndr</span> <span class='hs-varid'>old_lvl</span> <span class='hs-conop'>:</span> <span class='hs-varid'>rev_lvld_bndrs</span><span class='hs-layout'>)</span> <span class='hs-varid'>bndrs</span>
<a name="line-21"></a>
<a name="line-22"></a> <span class='hs-keyword'>where</span>
<a name="line-23"></a> <span class='hs-varid'>new_lvl</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>incMajorLvl</span> <span class='hs-varid'>old_lvl</span>
<a name="line-24"></a>
<a name="line-25"></a> <span class='hs-varid'>go</span> <span class='hs-varid'>old_lvl</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>rev_lvld_bndrs</span> <span class='hs-conid'>[]</span>
<a name="line-26"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>old_lvl</span><span class='hs-layout'>,</span> <span class='hs-varid'>reverse</span> <span class='hs-varid'>rev_lvld_bndrs</span><span class='hs-layout'>)</span>
<a name="line-27"></a> <span class='hs-comment'>-- a lambda like this (\x -> coerce t (\s -> ...))</span>
<a name="line-28"></a> <span class='hs-comment'>-- This happens quite a bit in state-transformer programs</span>
</pre>\end{code}
\begin{code}
<pre><a name="line-1"></a> <span class='hs-comment'>-- Destintion level is the max Id level of the expression</span>
<a name="line-2"></a> <span class='hs-comment'>-- (We'll abstract the type variables, if any.)</span>
<a name="line-3"></a><a name="destLevel"></a><span class='hs-definition'>destLevel</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>LevelEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>VarSet</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Bool</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Level</span>
<a name="line-4"></a><span class='hs-definition'>destLevel</span> <span class='hs-varid'>env</span> <span class='hs-varid'>fvs</span> <span class='hs-varid'>is_function</span>
<a name="line-5"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>floatLams</span> <span class='hs-varid'>env</span>
<a name="line-6"></a> <span class='hs-varop'>&&</span> <span class='hs-varid'>is_function</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>tOP_LEVEL</span> <span class='hs-comment'>-- Send functions to top level; see</span>
<a name="line-7"></a> <span class='hs-comment'>-- the comments with isFunction</span>
<a name="line-8"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>maxIdLevel</span> <span class='hs-varid'>env</span> <span class='hs-varid'>fvs</span>
<a name="line-9"></a>
<a name="line-10"></a><a name="isFunction"></a><span class='hs-definition'>isFunction</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>CoreExprWithFVs</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Bool</span>
<a name="line-11"></a><span class='hs-comment'>-- The idea here is that we want to float *functions* to</span>
<a name="line-12"></a><span class='hs-comment'>-- the top level. This saves no work, but </span>
<a name="line-13"></a><span class='hs-comment'>-- (a) it can make the host function body a lot smaller, </span>
<a name="line-14"></a><span class='hs-comment'>-- and hence inlinable. </span>
<a name="line-15"></a><span class='hs-comment'>-- (b) it can also save allocation when the function is recursive:</span>
<a name="line-16"></a><span class='hs-comment'>-- h = \x -> letrec f = \y -> ...f...y...x...</span>
<a name="line-17"></a><span class='hs-comment'>-- in f x</span>
<a name="line-18"></a><span class='hs-comment'>-- becomes</span>
<a name="line-19"></a><span class='hs-comment'>-- f = \x y -> ...(f x)...y...x...</span>
<a name="line-20"></a><span class='hs-comment'>-- h = \x -> f x x</span>
<a name="line-21"></a><span class='hs-comment'>-- No allocation for f now.</span>
<a name="line-22"></a><span class='hs-comment'>-- We may only want to do this if there are sufficiently few free </span>
<a name="line-23"></a><span class='hs-comment'>-- variables. We certainly only want to do it for values, and not for</span>
<a name="line-24"></a><span class='hs-comment'>-- constructors. So the simple thing is just to look for lambdas</span>
<a name="line-25"></a><span class='hs-definition'>isFunction</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-conid'>AnnLam</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-varid'>isId</span> <span class='hs-varid'>b</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>True</span>
<a name="line-26"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>isFunction</span> <span class='hs-varid'>e</span>
<a name="line-27"></a><span class='hs-definition'>isFunction</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-conid'>AnnNote</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>e</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>isFunction</span> <span class='hs-varid'>e</span>
<a name="line-28"></a><span class='hs-definition'>isFunction</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>False</span>
</pre>\end{code}
%************************************************************************
%* *
\subsection{Free-To-Level Monad}
%* *
%************************************************************************
\begin{code}
<pre><a name="line-1"></a><a name="LevelEnv"></a><span class='hs-keyword'>type</span> <span class='hs-conid'>LevelEnv</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-conid'>FloatOutSwitches</span><span class='hs-layout'>,</span>
<a name="line-2"></a> <span class='hs-conid'>VarEnv</span> <span class='hs-conid'>Level</span><span class='hs-layout'>,</span> <span class='hs-comment'>-- Domain is *post-cloned* TyVars and Ids</span>
<a name="line-3"></a> <span class='hs-conid'>Subst</span><span class='hs-layout'>,</span> <span class='hs-comment'>-- Domain is pre-cloned Ids; tracks the in-scope set</span>
<a name="line-4"></a> <span class='hs-comment'>-- so that subtitution is capture-avoiding</span>
<a name="line-5"></a> <span class='hs-conid'>IdEnv</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-conid'>LevelledExpr</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- Domain is pre-cloned Ids</span>
<a name="line-6"></a> <span class='hs-comment'>-- We clone let-bound variables so that they are still</span>
<a name="line-7"></a> <span class='hs-comment'>-- distinct when floated out; hence the SubstEnv/IdEnv.</span>
<a name="line-8"></a> <span class='hs-comment'>-- (see point 3 of the module overview comment).</span>
<a name="line-9"></a> <span class='hs-comment'>-- We also use these envs when making a variable polymorphic</span>
<a name="line-10"></a> <span class='hs-comment'>-- because we want to float it out past a big lambda.</span>
<a name="line-11"></a> <span class='hs-comment'>--</span>
<a name="line-12"></a> <span class='hs-comment'>-- The Subst and IdEnv always implement the same mapping, but the</span>
<a name="line-13"></a> <span class='hs-comment'>-- Subst maps to CoreExpr and the IdEnv to LevelledExpr</span>
<a name="line-14"></a> <span class='hs-comment'>-- Since the range is always a variable or type application,</span>
<a name="line-15"></a> <span class='hs-comment'>-- there is never any difference between the two, but sadly</span>
<a name="line-16"></a> <span class='hs-comment'>-- the types differ. The SubstEnv is used when substituting in</span>
<a name="line-17"></a> <span class='hs-comment'>-- a variable's IdInfo; the IdEnv when we find a Var.</span>
<a name="line-18"></a> <span class='hs-comment'>--</span>
<a name="line-19"></a> <span class='hs-comment'>-- In addition the IdEnv records a list of tyvars free in the</span>
<a name="line-20"></a> <span class='hs-comment'>-- type application, just so we don't have to call freeVars on</span>
<a name="line-21"></a> <span class='hs-comment'>-- the type application repeatedly.</span>
<a name="line-22"></a> <span class='hs-comment'>--</span>
<a name="line-23"></a> <span class='hs-comment'>-- The domain of the both envs is *pre-cloned* Ids, though</span>
<a name="line-24"></a> <span class='hs-comment'>--</span>
<a name="line-25"></a> <span class='hs-comment'>-- The domain of the VarEnv Level is the *post-cloned* Ids</span>
<a name="line-26"></a>
<a name="line-27"></a><a name="initialEnv"></a><span class='hs-definition'>initialEnv</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>FloatOutSwitches</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LevelEnv</span>
<a name="line-28"></a><span class='hs-definition'>initialEnv</span> <span class='hs-varid'>float_lams</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>float_lams</span><span class='hs-layout'>,</span> <span class='hs-varid'>emptyVarEnv</span><span class='hs-layout'>,</span> <span class='hs-varid'>emptySubst</span><span class='hs-layout'>,</span> <span class='hs-varid'>emptyVarEnv</span><span class='hs-layout'>)</span>
<a name="line-29"></a>
<a name="line-30"></a><a name="floatLams"></a><span class='hs-definition'>floatLams</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>LevelEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Bool</span>
<a name="line-31"></a><span class='hs-definition'>floatLams</span> <span class='hs-layout'>(</span><span class='hs-varid'>fos</span><span class='hs-layout'>,</span> <span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>floatOutLambdas</span> <span class='hs-varid'>fos</span>
<a name="line-32"></a>
<a name="line-33"></a><a name="floatConsts"></a><span class='hs-definition'>floatConsts</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>LevelEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Bool</span>
<a name="line-34"></a><span class='hs-definition'>floatConsts</span> <span class='hs-layout'>(</span><span class='hs-varid'>fos</span><span class='hs-layout'>,</span> <span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>floatOutConstants</span> <span class='hs-varid'>fos</span>
<a name="line-35"></a>
<a name="line-36"></a><a name="extendLvlEnv"></a><span class='hs-definition'>extendLvlEnv</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>LevelEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>TaggedBndr</span> <span class='hs-conid'>Level</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LevelEnv</span>
<a name="line-37"></a><span class='hs-comment'>-- Used when *not* cloning</span>
<a name="line-38"></a><span class='hs-definition'>extendLvlEnv</span> <span class='hs-layout'>(</span><span class='hs-varid'>float_lams</span><span class='hs-layout'>,</span> <span class='hs-varid'>lvl_env</span><span class='hs-layout'>,</span> <span class='hs-varid'>subst</span><span class='hs-layout'>,</span> <span class='hs-varid'>id_env</span><span class='hs-layout'>)</span> <span class='hs-varid'>prs</span>
<a name="line-39"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>float_lams</span><span class='hs-layout'>,</span>
<a name="line-40"></a> <span class='hs-varid'>foldl</span> <span class='hs-varid'>add_lvl</span> <span class='hs-varid'>lvl_env</span> <span class='hs-varid'>prs</span><span class='hs-layout'>,</span>
<a name="line-41"></a> <span class='hs-varid'>foldl</span> <span class='hs-varid'>del_subst</span> <span class='hs-varid'>subst</span> <span class='hs-varid'>prs</span><span class='hs-layout'>,</span>
<a name="line-42"></a> <span class='hs-varid'>foldl</span> <span class='hs-varid'>del_id</span> <span class='hs-varid'>id_env</span> <span class='hs-varid'>prs</span><span class='hs-layout'>)</span>
<a name="line-43"></a> <span class='hs-keyword'>where</span>
<a name="line-44"></a> <span class='hs-varid'>add_lvl</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-conid'>TB</span> <span class='hs-varid'>v</span> <span class='hs-varid'>l</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendVarEnv</span> <span class='hs-varid'>env</span> <span class='hs-varid'>v</span> <span class='hs-varid'>l</span>
<a name="line-45"></a> <span class='hs-varid'>del_subst</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-conid'>TB</span> <span class='hs-varid'>v</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendInScope</span> <span class='hs-varid'>env</span> <span class='hs-varid'>v</span>
<a name="line-46"></a> <span class='hs-varid'>del_id</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-conid'>TB</span> <span class='hs-varid'>v</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>delVarEnv</span> <span class='hs-varid'>env</span> <span class='hs-varid'>v</span>
<a name="line-47"></a> <span class='hs-comment'>-- We must remove any clone for this variable name in case of</span>
<a name="line-48"></a> <span class='hs-comment'>-- shadowing. This bit me in the following case</span>
<a name="line-49"></a> <span class='hs-comment'>-- (in nofib/real/gg/Spark.hs):</span>
<a name="line-50"></a> <span class='hs-comment'>-- </span>
<a name="line-51"></a> <span class='hs-comment'>-- case ds of wild {</span>
<a name="line-52"></a> <span class='hs-comment'>-- ... -> case e of wild {</span>
<a name="line-53"></a> <span class='hs-comment'>-- ... -> ... wild ...</span>
<a name="line-54"></a> <span class='hs-comment'>-- }</span>
<a name="line-55"></a> <span class='hs-comment'>-- }</span>
<a name="line-56"></a> <span class='hs-comment'>-- </span>
<a name="line-57"></a> <span class='hs-comment'>-- The inside occurrence of @wild@ was being replaced with @ds@,</span>
<a name="line-58"></a> <span class='hs-comment'>-- incorrectly, because the SubstEnv was still lying around. Ouch!</span>
<a name="line-59"></a> <span class='hs-comment'>-- KSW 2000-07.</span>
<a name="line-60"></a>
<a name="line-61"></a><a name="extendCaseBndrLvlEnv"></a><span class='hs-comment'>-- extendCaseBndrLvlEnv adds the mapping case-bndr->scrut-var if it can</span>
<a name="line-62"></a><span class='hs-comment'>-- (see point 4 of the module overview comment)</span>
<a name="line-63"></a><span class='hs-definition'>extendCaseBndrLvlEnv</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>LevelEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Expr</span> <span class='hs-layout'>(</span><span class='hs-conid'>TaggedBndr</span> <span class='hs-conid'>Level</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-conid'>Level</span>
<a name="line-64"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LevelEnv</span>
<a name="line-65"></a><span class='hs-definition'>extendCaseBndrLvlEnv</span> <span class='hs-layout'>(</span><span class='hs-varid'>float_lams</span><span class='hs-layout'>,</span> <span class='hs-varid'>lvl_env</span><span class='hs-layout'>,</span> <span class='hs-varid'>subst</span><span class='hs-layout'>,</span> <span class='hs-varid'>id_env</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>scrut_var</span><span class='hs-layout'>)</span> <span class='hs-varid'>case_bndr</span> <span class='hs-varid'>lvl</span>
<a name="line-66"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>float_lams</span><span class='hs-layout'>,</span>
<a name="line-67"></a> <span class='hs-varid'>extendVarEnv</span> <span class='hs-varid'>lvl_env</span> <span class='hs-varid'>case_bndr</span> <span class='hs-varid'>lvl</span><span class='hs-layout'>,</span>
<a name="line-68"></a> <span class='hs-varid'>extendIdSubst</span> <span class='hs-varid'>subst</span> <span class='hs-varid'>case_bndr</span> <span class='hs-layout'>(</span><span class='hs-conid'>Var</span> <span class='hs-varid'>scrut_var</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span>
<a name="line-69"></a> <span class='hs-varid'>extendVarEnv</span> <span class='hs-varid'>id_env</span> <span class='hs-varid'>case_bndr</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-varid'>scrut_var</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span> <span class='hs-conid'>Var</span> <span class='hs-varid'>scrut_var</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-70"></a>
<a name="line-71"></a><span class='hs-definition'>extendCaseBndrLvlEnv</span> <span class='hs-varid'>env</span> <span class='hs-sel'>_scrut</span> <span class='hs-varid'>case_bndr</span> <span class='hs-varid'>lvl</span>
<a name="line-72"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendLvlEnv</span> <span class='hs-varid'>env</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>TB</span> <span class='hs-varid'>case_bndr</span> <span class='hs-varid'>lvl</span><span class='hs-keyglyph'>]</span>
<a name="line-73"></a>
<a name="line-74"></a><a name="extendPolyLvlEnv"></a><span class='hs-definition'>extendPolyLvlEnv</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Level</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LevelEnv</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-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>Var</span><span class='hs-layout'>,</span> <span class='hs-conid'>Var</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LevelEnv</span>
<a name="line-75"></a><span class='hs-definition'>extendPolyLvlEnv</span> <span class='hs-varid'>dest_lvl</span> <span class='hs-layout'>(</span><span class='hs-varid'>float_lams</span><span class='hs-layout'>,</span> <span class='hs-varid'>lvl_env</span><span class='hs-layout'>,</span> <span class='hs-varid'>subst</span><span class='hs-layout'>,</span> <span class='hs-varid'>id_env</span><span class='hs-layout'>)</span> <span class='hs-varid'>abs_vars</span> <span class='hs-varid'>bndr_pairs</span>
<a name="line-76"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>float_lams</span><span class='hs-layout'>,</span>
<a name="line-77"></a> <span class='hs-varid'>foldl</span> <span class='hs-varid'>add_lvl</span> <span class='hs-varid'>lvl_env</span> <span class='hs-varid'>bndr_pairs</span><span class='hs-layout'>,</span>
<a name="line-78"></a> <span class='hs-varid'>foldl</span> <span class='hs-varid'>add_subst</span> <span class='hs-varid'>subst</span> <span class='hs-varid'>bndr_pairs</span><span class='hs-layout'>,</span>
<a name="line-79"></a> <span class='hs-varid'>foldl</span> <span class='hs-varid'>add_id</span> <span class='hs-varid'>id_env</span> <span class='hs-varid'>bndr_pairs</span><span class='hs-layout'>)</span>
<a name="line-80"></a> <span class='hs-keyword'>where</span>
<a name="line-81"></a> <span class='hs-varid'>add_lvl</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-varid'>v'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendVarEnv</span> <span class='hs-varid'>env</span> <span class='hs-varid'>v'</span> <span class='hs-varid'>dest_lvl</span>
<a name="line-82"></a> <span class='hs-varid'>add_subst</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-varid'>v</span><span class='hs-layout'>,</span> <span class='hs-varid'>v'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendIdSubst</span> <span class='hs-varid'>env</span> <span class='hs-varid'>v</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkVarApps</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'>abs_vars</span><span class='hs-layout'>)</span>
<a name="line-83"></a> <span class='hs-varid'>add_id</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-varid'>v</span><span class='hs-layout'>,</span> <span class='hs-varid'>v'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendVarEnv</span> <span class='hs-varid'>env</span> <span class='hs-varid'>v</span> <span class='hs-layout'>(</span><span class='hs-layout'>(</span><span class='hs-varid'>v'</span><span class='hs-conop'>:</span><span class='hs-varid'>abs_vars</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-varid'>mkVarApps</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'>abs_vars</span><span class='hs-layout'>)</span>
<a name="line-84"></a>
<a name="line-85"></a><a name="extendCloneLvlEnv"></a><span class='hs-definition'>extendCloneLvlEnv</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Level</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LevelEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Subst</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'>Var</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LevelEnv</span>
<a name="line-86"></a><span class='hs-definition'>extendCloneLvlEnv</span> <span class='hs-varid'>lvl</span> <span class='hs-layout'>(</span><span class='hs-varid'>float_lams</span><span class='hs-layout'>,</span> <span class='hs-varid'>lvl_env</span><span class='hs-layout'>,</span> <span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-varid'>id_env</span><span class='hs-layout'>)</span> <span class='hs-varid'>new_subst</span> <span class='hs-varid'>bndr_pairs</span>
<a name="line-87"></a> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>float_lams</span><span class='hs-layout'>,</span>
<a name="line-88"></a> <span class='hs-varid'>foldl</span> <span class='hs-varid'>add_lvl</span> <span class='hs-varid'>lvl_env</span> <span class='hs-varid'>bndr_pairs</span><span class='hs-layout'>,</span>
<a name="line-89"></a> <span class='hs-varid'>new_subst</span><span class='hs-layout'>,</span>
<a name="line-90"></a> <span class='hs-varid'>foldl</span> <span class='hs-varid'>add_id</span> <span class='hs-varid'>id_env</span> <span class='hs-varid'>bndr_pairs</span><span class='hs-layout'>)</span>
<a name="line-91"></a> <span class='hs-keyword'>where</span>
<a name="line-92"></a> <span class='hs-varid'>add_lvl</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-varid'>v'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendVarEnv</span> <span class='hs-varid'>env</span> <span class='hs-varid'>v'</span> <span class='hs-varid'>lvl</span>
<a name="line-93"></a> <span class='hs-varid'>add_id</span> <span class='hs-varid'>env</span> <span class='hs-layout'>(</span><span class='hs-varid'>v</span><span class='hs-layout'>,</span> <span class='hs-varid'>v'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendVarEnv</span> <span class='hs-varid'>env</span> <span class='hs-varid'>v</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>[</span><span class='hs-varid'>v'</span><span class='hs-keyglyph'>]</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-94"></a>
<a name="line-95"></a>
<a name="line-96"></a><a name="maxIdLevel"></a><span class='hs-definition'>maxIdLevel</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>LevelEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>VarSet</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Level</span>
<a name="line-97"></a><span class='hs-definition'>maxIdLevel</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-varid'>lvl_env</span><span class='hs-layout'>,</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-varid'>id_env</span><span class='hs-layout'>)</span> <span class='hs-varid'>var_set</span>
<a name="line-98"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>foldVarSet</span> <span class='hs-varid'>max_in</span> <span class='hs-varid'>tOP_LEVEL</span> <span class='hs-varid'>var_set</span>
<a name="line-99"></a> <span class='hs-keyword'>where</span>
<a name="line-100"></a> <span class='hs-varid'>max_in</span> <span class='hs-varid'>in_var</span> <span class='hs-varid'>lvl</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>foldr</span> <span class='hs-varid'>max_out</span> <span class='hs-varid'>lvl</span> <span class='hs-layout'>(</span><span class='hs-keyword'>case</span> <span class='hs-varid'>lookupVarEnv</span> <span class='hs-varid'>id_env</span> <span class='hs-varid'>in_var</span> <span class='hs-keyword'>of</span>
<a name="line-101"></a> <span class='hs-conid'>Just</span> <span class='hs-layout'>(</span><span class='hs-varid'>abs_vars</span><span class='hs-layout'>,</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>abs_vars</span>
<a name="line-102"></a> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>in_var</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-103"></a>
<a name="line-104"></a> <span class='hs-varid'>max_out</span> <span class='hs-varid'>out_var</span> <span class='hs-varid'>lvl</span>
<a name="line-105"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isId</span> <span class='hs-varid'>out_var</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>case</span> <span class='hs-varid'>lookupVarEnv</span> <span class='hs-varid'>lvl_env</span> <span class='hs-varid'>out_var</span> <span class='hs-keyword'>of</span>
<a name="line-106"></a> <span class='hs-conid'>Just</span> <span class='hs-varid'>lvl'</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>maxLvl</span> <span class='hs-varid'>lvl'</span> <span class='hs-varid'>lvl</span>
<a name="line-107"></a> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>lvl</span>
<a name="line-108"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>lvl</span> <span class='hs-comment'>-- Ignore tyvars in *maxIdLevel*</span>
<a name="line-109"></a>
<a name="line-110"></a><a name="lookupVar"></a><span class='hs-definition'>lookupVar</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>LevelEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Id</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LevelledExpr</span>
<a name="line-111"></a><span class='hs-definition'>lookupVar</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-varid'>id_env</span><span class='hs-layout'>)</span> <span class='hs-varid'>v</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>case</span> <span class='hs-varid'>lookupVarEnv</span> <span class='hs-varid'>id_env</span> <span class='hs-varid'>v</span> <span class='hs-keyword'>of</span>
<a name="line-112"></a> <span class='hs-conid'>Just</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-varid'>expr</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>expr</span>
<a name="line-113"></a> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Var</span> <span class='hs-varid'>v</span>
<a name="line-114"></a>
<a name="line-115"></a><a name="abstractVars"></a><span class='hs-definition'>abstractVars</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Level</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LevelEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>VarSet</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Var</span><span class='hs-keyglyph'>]</span>
<a name="line-116"></a> <span class='hs-comment'>-- Find the variables in fvs, free vars of the target expresion,</span>
<a name="line-117"></a> <span class='hs-comment'>-- whose level is greater than the destination level</span>
<a name="line-118"></a> <span class='hs-comment'>-- These are the ones we are going to abstract out</span>
<a name="line-119"></a><span class='hs-definition'>abstractVars</span> <span class='hs-varid'>dest_lvl</span> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-varid'>lvl_env</span><span class='hs-layout'>,</span> <span class='hs-keyword'>_</span><span class='hs-layout'>,</span> <span class='hs-varid'>id_env</span><span class='hs-layout'>)</span> <span class='hs-varid'>fvs</span>
<a name="line-120"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>map</span> <span class='hs-varid'>zap</span> <span class='hs-varop'>$</span> <span class='hs-varid'>uniq</span> <span class='hs-varop'>$</span> <span class='hs-varid'>sortLe</span> <span class='hs-varid'>le</span>
<a name="line-121"></a> <span class='hs-keyglyph'>[</span><span class='hs-varid'>var</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>fv</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>varSetElems</span> <span class='hs-varid'>fvs</span>
<a name="line-122"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>var</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>absVarsOf</span> <span class='hs-varid'>id_env</span> <span class='hs-varid'>fv</span>
<a name="line-123"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>abstract_me</span> <span class='hs-varid'>var</span> <span class='hs-keyglyph'>]</span>
<a name="line-124"></a> <span class='hs-comment'>-- NB: it's important to call abstract_me only on the OutIds the</span>
<a name="line-125"></a> <span class='hs-comment'>-- come from absVarsOf (not on fv, which is an InId)</span>
<a name="line-126"></a> <span class='hs-keyword'>where</span>
<a name="line-127"></a> <span class='hs-comment'>-- Sort the variables so the true type variables come first;</span>
<a name="line-128"></a> <span class='hs-comment'>-- the tyvars scope over Ids and coercion vars</span>
<a name="line-129"></a> <span class='hs-varid'>v1</span> <span class='hs-varop'>`le`</span> <span class='hs-varid'>v2</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>case</span> <span class='hs-layout'>(</span><span class='hs-varid'>is_tv</span> <span class='hs-varid'>v1</span><span class='hs-layout'>,</span> <span class='hs-varid'>is_tv</span> <span class='hs-varid'>v2</span><span class='hs-layout'>)</span> <span class='hs-keyword'>of</span>
<a name="line-130"></a> <span class='hs-layout'>(</span><span class='hs-conid'>True</span><span class='hs-layout'>,</span> <span class='hs-conid'>False</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>True</span>
<a name="line-131"></a> <span class='hs-layout'>(</span><span class='hs-conid'>False</span><span class='hs-layout'>,</span> <span class='hs-conid'>True</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>False</span>
<a name="line-132"></a> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>v1</span> <span class='hs-varop'><=</span> <span class='hs-varid'>v2</span> <span class='hs-comment'>-- Same family</span>
<a name="line-133"></a>
<a name="line-134"></a> <span class='hs-varid'>is_tv</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-varop'>&&</span> <span class='hs-varid'>not</span> <span class='hs-layout'>(</span><span class='hs-varid'>isCoVar</span> <span class='hs-varid'>v</span><span class='hs-layout'>)</span>
<a name="line-135"></a>
<a name="line-136"></a> <span class='hs-varid'>uniq</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-keyglyph'>[</span><span class='hs-conid'>Var</span><span class='hs-keyglyph'>]</span>
<a name="line-137"></a> <span class='hs-comment'>-- Remove adjacent duplicates; the sort will have brought them together</span>
<a name="line-138"></a> <span class='hs-varid'>uniq</span> <span class='hs-layout'>(</span><span class='hs-varid'>v1</span><span class='hs-conop'>:</span><span class='hs-varid'>v2</span><span class='hs-conop'>:</span><span class='hs-varid'>vs</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>v1</span> <span class='hs-varop'>==</span> <span class='hs-varid'>v2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>uniq</span> <span class='hs-layout'>(</span><span class='hs-varid'>v2</span><span class='hs-conop'>:</span><span class='hs-varid'>vs</span><span class='hs-layout'>)</span>
<a name="line-139"></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-conop'>:</span> <span class='hs-varid'>uniq</span> <span class='hs-layout'>(</span><span class='hs-varid'>v2</span><span class='hs-conop'>:</span><span class='hs-varid'>vs</span><span class='hs-layout'>)</span>
<a name="line-140"></a> <span class='hs-varid'>uniq</span> <span class='hs-varid'>vs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>vs</span>
<a name="line-141"></a>
<a name="line-142"></a> <span class='hs-varid'>abstract_me</span> <span class='hs-varid'>v</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>case</span> <span class='hs-varid'>lookupVarEnv</span> <span class='hs-varid'>lvl_env</span> <span class='hs-varid'>v</span> <span class='hs-keyword'>of</span>
<a name="line-143"></a> <span class='hs-conid'>Just</span> <span class='hs-varid'>lvl</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>dest_lvl</span> <span class='hs-varop'>`ltLvl`</span> <span class='hs-varid'>lvl</span>
<a name="line-144"></a> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>False</span>
<a name="line-145"></a>
<a name="line-146"></a> <span class='hs-comment'>-- We are going to lambda-abstract, so nuke any IdInfo,</span>
<a name="line-147"></a> <span class='hs-comment'>-- and add the tyvars of the Id (if necessary)</span>
<a name="line-148"></a> <span class='hs-varid'>zap</span> <span class='hs-varid'>v</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isId</span> <span class='hs-varid'>v</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>WARN</span><span class='hs-layout'>(</span> <span class='hs-varid'>workerExists</span> <span class='hs-layout'>(</span><span class='hs-varid'>idWorkerInfo</span> <span class='hs-varid'>v</span><span class='hs-layout'>)</span> <span class='hs-varop'>||</span>
<a name="line-149"></a> <span class='hs-varid'>not</span> <span class='hs-layout'>(</span><span class='hs-varid'>isEmptySpecInfo</span> <span class='hs-layout'>(</span><span class='hs-varid'>idSpecialisation</span> <span class='hs-varid'>v</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span>
<a name="line-150"></a> <span class='hs-varid'>text</span> <span class='hs-str'>"absVarsOf: discarding info on"</span> <span class='hs-varop'><+></span> <span class='hs-varid'>ppr</span> <span class='hs-varid'>v</span> <span class='hs-layout'>)</span>
<a name="line-151"></a> <span class='hs-varid'>setIdInfo</span> <span class='hs-varid'>v</span> <span class='hs-varid'>vanillaIdInfo</span>
<a name="line-152"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>v</span>
<a name="line-153"></a>
<a name="line-154"></a><a name="absVarsOf"></a><span class='hs-definition'>absVarsOf</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>IdEnv</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-conid'>LevelledExpr</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-keyglyph'>[</span><span class='hs-conid'>Var</span><span class='hs-keyglyph'>]</span>
<a name="line-155"></a> <span class='hs-comment'>-- If f is free in the expression, and f maps to poly_f a b c in the</span>
<a name="line-156"></a> <span class='hs-comment'>-- current substitution, then we must report a b c as candidate type</span>
<a name="line-157"></a> <span class='hs-comment'>-- variables</span>
<a name="line-158"></a> <span class='hs-comment'>--</span>
<a name="line-159"></a> <span class='hs-comment'>-- Also, if x::a is an abstracted variable, then so is a; that is,</span>
<a name="line-160"></a> <span class='hs-comment'>-- we must look in x's type</span>
<a name="line-161"></a> <span class='hs-comment'>-- And similarly if x is a coercion variable.</span>
<a name="line-162"></a><span class='hs-definition'>absVarsOf</span> <span class='hs-varid'>id_env</span> <span class='hs-varid'>v</span>
<a name="line-163"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isId</span> <span class='hs-varid'>v</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>av2</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>av1</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lookup_avs</span> <span class='hs-varid'>v</span>
<a name="line-164"></a> <span class='hs-layout'>,</span> <span class='hs-varid'>av2</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>add_tyvars</span> <span class='hs-varid'>av1</span><span class='hs-keyglyph'>]</span>
<a name="line-165"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>isCoVar</span> <span class='hs-varid'>v</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>add_tyvars</span> <span class='hs-varid'>v</span>
<a name="line-166"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>v</span><span class='hs-keyglyph'>]</span>
<a name="line-167"></a>
<a name="line-168"></a> <span class='hs-keyword'>where</span>
<a name="line-169"></a> <span class='hs-varid'>lookup_avs</span> <span class='hs-varid'>v</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>case</span> <span class='hs-varid'>lookupVarEnv</span> <span class='hs-varid'>id_env</span> <span class='hs-varid'>v</span> <span class='hs-keyword'>of</span>
<a name="line-170"></a> <span class='hs-conid'>Just</span> <span class='hs-layout'>(</span><span class='hs-varid'>abs_vars</span><span class='hs-layout'>,</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>abs_vars</span>
<a name="line-171"></a> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>v</span><span class='hs-keyglyph'>]</span>
<a name="line-172"></a>
<a name="line-173"></a> <span class='hs-varid'>add_tyvars</span> <span class='hs-varid'>v</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>v</span> <span class='hs-conop'>:</span> <span class='hs-varid'>varSetElems</span> <span class='hs-layout'>(</span><span class='hs-varid'>varTypeTyVars</span> <span class='hs-varid'>v</span><span class='hs-layout'>)</span>
</pre>\end{code}
\begin{code}
<pre><a name="line-1"></a><a name="LvlM"></a><span class='hs-keyword'>type</span> <span class='hs-conid'>LvlM</span> <span class='hs-varid'>result</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>UniqSM</span> <span class='hs-varid'>result</span>
<a name="line-2"></a>
<a name="line-3"></a><a name="initLvl"></a><span class='hs-definition'>initLvl</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>UniqSupply</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>UniqSM</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>a</span>
<a name="line-4"></a><span class='hs-definition'>initLvl</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>initUs_</span>
</pre>\end{code}
\begin{code}
<pre><a name="line-1"></a><a name="newPolyBndrs"></a><span class='hs-definition'>newPolyBndrs</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Level</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LevelEnv</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-keyglyph'>[</span><span class='hs-conid'>Id</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'>LevelEnv</span><span class='hs-layout'>,</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-2"></a><span class='hs-definition'>newPolyBndrs</span> <span class='hs-varid'>dest_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>abs_vars</span> <span class='hs-varid'>bndrs</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-3"></a> <span class='hs-varid'>uniqs</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>getUniquesM</span>
<a name="line-4"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>new_bndrs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>zipWith</span> <span class='hs-varid'>mk_poly_bndr</span> <span class='hs-varid'>bndrs</span> <span class='hs-varid'>uniqs</span>
<a name="line-5"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>extendPolyLvlEnv</span> <span class='hs-varid'>dest_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>abs_vars</span> <span class='hs-layout'>(</span><span class='hs-varid'>bndrs</span> <span class='hs-varop'>`zip`</span> <span class='hs-varid'>new_bndrs</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-varid'>new_bndrs</span><span class='hs-layout'>)</span>
<a name="line-6"></a> <span class='hs-keyword'>where</span>
<a name="line-7"></a> <span class='hs-varid'>mk_poly_bndr</span> <span class='hs-varid'>bndr</span> <span class='hs-varid'>uniq</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>transferPolyIdInfo</span> <span class='hs-varid'>bndr</span> <span class='hs-varid'>abs_vars</span> <span class='hs-varop'>$</span> <span class='hs-comment'>-- Note [transferPolyIdInfo] in Id.lhs</span>
<a name="line-8"></a> <span class='hs-varid'>mkSysLocal</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkFastString</span> <span class='hs-varid'>str</span><span class='hs-layout'>)</span> <span class='hs-varid'>uniq</span> <span class='hs-varid'>poly_ty</span>
<a name="line-9"></a> <span class='hs-keyword'>where</span>
<a name="line-10"></a> <span class='hs-varid'>str</span> <span class='hs-keyglyph'>=</span> <span class='hs-str'>"poly_"</span> <span class='hs-varop'>++</span> <span class='hs-varid'>occNameString</span> <span class='hs-layout'>(</span><span class='hs-varid'>getOccName</span> <span class='hs-varid'>bndr</span><span class='hs-layout'>)</span>
<a name="line-11"></a> <span class='hs-varid'>poly_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkPiTypes</span> <span class='hs-varid'>abs_vars</span> <span class='hs-layout'>(</span><span class='hs-varid'>idType</span> <span class='hs-varid'>bndr</span><span class='hs-layout'>)</span>
<a name="line-12"></a>
<a name="line-13"></a><a name="newLvlVar"></a><span class='hs-definition'>newLvlVar</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>String</span>
<a name="line-14"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>CoreBndr</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Type</span> <span class='hs-comment'>-- Abstract wrt these bndrs</span>
<a name="line-15"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LvlM</span> <span class='hs-conid'>Id</span>
<a name="line-16"></a><span class='hs-definition'>newLvlVar</span> <span class='hs-varid'>str</span> <span class='hs-varid'>vars</span> <span class='hs-varid'>body_ty</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-17"></a> <span class='hs-varid'>uniq</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>getUniqueM</span>
<a name="line-18"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkSysLocal</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkFastString</span> <span class='hs-varid'>str</span><span class='hs-layout'>)</span> <span class='hs-varid'>uniq</span> <span class='hs-layout'>(</span><span class='hs-varid'>mkPiTypes</span> <span class='hs-varid'>vars</span> <span class='hs-varid'>body_ty</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-19"></a>
<a name="line-20"></a><span class='hs-comment'>-- The deeply tiresome thing is that we have to apply the substitution</span>
<a name="line-21"></a><span class='hs-comment'>-- to the rules inside each Id. Grr. But it matters.</span>
<a name="line-22"></a>
<a name="line-23"></a><a name="cloneVar"></a><span class='hs-definition'>cloneVar</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>TopLevelFlag</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LevelEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Id</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Level</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Level</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LvlM</span> <span class='hs-layout'>(</span><span class='hs-conid'>LevelEnv</span><span class='hs-layout'>,</span> <span class='hs-conid'>Id</span><span class='hs-layout'>)</span>
<a name="line-24"></a><span class='hs-definition'>cloneVar</span> <span class='hs-conid'>TopLevel</span> <span class='hs-varid'>env</span> <span class='hs-varid'>v</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span>
<a name="line-25"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>env</span><span class='hs-layout'>,</span> <span class='hs-varid'>v</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- Don't clone top level things</span>
<a name="line-26"></a><span class='hs-definition'>cloneVar</span> <span class='hs-conid'>NotTopLevel</span> <span class='hs-varid'>env</span><span class='hs-keyglyph'>@</span><span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-varid'>subst</span><span class='hs-layout'>,</span><span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-varid'>v</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>dest_lvl</span>
<a name="line-27"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ASSERT</span><span class='hs-layout'>(</span> <span class='hs-varid'>isId</span> <span class='hs-varid'>v</span> <span class='hs-layout'>)</span> <span class='hs-keyword'>do</span>
<a name="line-28"></a> <span class='hs-varid'>us</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>getUniqueSupplyM</span>
<a name="line-29"></a> <span class='hs-keyword'>let</span>
<a name="line-30"></a> <span class='hs-layout'>(</span><span class='hs-varid'>subst'</span><span class='hs-layout'>,</span> <span class='hs-varid'>v1</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>cloneIdBndr</span> <span class='hs-varid'>subst</span> <span class='hs-varid'>us</span> <span class='hs-varid'>v</span>
<a name="line-31"></a> <span class='hs-varid'>v2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>zap_demand</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>dest_lvl</span> <span class='hs-varid'>v1</span>
<a name="line-32"></a> <span class='hs-varid'>env'</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendCloneLvlEnv</span> <span class='hs-varid'>dest_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>subst'</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>v</span><span class='hs-layout'>,</span><span class='hs-varid'>v2</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-33"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>env'</span><span class='hs-layout'>,</span> <span class='hs-varid'>v2</span><span class='hs-layout'>)</span>
<a name="line-34"></a>
<a name="line-35"></a><a name="cloneRecVars"></a><span class='hs-definition'>cloneRecVars</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>TopLevelFlag</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LevelEnv</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Level</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Level</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LvlM</span> <span class='hs-layout'>(</span><span class='hs-conid'>LevelEnv</span><span class='hs-layout'>,</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Id</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>
<a name="line-36"></a><span class='hs-definition'>cloneRecVars</span> <span class='hs-conid'>TopLevel</span> <span class='hs-varid'>env</span> <span class='hs-varid'>vs</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span>
<a name="line-37"></a> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>env</span><span class='hs-layout'>,</span> <span class='hs-varid'>vs</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- Don't clone top level things</span>
<a name="line-38"></a><span class='hs-definition'>cloneRecVars</span> <span class='hs-conid'>NotTopLevel</span> <span class='hs-varid'>env</span><span class='hs-keyglyph'>@</span><span class='hs-layout'>(</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-varid'>subst</span><span class='hs-layout'>,</span><span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-varid'>vs</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>dest_lvl</span>
<a name="line-39"></a> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ASSERT</span><span class='hs-layout'>(</span> <span class='hs-varid'>all</span> <span class='hs-varid'>isId</span> <span class='hs-varid'>vs</span> <span class='hs-layout'>)</span> <span class='hs-keyword'>do</span>
<a name="line-40"></a> <span class='hs-varid'>us</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>getUniqueSupplyM</span>
<a name="line-41"></a> <span class='hs-keyword'>let</span>
<a name="line-42"></a> <span class='hs-layout'>(</span><span class='hs-varid'>subst'</span><span class='hs-layout'>,</span> <span class='hs-varid'>vs1</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>cloneRecIdBndrs</span> <span class='hs-varid'>subst</span> <span class='hs-varid'>us</span> <span class='hs-varid'>vs</span>
<a name="line-43"></a> <span class='hs-varid'>vs2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>map</span> <span class='hs-layout'>(</span><span class='hs-varid'>zap_demand</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>dest_lvl</span><span class='hs-layout'>)</span> <span class='hs-varid'>vs1</span>
<a name="line-44"></a> <span class='hs-varid'>env'</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>extendCloneLvlEnv</span> <span class='hs-varid'>dest_lvl</span> <span class='hs-varid'>env</span> <span class='hs-varid'>subst'</span> <span class='hs-layout'>(</span><span class='hs-varid'>vs</span> <span class='hs-varop'>`zip`</span> <span class='hs-varid'>vs2</span><span class='hs-layout'>)</span>
<a name="line-45"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>env'</span><span class='hs-layout'>,</span> <span class='hs-varid'>vs2</span><span class='hs-layout'>)</span>
<a name="line-46"></a>
<a name="line-47"></a> <span class='hs-comment'>-- VERY IMPORTANT: we must zap the demand info </span>
<a name="line-48"></a> <span class='hs-comment'>-- if the thing is going to float out past a lambda,</span>
<a name="line-49"></a> <span class='hs-comment'>-- or if it's going to top level (where things can't be strict)</span>
<a name="line-50"></a><a name="zap_demand"></a><span class='hs-definition'>zap_demand</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Level</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Level</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Id</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Id</span>
<a name="line-51"></a><span class='hs-definition'>zap_demand</span> <span class='hs-varid'>dest_lvl</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varid'>id</span>
<a name="line-52"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>ctxt_lvl</span> <span class='hs-varop'>==</span> <span class='hs-varid'>dest_lvl</span><span class='hs-layout'>,</span>
<a name="line-53"></a> <span class='hs-varid'>not</span> <span class='hs-layout'>(</span><span class='hs-varid'>isTopLvl</span> <span class='hs-varid'>dest_lvl</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>id</span> <span class='hs-comment'>-- Stays, and not going to top level</span>
<a name="line-54"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>zapDemandIdInfo</span> <span class='hs-varid'>id</span> <span class='hs-comment'>-- Floats out</span>
</pre>\end{code}
</body>
</html>
