where
find [] = Nothing
find ((tpl, val) : rest)
- =
-#ifdef DEBUG
- if length tpl > length key then
- pprTrace "lookupSpecEnv" (doc <+> ppr tpl <+> ppr key) $
- Nothing
- else
-#endif
- case matchTys tpl key of
+ = case matchTys tpl key of
Nothing -> find rest
Just (subst, leftovers) -> ASSERT( null leftovers )
Just (subst, val)
specDefn (calls body_uds) (bndr,rhs) `thenSM` \ ((bndr',rhs'), spec_defns, spec_uds) ->
let
(all_uds, (dict_binds, dump_calls))
- = splitUDs [ValBinder bndr] (spec_uds `plusUDs` body_uds)
+ = splitUDs [ValBinder bndr]
+ (body_uds `plusUDs` spec_uds)
+ -- It's important that the `plusUDs` is this way round,
+ -- because body_uds may bind dictionaries that are
+ -- used in the calls passed to specDefn. So the
+ -- dictionary bindings in spec_uds may mention
+ -- dictionaries bound in body_uds.
-- If we make specialisations then we Rec the whole lot together
-- If not, leave it as a NonRec
(pairs', spec_defns_s, spec_uds_s) = unzip3 stuff
spec_defns = concat spec_defns_s
spec_uds = plusUDList spec_uds_s
+
(all_uds, (dict_binds, dump_calls))
- = splitUDs (map (ValBinder . fst) pairs) (spec_uds `plusUDs` body_uds)
+ = splitUDs (map (ValBinder . fst) pairs)
+ (body_uds `plusUDs` spec_uds)
+ -- See notes for non-rec case
+
new_bind = Rec (spec_defns ++ pairs')
in
returnSM ( new_bind : mkDictBinds dict_binds, all_uds )
tcMonoExpr expr sig_tc_ty
else -- Signature is polymorphic
- tcPolyExpr in_expr sig_tc_ty `thenTc` \ (_, _, expr, expr_ty, lie) ->
+ tcPolyExpr expr sig_tc_ty `thenTc` \ (_, _, expr, expr_ty, lie) ->
-- Now match the signature type with res_ty.
-- We must not do this earlier, because res_ty might well
-- emit an error message. This in turn means that we don't
-- mention the constructor, which doesn't exist for CCallable, CReturnable
-- Hardly beautiful, but only three extra lines.
- HsApp (TyApp (HsVar (RealId eRROR_ID)) [tcIdType this_dict_id])
- (HsLitOut (HsString msg) stringTy)
+ HsApp (TyApp (HsVar (RealId eRROR_ID)) [tcIdType this_dict_id])
+ (HsLitOut (HsString msg) stringTy)
| otherwise -- The common case
- = foldl HsApp (TyApp (HsVar (RealId dict_constr)) inst_tys')
- (map HsVar (sc_dict_ids ++ meth_ids))
+ = HsCon dict_constr inst_tys' (map HsVar (sc_dict_ids ++ meth_ids))
-- We don't produce a binding for the dict_constr; instead we
- -- rely on the simplifier to unfold this saturated application
+ -- just generate the saturated constructor directly
where
msg = _PK_ ("Compiler error: bad dictionary " ++ showSDoc (ppr clas))
-- Create any necessary record selector Ids and their bindings
-- "Necessary" includes data and newtype declarations
+ -- We don't create bindings for dictionary constructors;
+ -- they are always fully applied, and the bindings are just there
+ -- to support partial applications
let
tycons = getEnv_TyCons env
classes = getEnv_Classes env
match _ _ _ = \s -> Nothing
match_list [] tys2 k = \s -> k (s, tys2)
-match_list (ty1:tys1) [] k = panic "match_list"
+match_list (ty1:tys1) [] k = \s -> Nothing -- Not enough arg tys => failure
match_list (ty1:tys1) (ty2:tys2) k = match ty1 ty2 (match_list tys1 tys2 k)
\end{code}