-dsSpec _ _ _ _ _ _ (L _ (InlinePrag {}))
- = return Nothing
-
-dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
- (L loc (SpecPrag spec_expr spec_ty inl))
- = putSrcSpanDs loc $
- do { let poly_name = idName poly_id
- ; spec_name <- newLocalName poly_name
- ; ds_spec_expr <- dsExpr spec_expr
- ; case (decomposeRuleLhs ds_spec_expr) of {
- Nothing -> do { warnDs decomp_msg; return Nothing } ;
-
- Just (bndrs, _fn, args) ->
-
- -- Check for dead binders: Note [Unused spec binders]
- case filter isDeadBinder bndrs of {
- bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing }
- | otherwise -> do
-
- { f_body <- fix_up (Let mono_bind (Var mono_id))
-
- ; let local_poly = setIdNotExported poly_id
- -- Very important to make the 'f' non-exported,
- -- else it won't be inlined!
- spec_id = mkLocalId spec_name spec_ty
- spec_rhs = Let (NonRec local_poly poly_f_body) ds_spec_expr
- poly_f_body = mkLams (tvs ++ dicts) f_body
-
- extra_dict_bndrs = [localiseId d -- See Note [Constant rule dicts]
- | d <- varSetElems (exprFreeVars ds_spec_expr)
- , isDictId d]
- -- Note [Const rule dicts]
-
- rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
- AlwaysActive poly_name
- (extra_dict_bndrs ++ bndrs) args
- (mkVarApps (Var spec_id) bndrs)
- ; return (Just (addInlineInfo inl spec_id spec_rhs, rule))
- } } } }
- where
+
+dsSpecs all_tvs dicts tvs poly_id mono_id inl_arity mono_bind prags
+ = do { pairs <- mapMaybeM spec_one prags
+ ; let (spec_binds_s, rules) = unzip pairs
+ ; return (concat spec_binds_s, rules) }
+ where
+ spec_one :: LSpecPrag -> DsM (Maybe ([(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 <- dsCoercion spec_co
+ ; let ds_spec_expr = wrap_fn (Var poly_id)
+ ; case decomposeRuleLhs ds_spec_expr of {
+ Nothing -> do { warnDs (decomp_msg spec_co)
+ ; return Nothing } ;
+
+ Just (bndrs, _fn, args) ->
+
+ -- Check for dead binders: Note [Unused spec binders]
+ case filter isDeadBinder bndrs of {
+ bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing }
+ | otherwise -> do
+
+ { (spec_unf, unf_pairs) <- specUnfolding wrap_fn (realIdUnfolding poly_id)
+
+ ; let f_body = fix_up (Let mono_bind (Var mono_id))
+ spec_ty = exprType ds_spec_expr
+ 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
+
+ spec_id_arity = inl_arity + count isDictId bndrs
+
+ extra_dict_bndrs = [ localiseId d -- See Note [Constant rule dicts]
+ | d <- varSetElems (exprFreeVars ds_spec_expr)
+ , isDictId d]
+ -- Note [Const rule dicts]
+
+ 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 (mkLams (tvs ++ dicts) f_body)
+ spec_pair = makeCorePair spec_id spec_id_arity spec_rhs
+
+ ; return (Just (spec_pair : unf_pairs, rule))
+ } } } }
+