-dsSpecs poly_id poly_rhs prags
- = case prags of
- IsDefaultMethod -> return (nilOL, [])
- SpecPrags sps -> do { pairs <- mapMaybeM spec_one sps
- ; let (spec_binds_s, rules) = unzip pairs
- ; return (concatOL spec_binds_s, rules) }
- where
- spec_one :: Located TcSpecPrag -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
- spec_one (L loc (SpecPrag spec_co spec_inl))
- = putSrcSpanDs loc $
- do { let poly_name = idName poly_id
- ; spec_name <- newLocalName poly_name
- ; wrap_fn <- dsHsWrapper spec_co
- ; let (bndrs, ds_lhs) = collectBinders (wrap_fn (Var poly_id))
- spec_ty = mkPiTypes bndrs (exprType ds_lhs)
- ; case decomposeRuleLhs ds_lhs of {
- Nothing -> do { warnDs (decomp_msg spec_co)
- ; return Nothing } ;
-
- Just (_fn, args) ->
-
- -- Check for dead binders: Note [Unused spec binders]
- let arg_fvs = exprsFreeVars args
- bad_bndrs = filterOut (`elemVarSet` arg_fvs) bndrs
- in if not (null bad_bndrs)
- then do { warnDs (dead_msg bad_bndrs); return Nothing }
- else do
-
- { (spec_unf, unf_pairs) <- specUnfolding wrap_fn spec_ty (realIdUnfolding poly_id)
-
- ; let spec_id = mkLocalId spec_name spec_ty
- `setInlinePragma` inl_prag
- `setIdUnfolding` spec_unf
- inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id
- | otherwise = spec_inl
- -- Get the INLINE pragma from SPECIALISE declaration, or,
- -- failing that, from the original Id
-
- extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
- -- See Note [Constant rule dicts]
- | d <- varSetElems (arg_fvs `delVarSetList` bndrs)
- , isDictId d]
-
- rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
- AlwaysActive poly_name
- (extra_dict_bndrs ++ bndrs) args
- (mkVarApps (Var spec_id) bndrs)
-
- spec_rhs = wrap_fn poly_rhs
- spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
-
- ; return (Just (spec_pair `consOL` unf_pairs, rule))
- } } }
-
- dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
- <+> ptext (sLit "in specialied type:"),
- nest 2 (pprTheta (map get_pred bs))]
- , ptext (sLit "SPECIALISE pragma ignored")]
- get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b))
-
- decomp_msg spec_co
- = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
- 2 (pprHsWrapper (ppr poly_id) spec_co)
-
+dsSpecs _ IsDefaultMethod = return (nilOL, [])
+dsSpecs poly_rhs (SpecPrags sps)
+ = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps
+ ; let (spec_binds_s, rules) = unzip pairs
+ ; return (concatOL spec_binds_s, rules) }
+
+dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding
+ -- Nothing => RULE is for an imported Id
+ -- rhs is in the Id's unfolding
+ -> Located TcSpecPrag
+ -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
+dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
+ = putSrcSpanDs loc $
+ do { let poly_name = idName poly_id
+ ; spec_name <- newLocalName poly_name
+ ; wrap_fn <- dsHsWrapper spec_co
+ ; let (bndrs, ds_lhs) = collectBinders (wrap_fn (Var poly_id))
+ spec_ty = mkPiTypes bndrs (exprType ds_lhs)
+ ; case decomposeRuleLhs bndrs ds_lhs of {
+ Left msg -> do { warnDs msg; return Nothing } ;
+ Right (final_bndrs, _fn, args) -> do
+
+ { (spec_unf, unf_pairs) <- specUnfolding wrap_fn spec_ty (realIdUnfolding poly_id)
+
+ ; let spec_id = mkLocalId spec_name spec_ty
+ `setInlinePragma` inl_prag
+ `setIdUnfolding` spec_unf
+ inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id
+ | otherwise = spec_inl
+ -- Get the INLINE pragma from SPECIALISE declaration, or,
+ -- failing that, from the original Id
+
+ rule = mkRule False {- Not auto -} is_local_id
+ (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
+ AlwaysActive poly_name
+ final_bndrs args
+ (mkVarApps (Var spec_id) bndrs)
+
+ spec_rhs = wrap_fn poly_rhs
+ spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
+
+ ; return (Just (spec_pair `consOL` unf_pairs, rule))
+ } } }
+ where
+ is_local_id = isJust mb_poly_rhs
+ poly_rhs | Just rhs <- mb_poly_rhs
+ = rhs -- Local Id; this is its rhs
+ | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)
+ = unfolding -- Imported Id; this is its unfolding
+ -- Use realIdUnfolding so we get the unfolding
+ -- even when it is a loop breaker.
+ -- We want to specialise recursive functions!
+ | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
+ -- The type checker has checked that it *has* an unfolding