-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))
- } } }
-
+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 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 = mkRule False {- Not auto -} is_local_id
+ (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))
+ } } }
+ where