+bindInstsOfLocalFuns :: [Inst] -> [TcId] -> TcM TcMonoBinds
+
+bindInstsOfLocalFuns wanteds local_ids
+ | null overloaded_ids
+ -- Common case
+ = extendLIEs wanteds `thenM_`
+ returnM EmptyMonoBinds
+
+ | otherwise
+ = simpleReduceLoop doc try_me wanteds `thenM` \ (frees, binds, irreds) ->
+ ASSERT( null irreds )
+ extendLIEs frees `thenM_`
+ returnM binds
+ where
+ doc = text "bindInsts" <+> ppr local_ids
+ overloaded_ids = filter is_overloaded local_ids
+ is_overloaded id = isOverloadedTy (idType id)
+
+ overloaded_set = mkVarSet overloaded_ids -- There can occasionally be a lot of them
+ -- so it's worth building a set, so that
+ -- lookup (in isMethodFor) is faster
+
+ try_me inst | isMethodFor overloaded_set inst = ReduceMe
+ | otherwise = Free
+\end{code}
+
+
+%************************************************************************
+%* *
+\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
+
+reduceMe :: Inst -> WhatToDo
+reduceMe inst = ReduceMe
+
+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 Avails = FiniteMap Inst Avail
+
+data Avail
+ = IsFree -- Used for free Insts
+ | Irred -- Used for irreducible dictionaries,
+ -- which are going to be lambda bound
+
+ | Given TcId -- Used for dictionaries for which we have a binding
+ -- e.g. those "given" in a signature
+ Bool -- True <=> actually consumed (splittable IPs only)
+
+ | 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
+
+ | Linear -- Splittable Insts only.
+ Int -- The Int is always 2 or more; indicates how
+ -- many copies are required
+ Inst -- The splitter
+ Avail -- Where the "master copy" is
+
+ | LinRhss -- Splittable Insts only; this is used only internally
+ -- by extractResults, where a Linear
+ -- is turned into an LinRhss
+ [TcExpr] -- A supply of suitable RHSs
+
+pprAvails avails = vcat [sep [ppr inst, nest 2 (equals <+> pprAvail avail)]
+ | (inst,avail) <- fmToList avails ]
+
+instance Outputable Avail where
+ ppr = pprAvail
+
+pprAvail NoRhs = text "<no rhs>"
+pprAvail IsFree = text "Free"
+pprAvail Irred = text "Irred"
+pprAvail (Given x b) = text "Given" <+> ppr x <+>
+ if b then text "(used)" else empty
+pprAvail (Rhs rhs bs) = text "Rhs" <+> ppr rhs <+> braces (ppr bs)
+pprAvail (Linear n i a) = text "Linear" <+> ppr n <+> braces (ppr i) <+> ppr a
+pprAvail (LinRhss rhss) = text "LinRhss" <+> ppr rhss
+\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}
+extractResults :: Avails
+ -> [Inst] -- Wanted
+ -> TcM (TcDictBinds, -- Bindings
+ [Inst], -- Irreducible ones
+ [Inst]) -- Free ones
+
+extractResults avails wanteds
+ = go avails EmptyMonoBinds [] [] wanteds
+ where
+ go avails binds irreds frees []
+ = returnM (binds, irreds, frees)
+
+ go avails binds irreds frees (w:ws)
+ = case lookupFM avails w of
+ Nothing -> pprTrace "Urk: extractResults" (ppr w) $
+ go avails binds irreds frees ws
+
+ Just NoRhs -> go avails binds irreds frees ws
+ Just IsFree -> go (add_free avails w) binds irreds (w:frees) ws
+ Just Irred -> go (add_given avails w) binds (w:irreds) frees ws
+
+ Just (Given id _) -> go avails new_binds irreds frees ws
+ where
+ new_binds | id == instToId w = binds
+ | otherwise = addBind binds w (HsVar id)
+ -- The sought Id can be one of the givens, via a superclass chain
+ -- and then we definitely don't want to generate an x=x binding!
+
+ Just (Rhs rhs ws') -> go (add_given avails w) new_binds irreds frees (ws' ++ ws)
+ where
+ new_binds = addBind binds w rhs
+
+ Just (Linear n split_inst avail) -- Transform Linear --> LinRhss
+ -> get_root irreds frees avail w `thenM` \ (irreds', frees', root_id) ->
+ split n (instToId split_inst) root_id w `thenM` \ (binds', rhss) ->
+ go (addToFM avails w (LinRhss rhss))
+ (binds `AndMonoBinds` binds')
+ irreds' frees' (split_inst : w : ws)
+
+ Just (LinRhss (rhs:rhss)) -- Consume one of the Rhss
+ -> go new_avails new_binds irreds frees ws
+ where
+ new_binds = addBind binds w rhs
+ new_avails = addToFM avails w (LinRhss rhss)
+
+ get_root irreds frees (Given id _) w = returnM (irreds, frees, id)
+ get_root irreds frees Irred w = cloneDict w `thenM` \ w' ->
+ returnM (w':irreds, frees, instToId w')
+ get_root irreds frees IsFree w = cloneDict w `thenM` \ w' ->
+ returnM (irreds, w':frees, instToId w')
+
+ add_given avails w
+ | instBindingRequired w = addToFM avails w (Given (instToId w) True)
+ | otherwise = addToFM avails w NoRhs
+ -- NB: make sure that CCallable/CReturnable use NoRhs rather
+ -- than Given, else we end up with bogus bindings.
+
+ add_free avails w | isMethod w = avails
+ | otherwise = add_given avails w
+ -- NB: Hack alert!
+ -- Do *not* replace Free by Given 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!
+ -- (split n i a) returns: n rhss
+ -- auxiliary bindings
+ -- 1 or 0 insts to add to irreds
+
+
+split :: Int -> TcId -> TcId -> Inst
+ -> TcM (TcDictBinds, [TcExpr])
+-- (split n split_id root_id wanted) returns
+-- * a list of 'n' expressions, all of which witness 'avail'
+-- * a bunch of auxiliary bindings to support these expressions
+-- * one or zero insts needed to witness the whole lot
+-- (maybe be zero if the initial Inst is a Given)
+--
+-- NB: 'wanted' is just a template
+
+split n split_id root_id wanted
+ = go n
+ where
+ ty = linearInstType wanted
+ pair_ty = mkTyConApp pairTyCon [ty,ty]
+ id = instToId wanted
+ occ = getOccName id
+ loc = getSrcLoc id
+
+ go 1 = returnM (EmptyMonoBinds, [HsVar root_id])
+
+ go n = go ((n+1) `div` 2) `thenM` \ (binds1, rhss) ->
+ expand n rhss `thenM` \ (binds2, rhss') ->
+ returnM (binds1 `AndMonoBinds` binds2, rhss')
+
+ -- (expand n rhss)
+ -- Given ((n+1)/2) rhss, make n rhss, using auxiliary bindings
+ -- e.g. expand 3 [rhs1, rhs2]
+ -- = ( { x = split rhs1 },
+ -- [fst x, snd x, rhs2] )
+ expand n rhss
+ | n `rem` 2 == 0 = go rhss -- n is even
+ | otherwise = go (tail rhss) `thenM` \ (binds', rhss') ->
+ returnM (binds', head rhss : rhss')
+ where
+ go rhss = mapAndUnzipM do_one rhss `thenM` \ (binds', rhss') ->
+ returnM (andMonoBindList binds', concat rhss')
+
+ do_one rhs = newUnique `thenM` \ uniq ->
+ tcLookupId fstName `thenM` \ fst_id ->
+ tcLookupId sndName `thenM` \ snd_id ->
+ let
+ x = mkUserLocal occ uniq pair_ty loc
+ in
+ returnM (VarMonoBind x (mk_app split_id rhs),
+ [mk_fs_app fst_id ty x, mk_fs_app snd_id ty x])
+
+mk_fs_app id ty var = HsVar id `TyApp` [ty,ty] `HsApp` HsVar var
+
+mk_app id rhs = HsApp (HsVar id) rhs
+
+addBind binds inst rhs = binds `AndMonoBinds` VarMonoBind (instToId inst) 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
+ = mappM zonkInst wanteds `thenM` \ wanteds' ->
+ reduceContext doc try_me [] wanteds' `thenM` \ (no_improvement, frees, binds, irreds) ->
+ if no_improvement then
+ returnM (frees, binds, irreds)
+ else
+ simpleReduceLoop doc try_me (irreds ++ frees) `thenM` \ (frees1, binds1, irreds1) ->
+ returnM (frees1, binds `AndMonoBinds` binds1, irreds1)
+\end{code}
+
+
+
+\begin{code}
+reduceContext :: SDoc
+ -> (Inst -> WhatToDo)
+ -> [Inst] -- Given
+ -> [Inst] -- Wanted
+ -> 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 "----------------------"
+ ])) `thenM_`
+
+ -- Build the Avail mapping from "givens"
+ foldlM addGiven emptyFM givens `thenM` \ init_state ->
+
+ -- Do the real work
+ reduceList (0,[]) try_me wanteds init_state `thenM` \ avails ->
+
+ -- Do improvement, using everything in avails
+ -- In particular, avails includes all superclasses of everything
+ tcImprove avails `thenM` \ no_improvement ->
+
+ extractResults avails wanteds `thenM` \ (binds, irreds, frees) ->
+
+ 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 "----------------------"
+ ])) `thenM_`
+
+ returnM (no_improvement, frees, binds, irreds)
+
+tcImprove avails
+ = tcGetInstEnv `thenM` \ inst_env ->
+ let
+ preds = [ (pred, pp_loc)
+ | inst <- keysFM avails,
+ let pp_loc = pprInstLoc (instLoc inst),
+ pred <- fdPredsOfInst inst
+ ]
+ -- 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
+ returnM True
+ else
+ traceTc (ptext SLIT("Improve:") <+> vcat (map pprEquationDoc eqns)) `thenM_`
+ mappM_ unify eqns `thenM_`
+ returnM False
+ where
+ unify ((qtvs, t1, t2), doc)
+ = addErrCtxt doc $
+ tcInstTyVars VanillaTv (varSetElems qtvs) `thenM` \ (_, _, tenv) ->
+ unifyTauTy (substTy tenv t1) (substTy tenv 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]
+ -> Avails
+ -> TcM Avails
+\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 Avails
+ that contains the state of the algorithm
+
+ It returns a Avails.
+
+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 = returnM state
+ go (w:ws) state = reduce (n+1, w:stack) try_me w state `thenM` \ 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
+ | Just avail <- isAvailable state wanted
+ = if isLinearInst wanted then
+ addLinearAvailable state avail wanted `thenM` \ (state', wanteds') ->
+ reduceList stack try_me wanteds' state'
+ else
+ returnM state -- No op for non-linear things
+
+ | 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
projects / ghc-hetmet.git / blobdiff