X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsBinds.lhs;h=8f3006d0f338295e3057b45f0fb35c3e2802dbdd;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=5be1774c31d3d269c27a3b9582fe277536ffd4a2;hpb=03aa4b6dfb67cc20b94b5fb19c8e8c5958603ea6;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index 5be1774..8f3006d 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -8,7 +8,10 @@ in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at lower levels it is preserved with @let@/@letrec@s). \begin{code} -module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, AutoScc(..) ) where +module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, + dsCoercion, + AutoScc(..) + ) where #include "HsVersions.h" @@ -28,9 +31,9 @@ import StaticFlags ( opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs ) import OccurAnal ( occurAnalyseExpr ) import CostCentre ( mkAutoCC, IsCafCC(..) ) -import Id ( Id, idType, idName, isExportedId, mkLocalId, setInlinePragma ) +import Id ( Id, DictId, idType, idName, isExportedId, mkLocalId, setInlinePragma ) import Rules ( addIdSpecialisations, mkLocalRule ) -import Var ( Var, isGlobalId, setIdNotExported ) +import Var ( TyVar, Var, isGlobalId, setIdNotExported ) import VarEnv import Type ( mkTyVarTy, substTyWith ) import TysWiredIn ( voidTy ) @@ -38,7 +41,7 @@ import Outputable import SrcLoc ( Located(..) ) import Maybes ( isJust, catMaybes, orElse ) import Bag ( bagToList ) -import BasicTypes ( Activation(..), isAlwaysActive ) +import BasicTypes ( Activation(..), InlineSpec(..), isAlwaysActive, defaultInlineSpec ) import Monad ( foldM ) import FastString ( mkFastString ) import List ( (\\) ) @@ -84,12 +87,13 @@ dsHsBind auto_scc rest (VarBind var expr) addDictScc var core_expr `thenDs` \ core_expr' -> returnDs ((var, core_expr') : rest) -dsHsBind auto_scc rest (FunBind (L _ fun) _ matches _) +dsHsBind auto_scc rest (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn }) = matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, body) -> - addAutoScc auto_scc (fun, mkLams args body) `thenDs` \ pair -> + dsCoercion co_fn (return (mkLams args body)) `thenDs` \ rhs -> + addAutoScc auto_scc (fun, rhs) `thenDs` \ pair -> returnDs (pair : rest) -dsHsBind auto_scc rest (PatBind pat grhss ty _) +dsHsBind auto_scc rest (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) = dsGuarded grhss ty `thenDs` \ body_expr -> mkSelectorBinds pat body_expr `thenDs` \ sel_binds -> mappM (addAutoScc auto_scc) sel_binds `thenDs` \ sel_binds -> @@ -117,7 +121,6 @@ dsHsBind auto_scc rest -- Always treat the binds as recursive, because the typechecker -- makes rather mixed-up dictionary bindings core_bind = Rec core_prs - inline_env = mkVarEnv [(global, prag) | prag <- prags, isInlinePrag prag] in mappM (dsSpec all_tyvars dicts tyvars global local core_bind) prags `thenDs` \ mb_specs -> @@ -125,8 +128,11 @@ dsHsBind auto_scc rest (spec_binds, rules) = unzip (catMaybes mb_specs) global' = addIdSpecialisations global rules rhs' = mkLams tyvars $ mkLams dicts $ Let core_bind (Var local) + inl = case [inl | InlinePrag inl <- prags] of + [] -> defaultInlineSpec + (inl:_) -> inl in - returnDs (addInlineInfo inline_env (global', rhs') : spec_binds ++ rest) + returnDs (addInlineInfo inl global' rhs' : spec_binds ++ rest) dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds) = ds_lhs_binds (addSccs auto_scc exports) binds `thenDs` \ core_prs -> @@ -171,8 +177,15 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds) 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 + -- Example: -- f :: (Eq a, Ix b) => a -> b -> b +-- {-# SPECIALISE f :: Ix b => Int -> b -> b #-} -- -- AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds -- @@ -190,9 +203,9 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind (InlinePrag {}) = return Nothing dsSpec all_tvs dicts tvs poly_id mono_id mono_bind - (SpecPrag spec_expr spec_ty const_dicts) + (SpecPrag spec_expr spec_ty const_dicts inl) = do { let poly_name = idName poly_id - ; spec_name <- newLocalName (idName poly_id) + ; spec_name <- newLocalName poly_name ; ds_spec_expr <- dsExpr spec_expr ; let (bndrs, body) = collectBinders ds_spec_expr mb_lhs = decomposeRuleLhs (bndrs ++ const_dicts) body @@ -200,7 +213,7 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind ; case mb_lhs of Nothing -> do { dsWarn msg; return Nothing } - Just (bndrs', var, args) -> return (Just ((spec_id, spec_rhs), rule)) + Just (bndrs', var, args) -> return (Just (addInlineInfo inl spec_id spec_rhs, rule)) where local_poly = setIdNotExported poly_id -- Very important to make the 'f' non-exported, @@ -296,18 +309,19 @@ simpleSubst subst expr [(c,bs,go r) | (c,bs,r) <- alts] addLocalInlines exports core_prs - = map (addInlineInfo inline_env) core_prs + = map add_inline core_prs where + add_inline (bndr,rhs) | Just inl <- lookupVarEnv inline_env bndr + = addInlineInfo inl bndr rhs + | otherwise + = (bndr,rhs) inline_env = mkVarEnv [(mono_id, prag) | (_, _, mono_id, prags) <- exports, - prag <- prags, isInlinePrag prag] + InlinePrag prag <- prags] -addInlineInfo :: IdEnv Prag -> (Id,CoreExpr) -> (Id,CoreExpr) -addInlineInfo inline_env (bndr,rhs) - | Just (InlinePrag is_inline phase) <- lookupVarEnv inline_env bndr +addInlineInfo :: InlineSpec -> Id -> CoreExpr -> (Id,CoreExpr) +addInlineInfo (Inline phase is_inline) bndr rhs = (attach_phase bndr phase, wrap_inline is_inline rhs) - | otherwise - = (bndr, rhs) where attach_phase bndr phase | isAlwaysActive phase = bndr -- Default phase @@ -374,3 +388,30 @@ addDictScc var rhs = returnDs rhs returnDs (Note (SCC (mkAllDictsCC mod grp False)) rhs) -} \end{code} + + +%************************************************************************ +%* * + Desugaring coercions +%* * +%************************************************************************ + + +\begin{code} +dsCoercion :: ExprCoFn -> DsM CoreExpr -> DsM CoreExpr +dsCoercion CoHole thing_inside = thing_inside +dsCoercion (CoCompose c1 c2) thing_inside = dsCoercion c1 (dsCoercion c2 thing_inside) +dsCoercion (CoLams ids c) thing_inside = do { expr <- dsCoercion c thing_inside + ; return (mkLams ids expr) } +dsCoercion (CoTyLams tvs c) thing_inside = do { expr <- dsCoercion c thing_inside + ; return (mkLams tvs expr) } +dsCoercion (CoApps c ids) thing_inside = do { expr <- dsCoercion c thing_inside + ; return (mkVarApps expr ids) } +dsCoercion (CoTyApps c tys) thing_inside = do { expr <- dsCoercion c thing_inside + ; return (mkTyApps expr tys) } +dsCoercion (CoLet bs c) thing_inside = do { prs <- dsLHsBinds bs + ; expr <- dsCoercion c thing_inside + ; return (Let (Rec prs) expr) } +\end{code} + +