+\subsection{Data types for the reduction mechanism}
+%* *
+%************************************************************************
+
+The main control over context reduction is here
+
+\begin{code}
+data WhatToDo
+ = ReduceMe -- Try to reduce this
+ -- If there's no instance, behave exactly like
+ -- DontReduce: add the inst to
+ -- the irreductible ones, but don't
+ -- produce an error message of any kind.
+ -- It might be quite legitimate such as (Eq a)!
+
+ | DontReduce WantSCs -- Return as irreducible
+
+ | DontReduceUnlessConstant -- Return as irreducible unless it can
+ -- be reduced to a constant in one step
+
+ | Free -- Return as free
+
+data WantSCs = NoSCs | AddSCs -- Tells whether we should add the superclasses
+ -- of a predicate when adding it to the avails
+\end{code}
+
+
+
+\begin{code}
+type RedState = (Avails, -- What's available
+ [Inst]) -- Insts for which try_me returned Free
+
+type Avails = FiniteMap Inst Avail
+
+data Avail
+ = Irred -- Used for irreducible dictionaries,
+ -- which are going to be lambda bound
+
+ | BoundTo TcId -- Used for dictionaries for which we have a binding
+ -- e.g. those "given" in a signature
+
+ | NoRhs -- Used for Insts like (CCallable f)
+ -- where no witness is required.
+
+ | Rhs -- Used when there is a RHS
+ TcExpr -- The RHS
+ [Inst] -- Insts free in the RHS; we need these too
+
+pprAvails avails = vcat [ppr inst <+> equals <+> pprAvail avail
+ | (inst,avail) <- fmToList avails ]
+
+instance Outputable Avail where
+ ppr = pprAvail
+
+pprAvail NoRhs = text "<no rhs>"
+pprAvail Irred = text "Irred"
+pprAvail (BoundTo x) = text "Bound to" <+> ppr x
+pprAvail (Rhs rhs bs) = ppr rhs <+> braces (ppr bs)
+\end{code}
+
+Extracting the bindings from a bunch of Avails.
+The bindings do *not* come back sorted in dependency order.
+We assume that they'll be wrapped in a big Rec, so that the
+dependency analyser can sort them out later
+
+The loop startes
+\begin{code}
+bindsAndIrreds :: Avails
+ -> [Inst] -- Wanted
+ -> (TcDictBinds, -- Bindings
+ [Inst]) -- Irreducible ones
+
+bindsAndIrreds avails wanteds
+ = go avails EmptyMonoBinds [] wanteds
+ where
+ go avails binds irreds [] = (binds, irreds)
+
+ go avails binds irreds (w:ws)
+ = case lookupFM avails w of
+ Nothing -> -- Free guys come out here
+ -- (If we didn't do addFree we could use this as the
+ -- criterion for free-ness, and pick up the free ones here too)
+ go avails binds irreds ws
+
+ Just NoRhs -> go avails binds irreds ws
+
+ Just Irred -> go (addToFM avails w (BoundTo (instToId w))) binds (w:irreds) ws
+
+ Just (BoundTo id) -> go avails new_binds irreds ws
+ where
+ -- For implicit parameters, all occurrences share the same
+ -- Id, so there is no need for synonym bindings
+ new_binds | new_id == id = binds
+ | otherwise = addBind binds new_id (HsVar id)
+ new_id = instToId w
+
+ Just (Rhs rhs ws') -> go avails' (addBind binds id rhs) irreds (ws' ++ ws)
+ where
+ id = instToId w
+ avails' = addToFM avails w (BoundTo id)
+
+addBind binds id rhs = binds `AndMonoBinds` VarMonoBind id rhs
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[reduce]{@reduce@}
+%* *
+%************************************************************************
+
+When the "what to do" predicate doesn't depend on the quantified type variables,
+matters are easier. We don't need to do any zonking, unless the improvement step
+does something, in which case we zonk before iterating.
+
+The "given" set is always empty.
+
+\begin{code}
+simpleReduceLoop :: SDoc
+ -> (Inst -> WhatToDo) -- What to do, *not* based on the quantified type variables
+ -> [Inst] -- Wanted
+ -> TcM ([Inst], -- Free
+ TcDictBinds,
+ [Inst]) -- Irreducible
+
+simpleReduceLoop doc try_me wanteds
+ = mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds' ->
+ reduceContext doc try_me [] wanteds' `thenTc` \ (no_improvement, frees, binds, irreds) ->
+ if no_improvement then
+ returnTc (frees, binds, irreds)
+ else
+ simpleReduceLoop doc try_me (irreds ++ frees) `thenTc` \ (frees1, binds1, irreds1) ->
+ returnTc (frees1, binds `AndMonoBinds` binds1, irreds1)
+\end{code}
+
+
+
+\begin{code}
+reduceContext :: SDoc
+ -> (Inst -> WhatToDo)
+ -> [Inst] -- Given
+ -> [Inst] -- Wanted
+ -> NF_TcM (Bool, -- True <=> improve step did no unification
+ [Inst], -- Free
+ TcDictBinds, -- Dictionary bindings
+ [Inst]) -- Irreducible
+
+reduceContext doc try_me givens wanteds
+ =
+ traceTc (text "reduceContext" <+> (vcat [
+ text "----------------------",
+ doc,
+ text "given" <+> ppr givens,
+ text "wanted" <+> ppr wanteds,
+ text "----------------------"
+ ])) `thenNF_Tc_`
+
+ -- Build the Avail mapping from "givens"
+ foldlNF_Tc addGiven (emptyFM, []) givens `thenNF_Tc` \ init_state ->
+
+ -- Do the real work
+ reduceList (0,[]) try_me wanteds init_state `thenNF_Tc` \ state@(avails, frees) ->
+
+ -- Do improvement, using everything in avails
+ -- In particular, avails includes all superclasses of everything
+ tcImprove avails `thenTc` \ no_improvement ->
+
+ traceTc (text "reduceContext end" <+> (vcat [
+ text "----------------------",
+ doc,
+ text "given" <+> ppr givens,
+ text "wanted" <+> ppr wanteds,
+ text "----",
+ text "avails" <+> pprAvails avails,
+ text "frees" <+> ppr frees,
+ text "no_improvement =" <+> ppr no_improvement,
+ text "----------------------"
+ ])) `thenNF_Tc_`
+ let
+ (binds, irreds) = bindsAndIrreds avails wanteds
+ in
+ returnTc (no_improvement, frees, binds, irreds)
+
+tcImprove avails
+ = tcGetInstEnv `thenTc` \ inst_env ->
+ let
+ preds = predsOfInsts (keysFM avails)
+ -- Avails has all the superclasses etc (good)
+ -- It also has all the intermediates of the deduction (good)
+ -- It does not have duplicates (good)
+ -- NB that (?x::t1) and (?x::t2) will be held separately in avails
+ -- so that improve will see them separate
+ eqns = improve (classInstEnv inst_env) preds
+ in
+ if null eqns then
+ returnTc True
+ else
+ traceTc (ptext SLIT("Improve:") <+> vcat (map ppr_eqn eqns)) `thenNF_Tc_`
+ mapTc_ unify eqns `thenTc_`
+ returnTc False
+ where
+ unify (qtvs, t1, t2) = tcInstTyVars (varSetElems qtvs) `thenNF_Tc` \ (_, _, tenv) ->
+ unifyTauTy (substTy tenv t1) (substTy tenv t2)
+ ppr_eqn (qtvs, t1, t2) = ptext SLIT("forall") <+> braces (pprWithCommas ppr (varSetElems qtvs)) <+>
+ ppr t1 <+> equals <+> ppr t2
+\end{code}
+
+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 want_scs -> addIrred want_scs 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 AddSCs) -- Assume want superclasses
+
+ ; 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 -> -- 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!
+ -- Add it and its superclasses
+ addIrred AddSCs 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 = addAvailAndSCs state given (BoundTo (instToId given))
+
+addIrred :: WantSCs -> RedState -> Inst -> NF_TcM RedState
+addIrred NoSCs (avails,frees) irred = returnNF_Tc (addToFM avails irred Irred, frees)
+addIrred AddSCs state irred = addAvailAndSCs state irred Irred
+
+addAvailAndSCs :: RedState -> Inst -> Avail -> NF_TcM RedState
+addAvailAndSCs (avails, frees) wanted avail
+ = add_avail_and_scs avails wanted avail `thenNF_Tc` \ avails' ->
+ returnNF_Tc (avails', frees)
+
+---------------------
+add_avail_and_scs :: Avails -> Inst -> Avail -> NF_TcM Avails
+add_avail_and_scs avails wanted avail
+ = add_scs (addToFM avails wanted avail) wanted
+
+add_scs :: Avails -> Inst -> NF_TcM Avails
+ -- Add all the superclasses of the Inst to Avails
+ -- Invariant: the Inst is already in Avails.
+
+add_scs 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 "add_scs" sc_dicts sc_sels)
+ where
+ (clas, tys) = getDictClassTys dict
+ (tyvars, sc_theta, sc_sels, _) = classBigSig clas
+ sc_theta' = substTheta (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 -> add_avail_and_scs 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.
+
+
+%************************************************************************
+%* *
+\section{tcSimplifyTop: defaulting}
projects / ghc-hetmet.git / blobdiff