- = ds_lhs_binds (addSccs auto_scc exports) binds `thenDs` \ core_prs ->
- let
- add_inline (bndr,rhs) | Just prags <- lookupVarEnv inline_env bndr
- = addInlinePrags prags bndr rhs
- | otherwise = (bndr,rhs)
- inline_env = mkVarEnv [(lcl_id, prags) | (_, _, lcl_id, prags) <- exports]
-
- -- Rec because of mixed-up dictionary bindings
- core_bind = Rec (map add_inline 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.
+ = do { core_prs <- ds_lhs_binds NoSccs binds
+ ; let env = mkABEnv exports
+ do_one (lcl_id,rhs) | Just (gbl_id, prags) <- lookupVarEnv env lcl_id
+ = addInlinePrags prags 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 = 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
+
+ ; poly_tup_id <- newSysLocalDs (exprType poly_tup_expr)
+
+ ; 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 'Any'
+ do { locals' <- newSysLocalsDs (map substitute local_tys)
+ ; tup_id <- newSysLocalDs (substitute tup_ty)
+ ; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind)
+ prags
+ ; 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
+ ; returnDs ((global', rhs) : spec_binds) }
+ where
+ mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
+ | otherwise = mkArbitraryType all_tyvar
+ ty_args = map mk_ty_arg all_tyvars
+ substitute = substTyWith all_tyvars ty_args
+
+ ; export_binds_s <- mappM mk_bind (exports `zip` [0..])
+ -- don't scc (auto-)annotate the tuple itself.
+
+ ; returnDs ((poly_tup_id, poly_tup_expr) :
+ (concat export_binds_s ++ rest)) }
+
+mkABEnv :: [([TyVar], Id, Id, [Prag])] -> VarEnv (Id, [Prag])
+-- Takes the exports of a AbsBinds, and returns a mapping
+-- lcl_id -> (gbl_id, prags)
+mkABEnv exports = mkVarEnv [ (lcl_id, (gbl_id, prags))
+ | (_, gbl_id, lcl_id, prags) <- exports]