import HsSyn -- lots of things
import CoreSyn -- lots of things
import CoreUtils ( exprType, mkInlineMe, mkSCC )
import TcHsSyn ( TypecheckedMonoBinds )
import HsSyn -- lots of things
import CoreSyn -- lots of things
import CoreUtils ( exprType, mkInlineMe, mkSCC )
import TcHsSyn ( TypecheckedMonoBinds )
import Match ( matchWrapper )
import CmdLineOpts ( opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs )
import Match ( matchWrapper )
import CmdLineOpts ( opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs )
import Id ( idType, idName, isExportedId, isSpecPragmaId, Id )
import NameSet
import VarSet
import Id ( idType, idName, isExportedId, isSpecPragmaId, Id )
import NameSet
import VarSet
-import Type ( mkTyVarTy )
-import Subst ( mkTyVarSubst, substTy )
+import TcType ( mkTyVarTy )
+import Subst ( substTyWith )
dsMonoBinds auto_scc (AbsBinds [] [] exports inlines binds) rest
= dsMonoBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
let
dsMonoBinds auto_scc (AbsBinds [] [] exports inlines binds) rest
= dsMonoBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
let
- exports' = [(global, Var local) | (_, global, local) <- exports]
+ core_prs' = addLocalInlines exports inlines core_prs
+ exports' = [(global, Var local) | (_, global, local) <- exports]
let
-- Always treat the binds as recursive, because the typechecker
-- makes rather mixed-up dictionary bindings
let
-- Always treat the binds as recursive, because the typechecker
-- makes rather mixed-up dictionary bindings
- core_binds = [Rec core_prs]
- global' = (global, mkInline (idName global `elemNameSet` inlines) $
+ core_bind = Rec core_prs
+
+ -- The mkInline does directly what the
+ -- addLocalInlines do in the other cases
+ export' = (global, mkInline (idName global `elemNameSet` inlines) $
dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exports inlines binds) rest
= dsMonoBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
let
dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exports inlines binds) rest
= dsMonoBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
let
tup_expr = mkTupleExpr locals
tup_ty = exprType tup_expr
poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
tup_expr = mkTupleExpr locals
tup_ty = exprType tup_expr
poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
locals = [local | (_, _, local) <- exports]
local_tys = map idType locals
in
locals = [local | (_, _, local) <- exports]
local_tys = map idType locals
in
mk_bind (tyvars, global, local) n -- locals !! n == local
= -- Need to make fresh locals to bind in the selector, because
-- some of the tyvars will be bound to voidTy
mk_bind (tyvars, global, local) 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 (substTy env) local_tys) `thenDs` \ locals' ->
- newSysLocalDs (substTy env tup_ty) `thenDs` \ tup_id ->
+ newSysLocalsDs (map substitute local_tys) `thenDs` \ locals' ->
+ newSysLocalDs (substitute tup_ty) `thenDs` \ tup_id ->
returnDs (global, mkLams tyvars $ mkLams dicts $
mkTupleSelector locals' (locals' !! n) tup_id $
mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args)
where
mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
| otherwise = voidTy
returnDs (global, mkLams tyvars $ mkLams dicts $
mkTupleSelector locals' (locals' !! n) tup_id $
mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args)
where
mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
| otherwise = voidTy
in
zipWithDs mk_bind exports [0..] `thenDs` \ export_binds ->
-- don't scc (auto-)annotate the tuple itself.
in
zipWithDs mk_bind exports [0..] `thenDs` \ export_binds ->
-- don't scc (auto-)annotate the tuple itself.