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"
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 )
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 ( (\\) )
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 ->
-- 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 ->
(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 ->
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
--
= 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
; 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,
[(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
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}
+
+
projects / ghc-hetmet.git / blobdiff