- = ds_lhs_binds (addSccs auto_scc exports) binds `thenDs` \ core_prs ->
- let
- -- Rec because of mixed-up dictionary bindings
- core_bind = Rec (addLocalInlines exports core_prs)
-
- tup_expr = mkTupleExpr locals
- tup_ty = exprType tup_expr
- poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
- Let core_bind tup_expr
- locals = [local | (_, _, local, _) <- exports]
- local_tys = map idType locals
- in
- newSysLocalDs (exprType poly_tup_expr) `thenDs` \ poly_tup_id ->
- let
- dict_args = map Var dicts
-
- mk_bind ((tyvars, global, local, prags), n) -- locals !! n == local
- = -- Need to make fresh locals to bind in the selector, because
- -- some of the tyvars will be bound to voidTy
- newSysLocalsDs (map substitute local_tys) `thenDs` \ locals' ->
- newSysLocalDs (substitute tup_ty) `thenDs` \ tup_id ->
- mapM (dsSpec all_tyvars dicts tyvars global local core_bind)
- prags `thenDs` \ mb_specs ->
- let
- (spec_binds, rules) = unzip (catMaybes mb_specs)
- global' = addIdSpecialisations global rules
- rhs = mkLams tyvars $ mkLams dicts $
- mkTupleSelector locals' (locals' !! n) tup_id $
- mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args
- in
- returnDs ((global', rhs) : spec_binds)
- where
- mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
- | otherwise = voidTy
- ty_args = map mk_ty_arg all_tyvars
- substitute = substTyWith all_tyvars ty_args
- in
- mappM mk_bind (exports `zip` [0..]) `thenDs` \ export_binds_s ->
- -- don't scc (auto-)annotate the tuple itself.
-
- returnDs ((poly_tup_id, poly_tup_expr) : (concat export_binds_s ++ rest))
-
-dsSpec :: [TyVar] -> [DictId] -> [TyVar]
- -> Id -> Id -- Global, local
- -> CoreBind -> Prag
- -> DsM (Maybe ((Id,CoreExpr), -- Binding for specialised Id
- CoreRule)) -- Rule for the Global Id
+ = do { core_prs <- ds_lhs_binds NoSccs binds
+ ; let env = mkABEnv exports
+ ar_env = mkArityEnv binds
+ do_one (lcl_id,rhs) | Just (_, gbl_id, _, _prags) <- lookupVarEnv env lcl_id
+ = (lcl_id, addAutoScc auto_scc gbl_id rhs)
+ | otherwise = (lcl_id,rhs)
+
+ -- Rec because of mixed-up dictionary bindings
+ core_bind = Rec (map do_one core_prs)
+
+ tup_expr = mkBigCoreVarTup locals
+ tup_ty = exprType tup_expr
+ poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
+ Let core_bind tup_expr
+ locals = [local | (_, _, local, _) <- exports]
+ local_tys = map idType locals
+
+ ; poly_tup_id <- newSysLocalDs (exprType poly_tup_expr)
+
+ ; let mk_bind ((tyvars, global, local, spec_prags), n) -- locals!!n == local
+ = -- Need to make fresh locals to bind in the selector,
+ -- because some of the tyvars will be bound to 'Any'
+ do { let ty_args = map mk_ty_arg all_tyvars
+ substitute = substTyWith all_tyvars ty_args
+ ; locals' <- newSysLocalsDs (map substitute local_tys)
+ ; tup_id <- newSysLocalDs (substitute tup_ty)
+ ; (spec_binds, rules) <- dsSpecs all_tyvars dicts tyvars global local
+ (lookupArity ar_env local) core_bind
+ spec_prags
+ ; let global' = addIdSpecialisations global rules
+ rhs = mkLams tyvars $ mkLams dicts $
+ mkTupleSelector locals' (locals' !! n) tup_id $
+ mkVarApps (mkTyApps (Var poly_tup_id) ty_args)
+ dicts
+ ; return ((global', rhs) : spec_binds) }
+ where
+ mk_ty_arg all_tyvar
+ | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
+ | otherwise = dsMkArbitraryType all_tyvar
+
+ ; export_binds_s <- mapM mk_bind (exports `zip` [0..])
+ -- Don't scc (auto-)annotate the tuple itself.
+
+ ; return ((poly_tup_id, poly_tup_expr) :
+ (concat export_binds_s ++ rest)) }
+
+------------------------
+makeCorePair :: Id-> Arity -> CoreExpr -> (Id, CoreExpr)
+makeCorePair gbl_id arity rhs
+ | isInlinePragma (idInlinePragma gbl_id)
+ -- Add an Unfolding for an INLINE (but not for NOINLINE)
+ -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
+ = (gbl_id `setIdUnfolding` mkInlineRule needSaturated rhs arity,
+ etaExpand arity rhs)
+ | otherwise
+ = (gbl_id, rhs)
+
+------------------------
+type AbsBindEnv = VarEnv ([TyVar], Id, Id, [LSpecPrag])
+ -- Maps the "lcl_id" for an AbsBind to
+ -- its "gbl_id" and associated pragmas, if any
+
+mkABEnv :: [([TyVar], Id, Id, [LSpecPrag])] -> AbsBindEnv
+-- Takes the exports of a AbsBinds, and returns a mapping
+-- lcl_id -> (tyvars, gbl_id, lcl_id, prags)
+mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports]
+
+mkArityEnv :: LHsBinds Id -> IdEnv Arity
+ -- Maps a local to the arity of its definition
+mkArityEnv binds = foldrBag (plusVarEnv . lhsBindArity) emptyVarEnv binds
+
+lhsBindArity :: LHsBind Id -> IdEnv Arity
+lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms }))
+ = unitVarEnv (unLoc id) (matchGroupArity ms)
+lhsBindArity (L _ (AbsBinds { abs_exports = exports
+ , abs_dicts = dicts
+ , abs_binds = binds }))
+ = mkVarEnv [ (gbl, lookupArity ar_env lcl + n_val_dicts)
+ | (_, gbl, lcl, _) <- exports]
+ where -- See Note [Nested arities]
+ ar_env = mkArityEnv binds
+ n_val_dicts = dictArity dicts
+
+lhsBindArity _ = emptyVarEnv -- PatBind/VarBind
+
+dictArity :: [Var] -> Arity
+-- Don't count coercion variables in arity
+dictArity dicts = count isId dicts
+
+lookupArity :: IdEnv Arity -> Id -> Arity
+lookupArity ar_env id = lookupVarEnv ar_env id `orElse` 0
+\end{code}
+
+Note [Eta-expanding INLINE things]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ foo :: Eq a => a -> a
+ {-# INLINE foo #-}
+ foo x = ...
+
+If (foo d) ever gets floated out as a common sub-expression (which can
+happen as a result of method sharing), there's a danger that we never
+get to do the inlining, which is a Terribly Bad thing given that the
+user said "inline"!
+
+To avoid this we pre-emptively eta-expand the definition, so that foo
+has the arity with which it is declared in the source code. In this
+example it has arity 2 (one for the Eq and one for x). Doing this
+should mean that (foo d) is a PAP and we don't share it.
+
+Note [Nested arities]
+~~~~~~~~~~~~~~~~~~~~~
+For reasons that are not entirely clear, method bindings come out looking like
+this:
+
+ AbsBinds [] [] [$cfromT <= [] fromT]
+ $cfromT [InlPrag=INLINE] :: T Bool -> Bool
+ { AbsBinds [] [] [fromT <= [] fromT_1]
+ fromT :: T Bool -> Bool
+ { fromT_1 ((TBool b)) = not b } } }
+
+Note the nested AbsBind. The arity for the InlineRule on $cfromT should be
+gotten from the binding for fromT_1.
+
+It might be better to have just one level of AbsBinds, but that requires more
+thought!
+