X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FMkIface.lhs;h=478d7d3e0b8f6ced9feebdc30a295765ea69b34a;hb=b410846772e0ee630b82df31990bf9805b2d1849;hp=c55f54f772fd3f0aedb35507e69623f50d637c7d;hpb=d95ce839533391e7118257537044f01cbb1d6694;p=ghc-hetmet.git diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index c55f54f..478d7d3 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -631,7 +631,8 @@ freeNamesDeclABI (_mod, decl, extras) = data IfaceDeclExtras = IfaceIdExtras Fixity [IfaceRule] | IfaceDataExtras Fixity [IfaceInstABI] [(Fixity,[IfaceRule])] - | IfaceClassExtras [IfaceInstABI] [(Fixity,[IfaceRule])] + | IfaceClassExtras Fixity [IfaceInstABI] [(Fixity,[IfaceRule])] + | IfaceSynExtras Fixity | IfaceOtherDeclExtras freeNamesDeclExtras :: IfaceDeclExtras -> NameSet @@ -639,8 +640,10 @@ freeNamesDeclExtras (IfaceIdExtras _ rules) = unionManyNameSets (map freeNamesIfRule rules) freeNamesDeclExtras (IfaceDataExtras _ _insts subs) = unionManyNameSets (map freeNamesSub subs) -freeNamesDeclExtras (IfaceClassExtras _insts subs) +freeNamesDeclExtras (IfaceClassExtras _ _insts subs) = unionManyNameSets (map freeNamesSub subs) +freeNamesDeclExtras (IfaceSynExtras _) + = emptyNameSet freeNamesDeclExtras IfaceOtherDeclExtras = emptyNameSet @@ -653,10 +656,12 @@ instance Binary IfaceDeclExtras where putByte bh 1; put_ bh fix; put_ bh rules put_ bh (IfaceDataExtras fix insts cons) = do putByte bh 2; put_ bh fix; put_ bh insts; put_ bh cons - put_ bh (IfaceClassExtras insts methods) = do - putByte bh 3; put_ bh insts; put_ bh methods + put_ bh (IfaceClassExtras fix insts methods) = do + putByte bh 3; put_ bh fix; put_ bh insts; put_ bh methods + put_ bh (IfaceSynExtras fix) = do + putByte bh 4; put_ bh fix put_ bh IfaceOtherDeclExtras = do - putByte bh 4 + putByte bh 5 declExtras :: (OccName -> Fixity) -> OccEnv [IfaceRule] @@ -673,9 +678,10 @@ declExtras fix_fn rule_env inst_env decl (map IfaceInstABI $ lookupOccEnvL inst_env n) (map (id_extras . ifConOcc) (visibleIfConDecls cons)) IfaceClass{ifSigs=sigs} -> - IfaceClassExtras + IfaceClassExtras (fix_fn n) (map IfaceInstABI $ lookupOccEnvL inst_env n) [id_extras op | IfaceClassOp op _ _ <- sigs] + IfaceSyn{} -> IfaceSynExtras (fix_fn n) _other -> IfaceOtherDeclExtras where n = ifName decl @@ -1271,9 +1277,10 @@ tyThingToIfaceDecl :: TyThing -> IfaceDecl -- Reason: Iface stuff uses OccNames, and the conversion here does -- not do tidying on the way tyThingToIfaceDecl (AnId id) - = IfaceId { ifName = getOccName id, - ifType = toIfaceType (idType id), - ifIdInfo = info } + = IfaceId { ifName = getOccName id, + ifType = toIfaceType (idType id), + ifIdDetails = toIfaceIdDetails (idDetails id), + ifIdInfo = info } where info = case toIfaceIdInfo (idInfo id) of [] -> NoInfo @@ -1351,6 +1358,7 @@ tyThingToIfaceDecl (ATyCon tycon) ifaceConDecl data_con = IfCon { ifConOcc = getOccName (dataConName data_con), ifConInfix = dataConIsInfix data_con, + ifConWrapper = isJust (dataConWrapId_maybe data_con), ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con), ifConExTvs = toIfaceTvBndrs (dataConExTyVars data_con), ifConEqSpec = to_eq_spec (dataConEqSpec data_con), @@ -1397,7 +1405,7 @@ instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag, (tvs, fds) = classTvsFds cls arg_names = [filterNameSet is_local (tyClsNamesOfType ty) | ty <- tys] orph | is_local cls_name = Just (nameOccName cls_name) - | all isJust mb_ns = ASSERT( not (null mb_ns) ) head mb_ns + | all isJust mb_ns = head mb_ns | otherwise = Nothing mb_ns :: [Maybe OccName] -- One for each fundep; a locally-defined name @@ -1438,14 +1446,22 @@ toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id)) -- See Note [IdInfo on nested let-bindings] in IfaceSyn id_info = idInfo id inline_prag = inlinePragInfo id_info - prag_info | isAlwaysActive inline_prag = NoInfo - | otherwise = HasInfo [HsInline inline_prag] + prag_info | isDefaultInlinePragma inline_prag = NoInfo + | otherwise = HasInfo [HsInline inline_prag] -------------------------- +toIfaceIdDetails :: IdDetails -> IfaceIdDetails +toIfaceIdDetails VanillaId = IfVanillaId +toIfaceIdDetails DFunId = IfVanillaId +toIfaceIdDetails (RecSelId { sel_naughty = n + , sel_tycon = tc }) = IfRecSelId (toIfaceTyCon tc) n +toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other) + IfVanillaId -- Unexpected + toIfaceIdInfo :: IdInfo -> [IfaceInfoItem] toIfaceIdInfo id_info = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, - inline_hsinfo, unfold_hsinfo] + inline_hsinfo, wrkr_hsinfo, unfold_hsinfo] where ------------ Arity -------------- arity_info = arityInfo id_info @@ -1464,29 +1480,35 @@ toIfaceIdInfo id_info Just sig | not (isTopSig sig) -> Just (HsStrictness sig) _other -> Nothing + ------------ Worker -------------- + work_info = workerInfo id_info + has_worker = workerExists work_info + wrkr_hsinfo = case work_info of + HasWorker work_id wrap_arity -> + Just (HsWorker ((idName work_id)) wrap_arity) + NoWorker -> Nothing + ------------ Unfolding -------------- - unfold_hsinfo = fmap HsUnfold $ toIfUnfolding (unfoldingInfo id_info) + -- The unfolding is redundant if there is a worker + unfold_info = unfoldingInfo id_info + rhs = unfoldingTemplate unfold_info + no_unfolding = neverUnfold unfold_info + -- The CoreTidy phase retains unfolding info iff + -- we want to expose the unfolding, taking into account + -- unconditional NOINLINE, etc. See TidyPgm.addExternal + unfold_hsinfo | no_unfolding = Nothing + | has_worker = Nothing -- Unfolding is implicit + | otherwise = Just (HsUnfold (toIfaceExpr rhs)) ------------ Inline prag -------------- inline_prag = inlinePragInfo id_info - inline_hsinfo | isAlwaysActive inline_prag = Nothing - | isNothing unfold_hsinfo = Nothing + inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing + | no_unfolding && not has_worker + && isFunLike (inlinePragmaRuleMatchInfo inline_prag) + = Nothing -- If the iface file give no unfolding info, we -- don't need to say when inlining is OK! - | otherwise = Just (HsInline inline_prag) - --------------------------- -toIfUnfolding :: Unfolding -> Maybe IfaceUnfolding -toIfUnfolding (CoreUnfolding { uf_tmpl = rhs, uf_guidance = guidance }) - = case guidance of - UnfoldNever -> Nothing - _ -> Just (IfCoreUnfold (toIfaceExpr rhs)) -toIfUnfolding (InlineRule { uf_worker = Just wkr, uf_arity = arity }) - = Just (IfWrapper arity (idName wkr)) -toIfUnfolding (InlineRule { uf_worker = Nothing, uf_tmpl = rhs, uf_arity = arity }) - = Just (IfInlineRule arity (toIfaceExpr rhs)) -toIfUnfolding _ - = Nothing + | otherwise = Just (HsInline inline_prag) -------------------------- coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule @@ -1543,6 +1565,7 @@ toIfaceExpr (Note n e) = IfaceNote (toIfaceNote n) (toIfaceExpr e) --------------------- toIfaceNote :: Note -> IfaceNote toIfaceNote (SCC cc) = IfaceSCC cc +toIfaceNote InlineMe = IfaceInlineMe toIfaceNote (CoreNote s) = IfaceCoreNote s ---------------------