+The main context-reduction function is @reduce@. Here's its game plan.
+
+\begin{code}
+reduceList :: (Int,[Inst]) -- Stack (for err msgs)
+ -- along with its depth
+ -> (Inst -> WhatToDo)
+ -> [Inst]
+ -> RedState
+ -> TcM RedState
+\end{code}
+
+@reduce@ is passed
+ try_me: given an inst, this function returns
+ Reduce reduce this
+ DontReduce return this in "irreds"
+ Free return this in "frees"
+
+ wanteds: The list of insts to reduce
+ state: An accumulating parameter of type RedState
+ that contains the state of the algorithm
+
+ It returns a RedState.
+
+The (n,stack) pair is just used for error reporting.
+n is always the depth of the stack.
+The stack is the stack of Insts being reduced: to produce X
+I had to produce Y, to produce Y I had to produce Z, and so on.
+
+\begin{code}
+reduceList (n,stack) try_me wanteds state
+ | n > opt_MaxContextReductionDepth
+ = failWithTc (reduceDepthErr n stack)
+
+ | otherwise
+ =
+#ifdef DEBUG
+ (if n > 8 then
+ pprTrace "Jeepers! ReduceContext:" (reduceDepthMsg n stack)
+ else (\x->x))
+#endif
+ go wanteds state
+ where
+ go [] state = returnTc state
+ go (w:ws) state = reduce (n+1, w:stack) try_me w state `thenTc` \ state' ->
+ go ws state'
+
+ -- Base case: we're done!
+reduce stack try_me wanted state
+ -- It's the same as an existing inst, or a superclass thereof
+ | isAvailable state wanted
+ = returnTc state
+
+ | otherwise
+ = case try_me wanted of {
+
+ DontReduce -> addIrred state wanted
+
+ ; DontReduceUnlessConstant -> -- It's irreducible (or at least should not be reduced)
+ -- First, see if the inst can be reduced to a constant in one step
+ try_simple addIrred
+
+ ; Free -> -- It's free so just chuck it upstairs
+ -- First, see if the inst can be reduced to a constant in one step
+ try_simple addFree
+
+ ; ReduceMe no_instance_action -> -- It should be reduced
+ lookupInst wanted `thenNF_Tc` \ lookup_result ->
+ case lookup_result of
+ GenInst wanteds' rhs -> reduceList stack try_me wanteds' state `thenTc` \ state' ->
+ addWanted state' wanted rhs wanteds'
+ SimpleInst rhs -> addWanted state wanted rhs []
+
+ NoInstance -> -- No such instance!
+ case no_instance_action of
+ Stop -> failTc
+ AddToIrreds -> addIrred state wanted
+
+ }
+ where
+ try_simple do_this_otherwise
+ = lookupInst wanted `thenNF_Tc` \ lookup_result ->
+ case lookup_result of
+ SimpleInst rhs -> addWanted state wanted rhs []
+ other -> do_this_otherwise state wanted
+\end{code}
+
+
+\begin{code}
+isAvailable :: RedState -> Inst -> Bool
+isAvailable (avails, _) wanted = wanted `elemFM` avails
+ -- NB: the Ord instance of Inst compares by the class/type info
+ -- *not* by unique. So
+ -- d1::C Int == d2::C Int
+
+-------------------------
+addFree :: RedState -> Inst -> NF_TcM RedState
+ -- When an Inst is tossed upstairs as 'free' we nevertheless add it
+ -- to avails, so that any other equal Insts will be commoned up right
+ -- here rather than also being tossed upstairs. This is really just
+ -- an optimisation, and perhaps it is more trouble that it is worth,
+ -- as the following comments show!
+ --
+ -- NB1: do *not* add superclasses. If we have
+ -- df::Floating a
+ -- dn::Num a
+ -- but a is not bound here, then we *don't* want to derive
+ -- dn from df here lest we lose sharing.
+ --
+ -- NB2: do *not* add the Inst to avails at all if it's a method.
+ -- The following situation shows why this is bad:
+ -- truncate :: forall a. RealFrac a => forall b. Integral b => a -> b
+ -- From an application (truncate f i) we get
+ -- t1 = truncate at f
+ -- t2 = t1 at i
+ -- If we have also have a second occurrence of truncate, we get
+ -- t3 = truncate at f
+ -- t4 = t3 at i
+ -- When simplifying with i,f free, we might still notice that
+ -- t1=t3; but alas, the binding for t2 (which mentions t1)
+ -- will continue to float out!
+ -- Solution: never put methods in avail till they are captured
+ -- in which case addFree isn't used
+ --
+ -- NB3: make sure that CCallable/CReturnable use NoRhs rather
+ -- than BoundTo, else we end up with bogus bindings.
+ -- c.f. instBindingRequired in addWanted
+addFree (avails, frees) free
+ | isDict free = returnNF_Tc (addToFM avails free avail, free:frees)
+ | otherwise = returnNF_Tc (avails, free:frees)
+ where
+ avail | instBindingRequired free = BoundTo (instToId free)
+ | otherwise = NoRhs
+
+addWanted :: RedState -> Inst -> TcExpr -> [Inst] -> NF_TcM RedState
+addWanted state@(avails, frees) wanted rhs_expr wanteds
+-- Do *not* add superclasses as well. Here's an example of why not
+-- class Eq a => Foo a b
+-- instance Eq a => Foo [a] a
+-- If we are reducing
+-- (Foo [t] t)
+-- we'll first deduce that it holds (via the instance decl). We
+-- must not then overwrite the Eq t constraint with a superclass selection!
+-- ToDo: this isn't entirely unsatisfactory, because
+-- we may also lose some entirely-legitimate sharing this way
+
+ = ASSERT( not (isAvailable state wanted) )
+ returnNF_Tc (addToFM avails wanted avail, frees)
+ where
+ avail | instBindingRequired wanted = Rhs rhs_expr wanteds
+ | otherwise = ASSERT( null wanteds ) NoRhs
+
+addGiven :: RedState -> Inst -> NF_TcM RedState
+addGiven state given = add_avail state given (BoundTo (instToId given))
+
+addIrred :: RedState -> Inst -> NF_TcM RedState
+addIrred state irred = add_avail state irred Irred
+
+add_avail :: RedState -> Inst -> Avail -> NF_TcM RedState
+add_avail (avails, frees) wanted avail
+ = addAvail avails wanted avail `thenNF_Tc` \ avails' ->
+ returnNF_Tc (avails', frees)
+
+---------------------
+addAvail :: Avails -> Inst -> Avail -> NF_TcM Avails
+addAvail avails wanted avail
+ = addSuperClasses (addToFM avails wanted avail) wanted
+
+addSuperClasses :: Avails -> Inst -> NF_TcM Avails
+ -- Add all the superclasses of the Inst to Avails
+ -- Invariant: the Inst is already in Avails.
+
+addSuperClasses avails dict
+ | not (isClassDict dict)
+ = returnNF_Tc avails
+
+ | otherwise -- It is a dictionary
+ = newDictsFromOld dict sc_theta' `thenNF_Tc` \ sc_dicts ->
+ foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_dicts sc_sels)
+ where
+ (clas, tys) = getDictClassTys dict
+ (tyvars, sc_theta, sc_sels, _) = classBigSig clas
+ sc_theta' = substClasses (mkTopTyVarSubst tyvars tys) sc_theta
+
+ add_sc avails (sc_dict, sc_sel) -- Add it, and its superclasses
+ = case lookupFM avails sc_dict of
+ Just (BoundTo _) -> returnNF_Tc avails -- See Note [SUPER] below
+ other -> addAvail avails sc_dict avail
+ where
+ sc_sel_rhs = DictApp (TyApp (HsVar sc_sel) tys) [instToId dict]
+ avail = Rhs sc_sel_rhs [dict]
+\end{code}
+
+Note [SUPER]. We have to be careful here. If we are *given* d1:Ord a,
+and want to deduce (d2:C [a]) where
+
+ class Ord a => C a where
+ instance Ord a => C [a] where ...
+
+Then we'll use the instance decl to deduce C [a] and then add the
+superclasses of C [a] to avails. But we must not overwrite the binding
+for d1:Ord a (which is given) with a superclass selection or we'll just
+build a loop! Hence looking for BoundTo. Crudely, BoundTo is cheaper
+than a selection.
+