setIdStrictness,
setIdWorkerInfo,
setIdSpecialisation,
- setIdUpdateInfo,
setIdCafInfo,
setIdCprInfo,
setIdOccInfo,
idWorkerInfo,
idUnfolding,
idSpecialisation,
- idUpdateInfo,
idCafInfo,
idCprInfo,
idLBVarInfo,
`setIdStrictness`,
`setIdWorkerInfo`,
`setIdSpecialisation`,
- `setIdUpdateInfo`,
`setInlinePragma`,
`idCafInfo`,
`idCprInfo`
setIdDemandInfo id demand_info = modifyIdInfo (`setDemandInfo` demand_info) id
---------------------------------
- -- UPDATE INFO
-idUpdateInfo :: Id -> UpdateInfo
-idUpdateInfo id = updateInfo (idInfo id)
-
-setIdUpdateInfo :: Id -> UpdateInfo -> Id
-setIdUpdateInfo id upd_info = modifyIdInfo (`setUpdateInfo` upd_info) id
-
- ---------------------------------
-- SPECIALISATION
idSpecialisation :: Id -> CoreRules
idSpecialisation id = specInfo (idInfo id)
vanillaIdInfo, mkIdInfo, seqIdInfo, megaSeqIdInfo,
-- Zapping
- zapFragileInfo, zapLamInfo, zapSpecPragInfo, copyIdInfo,
+ zapFragileInfo, zapLamInfo, zapSpecPragInfo, shortableIdInfo, copyIdInfo,
-- Flavour
IdFlavour(..), flavourInfo,
-- Specialisation
specInfo, setSpecInfo,
- -- Update
- UpdateInfo, UpdateSpec,
- mkUpdateInfo, updateInfo, updateInfoMaybe, ppUpdateInfo, setUpdateInfo,
-
-- CAF info
CafInfo(..), cafInfo, setCafInfo, ppCafInfo,
import Outputable
import Maybe ( isJust )
-infixl 1 `setUpdateInfo`,
- `setDemandInfo`,
+infixl 1 `setDemandInfo`,
`setStrictnessInfo`,
`setSpecInfo`,
`setArityInfo`,
strictnessInfo :: StrictnessInfo, -- Strictness properties
workerInfo :: WorkerInfo, -- Pointer to Worker Function
unfoldingInfo :: Unfolding, -- Its unfolding
- updateInfo :: UpdateInfo, -- Which args should be updated
cafInfo :: CafInfo,
cprInfo :: CprInfo, -- Function always constructs a product result
lbvarInfo :: LBVarInfo, -- Info about a lambda-bound variable
-- actually increases residency significantly.
= info { unfoldingInfo = uf }
-setUpdateInfo info ud = info { updateInfo = ud }
setDemandInfo info dd = info { demandInfo = dd }
setArityInfo info ar = info { arityInfo = ar }
setCafInfo info cf = info { cafInfo = cf }
workerInfo = NoWorker,
strictnessInfo = NoStrictnessInfo,
unfoldingInfo = noUnfolding,
- updateInfo = NoUpdateInfo,
cafInfo = MayHaveCafRefs,
cprInfo = NoCPRInfo,
lbvarInfo = NoLBVarInfo,
%************************************************************************
%* *
-\subsection[update-IdInfo]{Update-analysis info about an @Id@}
-%* *
-%************************************************************************
-
-\begin{code}
-data UpdateInfo
- = NoUpdateInfo
- | SomeUpdateInfo UpdateSpec
- deriving (Eq, Ord)
- -- we need Eq/Ord to cross-chk update infos in interfaces
-
--- the form in which we pass update-analysis info between modules:
-type UpdateSpec = [Int]
-\end{code}
-
-\begin{code}
-mkUpdateInfo = SomeUpdateInfo
-
-updateInfoMaybe NoUpdateInfo = Nothing
-updateInfoMaybe (SomeUpdateInfo []) = Nothing
-updateInfoMaybe (SomeUpdateInfo u) = Just u
-\end{code}
-
-Text instance so that the update annotations can be read in.
-
-\begin{code}
-ppUpdateInfo NoUpdateInfo = empty
-ppUpdateInfo (SomeUpdateInfo []) = empty
-ppUpdateInfo (SomeUpdateInfo spec) = (<>) (ptext SLIT("__UA ")) (hcat (map int spec))
- -- was "__U "; changed to avoid conflict with unfoldings. KSW 1999-07.
-\end{code}
-
-%************************************************************************
-%* *
\subsection[CAF-IdInfo]{CAF-related information}
%* *
%************************************************************************
where f is exported. We are going to swizzle it around to
f = BIG
f_local = f
-but we must be careful to combine their IdInfos right.
-The fact that things can go wrong here is a bad sign, but I can't see
-how to make it 'patently right', so copyIdInfo is derived (pretty much) by trial and error
-Here 'from' is f_local, 'to' is f, and the result is attached to f
+BUT (a) we must be careful about messing up rules
+ (b) we must ensure f's IdInfo ends up right
+
+(a) Messing up the rules
+~~~~~~~~~~~~~~~~~~~~
+The example that went bad on me was this one:
+
+ iterate :: (a -> a) -> a -> [a]
+ iterate = iterateList
+
+ iterateFB c f x = x `c` iterateFB c f (f x)
+ iterateList f x = x : iterateList f (f x)
+
+ {-# RULES
+ "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
+ "iterateFB" iterateFB (:) = iterateList
+ #-}
+
+This got shorted out to:
+
+ iterateList :: (a -> a) -> a -> [a]
+ iterateList = iterate
+
+ iterateFB c f x = x `c` iterateFB c f (f x)
+ iterate f x = x : iterate f (f x)
+
+ {-# RULES
+ "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
+ "iterateFB" iterateFB (:) = iterate
+ #-}
+
+And now we get an infinite loop in the rule system
+ iterate f x -> build (\cn -> iterateFB c f x
+ -> iterateFB (:) f x
+ -> iterate f x
+
+Tiresome solution: don't do shorting out if f has rewrite rules.
+Hence shortableIdInfo.
+
+(b) Keeping the IdInfo right
+~~~~~~~~~~~~~~~~~~~~~~~~
+We want to move strictness/worker info from f_local to f, but keep the rest.
+Hence copyIdInfo.
\begin{code}
-copyIdInfo :: IdInfo -- From
- -> IdInfo -- To
- -> IdInfo -- To, updated with stuff from From; except flavour unchanged
-copyIdInfo from to = from { flavourInfo = flavourInfo to,
- specInfo = specInfo to,
- inlinePragInfo = inlinePragInfo to
+shortableIdInfo :: IdInfo -> Bool
+shortableIdInfo info = isEmptyCoreRules (specInfo info)
+
+copyIdInfo :: IdInfo -- f_local
+ -> IdInfo -- f (the exported one)
+ -> IdInfo -- New info for f
+copyIdInfo f_local f = f { strictnessInfo = strictnessInfo f_local,
+ workerInfo = workerInfo f_local,
+ cprInfo = cprInfo f_local
}
- -- It's important to preserve the inline pragma on 'f'; e.g. consider
- -- {-# NOINLINE f #-}
- -- f = local
- --
- -- similarly, transformation rules may be attached to f
- -- and we want to preserve them.
- --
- -- On the other hand, we want the strictness info from f_local.
\end{code}
mkLams tyvars $ mkLams dict_args $ Lam id_arg1 $
Note (Coerce result_ty (head orig_arg_tys)) (Var id_arg1)
-{- I nuked this because map (:) xs would create a
- new local lambda for the (:) in core-to-stg.
- There isn't a defn for the worker!
-
| null dict_args && all not_marked_strict strict_marks
= Var work_id -- The common case. Not only is this efficient,
-- but it also ensures that the wrapper is replaced
-- becomes
-- f $w: x
-- This is really important in rule matching,
- -- which is a bit sad. (We could match on the wrappers,
+ -- (We could match on the wrappers,
-- but that makes it less likely that rules will match
- -- when we bring bits of unfoldings together
--}
+ -- when we bring bits of unfoldings together.)
+ --
+ -- NB: because of this special case, (map (:) ys) turns into
+ -- (map $w: ys), and thence into (map (\x xs. $w: x xs) ys)
+ -- in core-to-stg. The top-level defn for (:) is never used.
+ -- This is somewhat of a bore, but I'm currently leaving it
+ -- as is, so that there still is a top level curried (:) for
+ -- the interpreter to call.
| otherwise
= mkLams all_tyvars $ mkLams dict_args $
| CoreUnfolding -- An unfolding with redundant cached information
CoreExpr -- Template; binder-info is correct
- Bool -- This is a top-level binding
- Bool -- exprIsCheap template (cached); it won't duplicate (much) work
- -- if you inline this in more than one place
+ Bool -- True <=> top level binding
Bool -- exprIsValue template (cached); it is ok to discard a `seq` on
-- this variable
- Bool -- exprIsBottom template (cached)
+ Bool -- True <=> doesn't waste (much) work to expand inside an inlining
+ -- Basically it's exprIsCheap
UnfoldingGuidance -- Tells about the *size* of the template.
mkOtherCon = OtherCon
seqUnfolding :: Unfolding -> ()
-seqUnfolding (CoreUnfolding e top b1 b2 b3 g)
- = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` seqGuidance g
+seqUnfolding (CoreUnfolding e top b1 b2 g)
+ = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g
seqUnfolding other = ()
seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
\begin{code}
unfoldingTemplate :: Unfolding -> CoreExpr
-unfoldingTemplate (CoreUnfolding expr _ _ _ _ _) = expr
-unfoldingTemplate (CompulsoryUnfolding expr) = expr
+unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr
+unfoldingTemplate (CompulsoryUnfolding expr) = expr
unfoldingTemplate other = panic "getUnfoldingTemplate"
maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
-maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _ _) = Just expr
-maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr
-maybeUnfoldingTemplate other = Nothing
+maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr
+maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr
+maybeUnfoldingTemplate other = Nothing
otherCons :: Unfolding -> [AltCon]
otherCons (OtherCon cons) = cons
isValueUnfolding :: Unfolding -> Bool
-- Returns False for OtherCon
-isValueUnfolding (CoreUnfolding _ _ _ is_evald _ _) = is_evald
-isValueUnfolding other = False
+isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
+isValueUnfolding other = False
isEvaldUnfolding :: Unfolding -> Bool
-- Returns True for OtherCon
-isEvaldUnfolding (OtherCon _) = True
-isEvaldUnfolding (CoreUnfolding _ _ _ is_evald _ _) = is_evald
-isEvaldUnfolding other = False
+isEvaldUnfolding (OtherCon _) = True
+isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
+isEvaldUnfolding other = False
isCheapUnfolding :: Unfolding -> Bool
-isCheapUnfolding (CoreUnfolding _ _ is_cheap _ _ _) = is_cheap
-isCheapUnfolding other = False
+isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap
+isCheapUnfolding other = False
isCompulsoryUnfolding :: Unfolding -> Bool
isCompulsoryUnfolding (CompulsoryUnfolding _) = True
isCompulsoryUnfolding other = False
hasUnfolding :: Unfolding -> Bool
-hasUnfolding (CoreUnfolding _ _ _ _ _ _) = True
-hasUnfolding (CompulsoryUnfolding _) = True
-hasUnfolding other = False
+hasUnfolding (CoreUnfolding _ _ _ _ _) = True
+hasUnfolding (CompulsoryUnfolding _) = True
+hasUnfolding other = False
hasSomeUnfolding :: Unfolding -> Bool
hasSomeUnfolding NoUnfolding = False
import CmdLineOpts ( opt_UF_CreationThreshold,
opt_UF_UseThreshold,
- opt_UF_ScrutConDiscount,
opt_UF_FunAppDiscount,
- opt_UF_PrimArgDiscount,
- opt_UF_KeenessFactor,
+ opt_UF_KeenessFactor,
opt_UF_CheapOp, opt_UF_DearOp,
opt_UnfoldCasms, opt_PprStyle_Debug,
opt_D_dump_inlinings
mkUnfolding top_lvl expr
= CoreUnfolding (occurAnalyseGlobalExpr expr)
top_lvl
- (exprIsCheap expr)
(exprIsValue expr)
- (exprIsBottom expr)
+ -- Already evaluated
+
+ (exprIsCheap expr)
+ -- OK to inline inside a lambda
+
(calcUnfoldingGuidance opt_UF_CreationThreshold expr)
-- Sometimes during simplification, there's a large let-bound thing
-- which has been substituted, and so is now dead; so 'expr' contains
certainlyWillInline v
= case idUnfolding v of
- CoreUnfolding _ _ _ is_value _ g@(UnfoldIfGoodArgs n_vals _ size _)
+ CoreUnfolding _ _ is_value _ g@(UnfoldIfGoodArgs n_vals _ size _)
-> is_value
&& size - (n_vals +1) <= opt_UF_UseThreshold
-- Constructors have compulsory unfoldings, but
-- may have rules, in which case they are
-- black listed till later
- CoreUnfolding unf_template is_top is_cheap is_value is_bot guidance ->
+ CoreUnfolding unf_template is_top is_value is_cheap guidance ->
let
result | yes_or_no = Just unf_template
n_val_args = length arg_infos
- ok_inside_lam = is_value || is_bot || (is_cheap && not is_top)
- -- I'm experimenting with is_cheap && not is_top
-
yes_or_no
| black_listed = False
| otherwise = case occ of
IAmDead -> pprTrace "callSiteInline: dead" (ppr id) False
IAmALoopBreaker -> False
- OneOcc in_lam one_br -> (not in_lam || ok_inside_lam) && consider_safe in_lam True one_br
- NoOccInfo -> ok_inside_lam && consider_safe True False False
+ OneOcc in_lam one_br -> (not in_lam || is_cheap) && consider_safe in_lam True one_br
+ NoOccInfo -> is_cheap && consider_safe True False False
consider_safe in_lam once once_in_one_branch
-- consider_safe decides whether it's a good idea to inline something,
text "interesting continuation" <+> ppr interesting_cont,
text "is value:" <+> ppr is_value,
text "is cheap:" <+> ppr is_cheap,
- text "is bottom:" <+> ppr is_bot,
- text "is top-level:" <+> ppr is_top,
text "guidance" <+> ppr guidance,
text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO",
if yes_or_no then
import Var ( isTyVar )
import IdInfo ( IdInfo, megaSeqIdInfo, occInfo,
arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo,
- demandInfo, updateInfo, ppUpdateInfo, specInfo,
+ demandInfo, specInfo,
strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo,
cprInfo, ppCprInfo, lbvarInfo,
workerInfo, ppWorkerInfo
= hsep [
ppFlavourInfo (flavourInfo info),
ppArityInfo a,
- ppUpdateInfo u,
ppWorkerInfo (workerInfo info),
ppStrictnessInfo s,
ppCafInfo c,
where
a = arityInfo info
s = strictnessInfo info
- u = updateInfo info
c = cafInfo info
m = cprInfo info
p = specInfo info
import CoreLint ( beginPass, endPass )
import CoreSyn
import CoreUtils ( exprIsValue )
-import Id ( setIdCprInfo, idCprInfo, idArity,
- isBottomingId )
+import Id ( Id, setIdCprInfo, idCprInfo, idArity,
+ isBottomingId, idDemandInfo )
import IdInfo ( CprInfo(..) )
+import Demand ( isStrict )
import VarEnv
import Util ( nTimes, mapAccumL )
import Outputable
cprAnalBind rho (NonRec b e)
= (extendVarEnv rho b absval, NonRec b' e')
where
- (e', absval) = cprAnalRhs rho e
- b' = setIdCprInfo b (absToCprInfo absval)
+ (e', absval) = cprAnalExpr rho e
+ b' = addIdCprInfo b e' absval
cprAnalBind rho (Rec prs)
= (final_rho, Rec (map do_pr prs))
where
do_pr (b,e) = (b', e')
where
- b' = setIdCprInfo b (absToCprInfo absval)
- (e', absval) = cprAnalRhs final_rho e
+ b' = addIdCprInfo b e' absval
+ (e', absval) = cprAnalExpr final_rho e
-- When analyzing mutually recursive bindings the iterations to find
-- a fixpoint is bounded by the number of bindings in the group.
init_rho = rho `extendVarEnvList` [(b,Bot) | (b,e) <- prs]
do_one_pass :: CPREnv -> CPREnv
- do_one_pass rho = foldl (\ rho (b,e) -> extendVarEnv rho b (snd (cprAnalRhs rho e)))
+ do_one_pass rho = foldl (\ rho (b,e) -> extendVarEnv rho b (snd (cprAnalExpr rho e)))
rho prs
-cprAnalRhs :: CPREnv -> CoreExpr -> (CoreExpr, AbsVal)
-cprAnalRhs rho e
- = case cprAnalExpr rho e of
- (e_pluscpr, e_absval) -> (e_pluscpr, pinCPR e e_absval)
-
cprAnalExpr :: CPREnv -> CoreExpr -> (CoreExpr, AbsVal)
-
-- If Id will always diverge when given sufficient arguments then
-- we can just set its abs val to Bot. Any other CPR info
-- from other paths will then dominate, which is what we want.
rho' = rho `extendVarEnvList` (zip binds (repeat Top))
--- take a binding pair and the abs val calculated from the rhs and
--- calculate a new absval taking into account sufficient manifest
--- lambda condition
--- Also we pin the var's CPR property to it. A var only has the CPR property if
--- it is a function
-
-pinCPR :: CoreExpr -> AbsVal -> AbsVal
-pinCPR e av = case av of
- -- is v a function with insufficent lambdas?
- Fun _ | n_fun_tys av /= length val_binders ->
- -- argtys must be greater than val_binders. So stripped_exp
- -- has a function type. The head of this expr can't be lambda
- -- a note, because we stripped them off before. It can't be a
- -- constructor because it has a function type. It can't be a Type.
- -- If its an app, let or case then there is work to get the
- -- and we can't do anything because we may lose laziness. *But*
- -- if its a var (i.e. a function name) then we are fine. Note
- -- that I don't think this case is at all interesting, but I have
- -- a test program that generates it.
-
- -- UPDATE: 20 Jul 1999
- -- I've decided not to allow this (useless) optimisation. It will make
- -- the w/w split more complex.
- -- if isVar stripped_exp then
- -- (addCpr av, av)
- -- else
- Top
-
- Tuple | exprIsValue e -> av
- | otherwise -> Top
+addIdCprInfo :: Id -> CoreExpr -> AbsVal -> Id
+addIdCprInfo bndr rhs absval
+ | useful_info && ok_to_add = setIdCprInfo bndr cpr_info
+ | otherwise = bndr
+ where
+ cpr_info = absToCprInfo absval
+ useful_info = case cpr_info of { ReturnsCPR -> True; NoCPRInfo -> False }
+
+ ok_to_add = case absval of
+ Fun _ -> idArity bndr >= n_fun_tys absval
+ -- Enough visible lambdas
+
+ Tuple -> exprIsValue rhs || isStrict (idDemandInfo bndr)
-- If the rhs is a value, and returns a constructed product,
-- it will be inlined at usage sites, so we give it a Tuple absval
-- If it isn't a value, we won't inline it (code/work dup worries), so
-- we discard its absval.
+ --
+ -- Also, if the strictness analyser has figured out that it's strict,
+ -- the let-to-case transformation will happen, so again it's good.
+ -- (CPR analysis runs before the simplifier has had a chance to do
+ -- the let-to-case transform.)
+ -- This made a big difference to PrelBase.modInt, which had something like
+ -- modInt = \ x -> let r = ... -> I# v in
+ -- ...body strict in r...
+ -- r's RHS isn't a value yet; but modInt returns r in various branches, so
+ -- if r doesn't have the CPR property then neither does modInt
- _ -> av
- where
- n_fun_tys :: AbsVal -> Int
- n_fun_tys (Fun av) = 1 + n_fun_tys av
- n_fun_tys other = 0
+ _ -> False
+
+ n_fun_tys :: AbsVal -> Int
+ n_fun_tys (Fun av) = 1 + n_fun_tys av
+ n_fun_tys other = 0
- -- val_binders are the explicit lambdas at the head of the expression
- -- Don't get confused by inline pragamas
- val_binders = filter isId (fst (collectBindersIgnoringNotes e))
absToCprInfo :: AbsVal -> CprInfo
absToCprInfo Tuple = ReturnsCPR
absToCprInfo (Fun r) = absToCprInfo r
absToCprInfo _ = NoCPRInfo
+
-- Cpr Info doesn't store the number of arguments a function has, so the caller
-- must take care to add the appropriate number of Funs.
getCprAbsVal v = case idCprInfo v of
dsProgram mod_name all_binds rules fo_decls
= dsMonoBinds auto_scc all_binds [] `thenDs` \ core_prs ->
- dsForeigns mod_name fo_decls `thenDs` \ (fi_binds, fe_binds, h_code, c_code) ->
+ dsForeigns mod_name fo_decls `thenDs` \ (fe_binders, foreign_binds, h_code, c_code) ->
let
- ds_binds = fi_binds ++ [Rec core_prs] ++ fe_binds
- fe_binders = bindersOfBinds fe_binds
+ ds_binds = [Rec (foreign_binds ++ core_prs)]
+ -- Notice that we put the whole lot in a big Rec, even the foreign binds
+ -- When compiling PrelFloat, which defines data Float = F# Float#
+ -- we want F# to be in scope in the foreign marshalling code!
+ -- You might think it doesn't matter, but the simplifier brings all top-level
+ -- things into the in-scope set before simplifying; so we get no unfolding for F#!
+
local_binders = mkVarSet (bindersOfBinds ds_binds)
in
mapDs (dsRule local_binders) rules `thenDs` \ rules' ->
so we reuse the desugaring code in @DsCCall@ to deal with these.
\begin{code}
+type Binding = (Id, CoreExpr) -- No rec/nonrec structure;
+ -- the occurrence analyser will sort it all out
+
dsForeigns :: Module
-> [TypecheckedForeignDecl]
- -> DsM ( [CoreBind] -- desugared foreign imports
- , [CoreBind] -- helper functions for foreign exports
+ -> DsM ( [Id] -- Foreign-exported binders;
+ -- we have to generate code to register these
+ , [Binding]
, SDoc -- Header file prototypes for
-- "foreign exported" functions.
, SDoc -- C stubs to use when calling
-- "foreign exported" functions.
)
-dsForeigns mod_name fos = foldlDs combine ([],[],empty,empty) fos
+dsForeigns mod_name fos = foldlDs combine ([], [], empty, empty) fos
where
- combine (acc_fi, acc_fe, acc_h, acc_c) fo@(ForeignDecl i imp_exp _ ext_nm cconv _)
+ combine (acc_feb, acc_f, acc_h, acc_c) fo@(ForeignDecl i imp_exp _ ext_nm cconv _)
| isForeignImport = -- foreign import (dynamic)?
dsFImport i (idType i) uns ext_nm cconv `thenDs` \ bs ->
- returnDs (bs ++ acc_fi, acc_fe, acc_h, acc_c)
+ returnDs (acc_feb, bs ++ acc_f, acc_h, acc_c)
| isForeignLabel =
dsFLabel i (idType i) ext_nm `thenDs` \ b ->
- returnDs (b:acc_fi, acc_fe, acc_h, acc_c)
+ returnDs (acc_feb, b:acc_f, acc_h, acc_c)
| isDynamicExtName ext_nm =
- dsFExportDynamic i (idType i) mod_name ext_nm cconv `thenDs` \ (fi,fe,h,c) ->
- returnDs (fi:acc_fi, fe:acc_fe, h $$ acc_h, c $$ acc_c)
+ dsFExportDynamic i (idType i) mod_name ext_nm cconv `thenDs` \ (feb,bs,h,c) ->
+ returnDs (feb:acc_feb, bs ++ acc_f, h $$ acc_h, c $$ acc_c)
| otherwise = -- foreign export
- dsFExport i (idType i) mod_name ext_nm cconv False `thenDs` \ (fe,h,c) ->
- returnDs (acc_fi, fe:acc_fe, h $$ acc_h, c $$ acc_c)
+ dsFExport i (idType i) mod_name ext_nm cconv False `thenDs` \ (feb,fe,h,c) ->
+ returnDs (feb:acc_feb, fe:acc_f, h $$ acc_h, c $$ acc_c)
where
isForeignImport =
case imp_exp of
-> Bool -- True <=> might cause Haskell GC
-> ExtName
-> CallConv
- -> DsM [CoreBind]
+ -> DsM [Binding]
dsFImport fn_id ty may_not_gc ext_name cconv
= let
(tvs, fun_ty) = splitForAllTys ty
wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
wrap_rhs = mkInlineMe (mkLams (tvs ++ args) wrapper_body)
in
- returnDs [NonRec work_id work_rhs, NonRec fn_id wrap_rhs]
+ returnDs [(work_id, work_rhs), (fn_id, wrap_rhs)]
\end{code}
Foreign labels
\begin{code}
-dsFLabel :: Id -> Type -> ExtName -> DsM CoreBind
+dsFLabel :: Id -> Type -> ExtName -> DsM Binding
dsFLabel nm ty ext_name =
ASSERT(fromJust res_ty == addrPrimTy) -- typechecker ensures this
- returnDs (NonRec nm (fo_rhs (mkLit (MachLabel enm))))
+ returnDs (nm, fo_rhs (mkLit (MachLabel enm)))
where
(res_ty, fo_rhs) = resultWrapper ty
enm = extNameStatic ext_name
-> CallConv
-> Bool -- True => invoke IO action that's hanging off
-- the first argument's stable pointer
- -> DsM ( CoreBind
+ -> DsM ( Id -- The foreign-exported Id
+ , Binding
, SDoc
, SDoc
)
c_nm f_helper_glob
wrapper_arg_tys res_ty cconv isDyn
in
- returnDs (NonRec f_helper_glob the_body, h_stub, c_stub)
+ returnDs (f_helper_glob, (f_helper_glob, the_body), h_stub, c_stub)
where
(tvs,sans_foralls) = splitForAllTys ty
-> Module
-> ExtName
-> CallConv
- -> DsM (CoreBind, CoreBind, SDoc, SDoc)
+ -> DsM (Id, [Binding], SDoc, SDoc)
dsFExportDynamic i ty mod_name ext_name cconv =
newSysLocalDs ty `thenDs` \ fe_id ->
let
fe_ext_name = ExtName (_PK_ fe_nm) Nothing
in
dsFExport i export_ty mod_name fe_ext_name cconv True
- `thenDs` \ (fe@(NonRec fe_helper fe_expr), h_code, c_code) ->
+ `thenDs` \ (feb, fe, h_code, c_code) ->
newSysLocalDs arg_ty `thenDs` \ cback ->
dsLookupGlobalValue makeStablePtrIdKey `thenDs` \ makeStablePtrId ->
let
let io_app = mkLams tvs $
mkLams [cback] $
stbl_app ccall_io_adj res_ty
+ fed = (i `setInlinePragma` neverInlinePrag, io_app)
+ -- Never inline the f.e.d. function, because the litlit
+ -- might not be in scope in other modules.
in
- -- Never inline the f.e.d. function, because the litlit might not be in scope
- -- in other modules.
- returnDs (NonRec (i `setInlinePragma` neverInlinePrag) io_app, fe, h_code, c_code)
+ returnDs (feb, [fed, fe], h_code, c_code)
where
(tvs,sans_foralls) = splitForAllTys ty
-- others:
import Id ( idArity, idType, isDataConId_maybe, isPrimOpId_maybe )
import Var ( varType, isId )
-import IdInfo ( ArityInfo, UpdateInfo, InlinePragInfo,
+import IdInfo ( ArityInfo, InlinePragInfo,
pprInlinePragInfo, ppArityInfo, ppStrictnessInfo
)
import RdrName ( RdrName )
= HsArity ArityInfo
| HsStrictness StrictnessInfo
| HsUnfold InlinePragInfo (UfExpr name)
- | HsUpdate UpdateInfo
| HsNoCafRefs
| HsCprInfo
| HsWorker name -- Worker, if any
= n1 == n2 &&
nd1 == nd2 &&
eqWithHsTyVars tvs1 tvs2 (\ env ->
- eq_hsContext env cxt1 cxt2 &&
+ eq_hsContext env cxt1 cxt2 &&
eqListBy (eq_ConDecl env) cons1 cons2
)
| RecCon -- record-style con decl
[([name], BangType name)] -- list of "fields"
- | NewCon -- newtype con decl, possibly with a labelled field.
- (HsType name)
- (Maybe name) -- Just x => labelled field 'x'
-
eq_ConDecl env (ConDecl n1 _ tvs1 cxt1 cds1 _)
(ConDecl n2 _ tvs2 cxt2 cds2 _)
= n1 == n2 &&
= eq_btype env bta1 bta2 && eq_btype env btb1 btb2
eq_ConDetails env (RecCon fs1) (RecCon fs2)
= eqListBy (eq_fld env) fs1 fs2
-eq_ConDetails env (NewCon t1 mn1) (NewCon t2 mn2)
- = eq_hsType env t1 t2 && mn1 == mn2
eq_ConDetails env _ _ = False
eq_fld env (ns1,bt1) (ns2, bt2) = ns1==ns2 && eq_btype env bt1 bt2
ppr_con_details con (VanillaCon tys)
= ppr con <+> hsep (map (ppr_bang) tys)
-ppr_con_details con (NewCon ty Nothing)
- = ppr con <+> pprParendHsType ty
-
-ppr_con_details con (NewCon ty (Just x))
- = ppr con <+> braces pp_field
- where
- pp_field = ppr x <+> dcolon <+> pprParendHsType ty
-
ppr_con_details con (RecCon fields)
= ppr con <+> braces (hsep (punctuate comma (map ppr_field fields)))
where
opt_D_dump_ds,
opt_D_dump_flatC,
opt_D_dump_foreign,
+ opt_D_dump_hi_diffs,
opt_D_dump_inlinings,
opt_D_dump_occur_anal,
opt_D_dump_parsed,
opt_UF_HiFileThreshold,
opt_UF_CreationThreshold,
opt_UF_UseThreshold,
- opt_UF_ScrutConDiscount,
opt_UF_FunAppDiscount,
- opt_UF_PrimArgDiscount,
opt_UF_KeenessFactor,
+ opt_UF_UpdateInPlace,
opt_UF_CheapOp,
opt_UF_DearOp,
opt_D_source_stats = opt_D_dump_most || lookUp SLIT("-dsource-stats")
opt_D_verbose_core2core = opt_D_dump_all || lookUp SLIT("-dverbose-simpl")
opt_D_verbose_stg2stg = opt_D_dump_all || lookUp SLIT("-dverbose-stg")
+opt_D_dump_hi_diffs = opt_D_dump_all || lookUp SLIT("-ddump-hi-diffs")
+
opt_D_dump_minimal_imports = lookUp SLIT("-ddump-minimal-imports")
opt_DoCoreLinting = lookUp SLIT("-dcore-lint")
opt_UF_HiFileThreshold = lookup_def_int "-funfolding-interface-threshold" (45::Int)
opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (45::Int)
opt_UF_UseThreshold = lookup_def_int "-funfolding-use-threshold" (8::Int) -- Discounts can be big
-opt_UF_ScrutConDiscount = lookup_def_int "-funfolding-con-discount" (2::Int)
opt_UF_FunAppDiscount = lookup_def_int "-funfolding-fun-discount" (6::Int) -- It's great to inline a fn
-opt_UF_PrimArgDiscount = lookup_def_int "-funfolding-prim-discount" (1::Int)
opt_UF_KeenessFactor = lookup_def_float "-funfolding-keeness-factor" (1.5::Float)
+opt_UF_UpdateInPlace = lookUp SLIT("-funfolding-update-in-place")
opt_UF_CheapOp = ( 1 :: Int) -- Only one instruction; and the args are charged for
opt_UF_DearOp = ( 4 :: Int)
import SrcLoc ( noSrcLoc )
import Bag
import Outputable
+import ErrUtils ( dumpIfSet )
import Maybe ( isNothing )
import List ( partition )
}}
in
- case checkIface old_iface full_new_iface of {
- Nothing -> when opt_D_dump_rn_trace $
- putStrLn "Interface file unchanged" ; -- No need to update .hi file
+ do maybe_final_iface <- checkIface old_iface full_new_iface
+ case maybe_final_iface of {
+ Nothing -> when opt_D_dump_rn_trace $
+ putStrLn "Interface file unchanged" ; -- No need to update .hi file
- Just final_iface ->
+ Just final_iface ->
- do let mod_vers_unchanged = case old_iface of
+ do let mod_vers_unchanged = case old_iface of
Just iface -> pi_vers iface == pi_vers final_iface
Nothing -> False
- when (mod_vers_unchanged && opt_D_dump_rn_trace) $
- putStrLn "Module version unchanged, but usages differ; hence need new hi file"
+ when (mod_vers_unchanged && opt_D_dump_rn_trace) $
+ putStrLn "Module version unchanged, but usages differ; hence need new hi file"
- if_hdl <- openFile filename WriteMode
- printForIface if_hdl (pprIface final_iface)
- hClose if_hdl
+ if_hdl <- openFile filename WriteMode
+ printForIface if_hdl (pprIface final_iface)
+ hClose if_hdl
}
where
full_new_iface = completeIface new_iface local_tycons local_classes
\begin{code}
checkIface :: Maybe ParsedIface -- The old interface, read from M.hi
-> ParsedIface -- The new interface; but with all version numbers = 1
- -> Maybe ParsedIface -- Nothing => no change; no need to write new Iface
+ -> IO (Maybe ParsedIface) -- Nothing => no change; no need to write new Iface
-- Just pi => Here is the new interface to write
-- with correct version numbers
+ -- The I/O part is just so it can print differences
-- NB: the fixities, declarations, rules are all assumed
-- to be sorted by increasing order of hsDeclName, so that
checkIface Nothing new_iface
-- No old interface, so definitely write a new one!
- = Just new_iface
+ = return (Just new_iface)
checkIface (Just iface) new_iface
| no_output_change && no_usage_change
- = Nothing
+ = return Nothing
| otherwise -- Add updated version numbers
- =
-{- pprTrace "checkIface" (
- vcat [ppr no_decl_changed <+> ppr no_export_change <+> ppr no_usage_change,
- text "--------",
- vcat (map ppr (pi_decls iface)),
- text "--------",
- vcat (map ppr (pi_decls new_iface))
- ]) $
--}
- Just (new_iface { pi_vers = new_mod_vers,
- pi_fixity = (new_fixity_vers, new_fixities),
- pi_rules = (new_rules_vers, new_rules),
- pi_decls = final_decls
- })
+ = do { dumpIfSet opt_D_dump_hi_diffs "Interface file changes" pp_diffs ;
+ return (Just new_iface )}
where
+ final_iface = new_iface { pi_vers = new_mod_vers,
+ pi_fixity = (new_fixity_vers, new_fixities),
+ pi_rules = (new_rules_vers, new_rules),
+ pi_decls = final_decls }
+
no_usage_change = pi_usages iface == pi_usages new_iface
no_output_change = no_decl_changed &&
new_rules_vers | rules == new_rules = rules_vers
| otherwise = bumpVersion rules_vers
- (no_decl_changed, final_decls) = merge_decls True [] (pi_decls iface) (pi_decls new_iface)
+ (no_decl_changed, pp_diffs, final_decls) = merge_decls True empty [] (pi_decls iface) (pi_decls new_iface)
-- Fill in the version number on the new declarations
-- by looking at the old declarations.
-- Set the flag if anything changes.
-- Assumes that the decls are sorted by hsDeclName
- merge_decls ok_so_far acc [] [] = (ok_so_far, reverse acc)
- merge_decls ok_so_far acc old [] = (False, reverse acc)
- merge_decls ok_so_far acc [] (nvd:nvds) = merge_decls False (nvd:acc) [] nvds
- merge_decls ok_so_far acc (vd@(v,d):vds) (nvd@(_,nd):nvds)
+ merge_decls ok_so_far pp acc [] [] = (ok_so_far, pp, reverse acc)
+ merge_decls ok_so_far pp acc old [] = (False, pp, reverse acc)
+ merge_decls ok_so_far pp acc [] (nvd:nvds) = merge_decls False (pp $$ only_new nvd) (nvd:acc) [] nvds
+ merge_decls ok_so_far pp acc (vd@(v,d):vds) (nvd@(_,nd):nvds)
= case d_name `compare` nd_name of
- LT -> merge_decls False acc vds (nvd:nvds)
- GT -> merge_decls False (nvd:acc) (vd:vds) nvds
- EQ | d == nd -> merge_decls ok_so_far (vd:acc) vds nvds
- | otherwise -> merge_decls False ((bumpVersion v, nd):acc) vds nvds
+ LT -> merge_decls False (pp $$ only_old vd) acc vds (nvd:nvds)
+ GT -> merge_decls False (pp $$ only_new nvd) (nvd:acc) (vd:vds) nvds
+ EQ | d == nd -> merge_decls ok_so_far pp (vd:acc) vds nvds
+ | otherwise -> merge_decls False (pp $$ changed d nd) ((bumpVersion v, nd):acc) vds nvds
where
d_name = hsDeclName d
nd_name = hsDeclName nd
+
+ only_old (_,d) = ptext SLIT("Only in old iface:") <+> ppr d
+ only_new (_,d) = ptext SLIT("Only in new iface:") <+> ppr d
+ changed d nd = ptext SLIT("Changed in iface: ") <+> ((ptext SLIT("Old:") <+> ppr d) $$
+ (ptext SLIT("New:") <+> ppr nd))
\end{code}
{-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.34 2000/08/01 09:08:27 simonpj Exp $
+$Id: Parser.y,v 1.35 2000/09/14 13:46:40 simonpj Exp $
Haskell grammar.
| con '{' fielddecls '}' { ($1, RecCon (reverse $3)) }
newconstr :: { RdrNameConDecl }
- : srcloc conid atype { mkConDecl $2 [] [] (NewCon $3 Nothing) $1 }
+ : srcloc conid atype { mkConDecl $2 [] [] (VanillaCon [Unbanged $3]) $1 }
| srcloc conid '{' var '::' type '}'
- { mkConDecl $2 [] [] (NewCon $6 (Just $4)) $1 }
+ { mkConDecl $2 [] [] (RecCon [([$4], Unbanged $6)]) $1 }
scontype :: { (RdrName, [RdrNameBangType]) }
: btype {% splitForConApp $1 [] }
-- We use "data_fs" so as to include ()
newtype_constr :: { [RdrNameConDecl] {- Not allowed to be empty -} }
-newtype_constr : src_loc '=' ex_stuff data_name atype { [mk_con_decl $4 $3 (NewCon $5 Nothing) $1] }
+newtype_constr : src_loc '=' ex_stuff data_name atype { [mk_con_decl $4 $3 (VanillaCon [Unbanged $5]) $1] }
| src_loc '=' ex_stuff data_name '{' var_name '::' atype '}'
- { [mk_con_decl $4 $3 (NewCon $8 (Just $6)) $1] }
+ { [mk_con_decl $4 $3 (RecCon [([$6], Unbanged $8)]) $1] }
ex_stuff :: { ([HsTyVarBndr RdrName], RdrNameContext) }
ex_stuff : { ([],[]) }
get_details (VanillaCon tys) = plusFVs (map get_bang tys)
get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2
get_details (RecCon fields) = plusFVs [get_bang t | (_, t) <- fields]
- get_details (NewCon t _) = extractHsTyNames t
get_field (fs,t) | any (`elemNameSet` source_fvs) fs = get_bang t
| otherwise = emptyFVs
getConFieldNames new_name (ConDecl con _ _ _ condecl src_loc : rest)
= new_name con src_loc `thenRn` \ n ->
- (case condecl of
- NewCon _ (Just f) ->
- new_name f src_loc `thenRn` \ new_f ->
- returnRn [n,new_f]
- _ -> returnRn [n]) `thenRn` \ nn ->
getConFieldNames new_name rest `thenRn` \ ns ->
- returnRn (nn ++ ns)
+ returnRn (n : ns)
getConFieldNames new_name [] = returnRn []
rnBangTy doc ty2 `thenRn` \ (new_ty2, fvs2) ->
returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2)
-rnConDetails doc locn (NewCon ty mb_field)
- = rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
- rn_field mb_field `thenRn` \ new_mb_field ->
- returnRn (NewCon new_ty new_mb_field, fvs)
- where
- rn_field Nothing = returnRn Nothing
- rn_field (Just f) =
- lookupTopBndrRn f `thenRn` \ new_f ->
- returnRn (Just new_f)
-
rnConDetails doc locn (RecCon fields)
= checkDupOrQualNames doc field_names `thenRn_`
mapFvRn (rnField doc) fields `thenRn` \ (new_fields, fvs) ->
rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ (expr', fvs) ->
returnRn (HsUnfold inline expr', fvs)
rnIdInfo (HsArity arity) = returnRn (HsArity arity, emptyFVs)
-rnIdInfo (HsUpdate update) = returnRn (HsUpdate update, emptyFVs)
rnIdInfo HsNoCafRefs = returnRn (HsNoCafRefs, emptyFVs)
rnIdInfo HsCprInfo = returnRn (HsCprInfo, emptyFVs)
idSpecialisation,
idType, idUnique, Id
)
-import IdInfo ( OccInfo(..), insideLam, copyIdInfo )
+import IdInfo ( OccInfo(..), insideLam, shortableIdInfo, copyIdInfo )
import VarSet
import VarEnv
zapBind ind_env bind = bind
-zap ind_env pair@(bndr,rhs)
- = case lookupVarEnv ind_env bndr of
+zap ind_env pair@(local_id,rhs)
+ = case lookupVarEnv ind_env local_id of
Nothing -> [pair]
- Just exported_id -> [(bndr, Var exported_id),
- (exported_id_w_info, rhs)]
- where
- exported_id_w_info = modifyIdInfo (copyIdInfo (idInfo bndr)) exported_id
- -- See notes with copyIdInfo about propagating IdInfo from
- -- one to t'other
+ Just exported_id -> [(local_id, Var exported_id),
+ (exported_id', rhs)]
+ where
+ exported_id' = modifyIdInfo (copyIdInfo (idInfo local_id)) exported_id
shortMeOut ind_env exported_id local_id
- = isExportedId exported_id && -- Only if this is exported
-
- isLocallyDefined local_id && -- Only if this one is defined in this
- -- module, so that we *can* change its
- -- binding to be the exported thing!
-
- not (isExportedId local_id) && -- Only if this one is not itself exported,
- -- since the transformation will nuke it
-
- not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for
+-- The if-then-else stuff is just so I can get a pprTrace to see
+-- how often I don't get shorting out becuase of IdInfo stuff
+ = if isExportedId exported_id && -- Only if this is exported
+
+ isLocallyDefined local_id && -- Only if this one is defined in this
+ -- module, so that we *can* change its
+ -- binding to be the exported thing!
+
+ not (isExportedId local_id) && -- Only if this one is not itself exported,
+ -- since the transformation will nuke it
+
+ not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for
+ then
+ if shortableIdInfo (idInfo exported_id) -- Only if its IdInfo is 'shortable'
+ -- (see the defn of IdInfo.shortableIdInfo
+ then True
+ else pprTrace "shortMeOut:" (ppr exported_id) False
+ else
+ False
\end{code}
lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_))
| null abs_vars
= -- No type abstraction; clone existing binder
- lvlExpr ctxt_lvl env rhs `thenLvl` \ rhs' ->
+ lvlExpr dest_lvl env rhs `thenLvl` \ rhs' ->
cloneVar top_lvl env bndr ctxt_lvl dest_lvl `thenLvl` \ (env', bndr') ->
returnLvl (NonRec (bndr', dest_lvl) rhs', env')
#include "HsVersions.h"
import CmdLineOpts ( switchIsOn, SimplifierSwitch(..),
- opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge, opt_DictsStrict
+ opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge, opt_DictsStrict,
+ opt_UF_UpdateInPlace
)
import CoreSyn
import CoreUnfold ( isValueUnfolding )
idOccInfo, idUnfolding, idStrictness,
mkId, idInfo
)
-import IdInfo ( StrictnessInfo(..), arityLowerBound, setOccInfo, vanillaIdInfo )
+import IdInfo ( StrictnessInfo(..), ArityInfo, atLeastArity, setOccInfo, vanillaIdInfo )
import Maybes ( maybeToBool, catMaybes )
import Name ( isLocalName, setNameUnique )
import Demand ( Demand, isStrict, wwLazy, wwLazy )
-- Note the repType: we want to look through newtypes for this purpose
-canUpdateInPlace ty = case splitTyConApp_maybe (repType ty) of {
+canUpdateInPlace ty
+ | not opt_UF_UpdateInPlace = False
+ | otherwise
+ = case splitTyConApp_maybe (repType ty) of {
Nothing -> False ;
Just (tycon, _) ->
\begin{code}
transformRhs :: OutExpr
- -> (Arity -> OutExpr -> SimplM (OutStuff a))
+ -> (ArityInfo -> OutExpr -> SimplM (OutStuff a))
-> SimplM (OutStuff a)
transformRhs rhs thing_inside
\begin{code}
tryEtaExpansion :: OutExpr
- -> (Arity -> OutExpr -> SimplM (OutStuff a))
+ -> (ArityInfo -> OutExpr -> SimplM (OutStuff a))
-> SimplM (OutStuff a)
tryEtaExpansion rhs thing_inside
| not opt_SimplDoLambdaEtaExpansion
fun_arity = exprEtaExpandArity fun
- final_arity | all_trivial_args = x_arity + extra_args_wanted
- | otherwise = x_arity
+ final_arity | all_trivial_args = atLeastArity (x_arity + extra_args_wanted)
+ | otherwise = atLeastArity x_arity
-- Arity can be more than the number of lambdas
-- because of coerces. E.g. \x -> coerce t (\y -> e)
-- will have arity at least 2
zapLamIdInfo, setOneShotLambda,
)
import IdInfo ( OccInfo(..), isDeadOcc, isLoopBreaker,
- ArityInfo, setArityInfo, atLeastArity,
+ ArityInfo, setArityInfo, unknownArity,
setUnfoldingInfo,
occInfo
)
= thing_inside
| exprIsTrivial new_rhs
- = completeTrivialBinding old_bndr new_bndr
- black_listed loop_breaker new_rhs
- thing_inside
+ -- We're looking at a binding with a trivial RHS, so
+ -- perhaps we can discard it altogether!
+ --
+ -- NB: a loop breaker never has postInlineUnconditionally True
+ -- and non-loop-breakers only have *forward* references
+ -- Hence, it's safe to discard the binding
+ --
+ -- NOTE: This isn't our last opportunity to inline.
+ -- We're at the binding site right now, and
+ -- we'll get another opportunity when we get to the ocurrence(s)
+
+ -- Note that we do this unconditional inlining only for trival RHSs.
+ -- Don't inline even WHNFs inside lambdas; doing so may
+ -- simply increase allocation when the function is called
+ -- This isn't the last chance; see NOTE above.
+ --
+ -- NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here
+ -- Why? Because we don't even want to inline them into the
+ -- RHS of constructor arguments. See NOTE above
+ --
+ -- NB: Even NOINLINEis ignored here: if the rhs is trivial
+ -- it's best to inline it anyway. We often get a=E; b=a
+ -- from desugaring, with both a and b marked NOINLINE.
+ = if must_keep_binding then -- Keep the binding
+ finally_bind_it unknownArity new_rhs
+ -- Arity doesn't really matter because for a trivial RHS
+ -- we will inline like crazy at call sites
+ -- If this turns out be false, we can easily compute arity
+ else -- Drop the binding
+ extendSubst old_bndr (DoneEx new_rhs) $
+ -- Use the substitution to make quite, quite sure that the substitution
+ -- will happen, since we are going to discard the binding
+ tick (PostInlineUnconditionally old_bndr) `thenSmpl_`
+ thing_inside
| Note coercion@(Coerce _ inner_ty) inner_rhs <- new_rhs
+ -- [NB inner_rhs is guaranteed non-trivial by now]
-- x = coerce t e ==> c = e; x = inline_me (coerce t c)
-- Now x can get inlined, which moves the coercion
-- to the usage site. This is a bit like worker/wrapper stuff,
-- x = coerce T (I# 3)
-- get's w/wd to
-- c = I# 3
- -- x = coerce T $wx
+ -- x = coerce T c
-- This in turn means that
-- case (coerce Int x) of ...
-- will inline x.
-- get substituted away, but not if it's exported.)
= newId SLIT("c") inner_ty $ \ c_id ->
completeBinding c_id c_id top_lvl False inner_rhs $
- completeTrivialBinding old_bndr new_bndr black_listed loop_breaker
- (Note InlineMe (Note coercion (Var c_id))) $
+ completeBinding old_bndr new_bndr top_lvl black_listed
+ (Note InlineMe (Note coercion (Var c_id))) $
thing_inside
| otherwise
- = transformRhs new_rhs $ \ arity new_rhs' ->
- getSubst `thenSmpl` \ subst ->
- let
- -- We make new IdInfo for the new binder by starting from the old binder,
- -- doing appropriate substitutions.
- -- Then we add arity and unfolding info to get the new binder
- new_bndr_info = substIdInfo subst old_info (idInfo new_bndr)
- `setArityInfo` atLeastArity arity
-
- -- Add the unfolding *only* for non-loop-breakers
- -- Making loop breakers not have an unfolding at all
- -- means that we can avoid tests in exprIsConApp, for example.
- -- This is important: if exprIsConApp says 'yes' for a recursive
- -- thing, then we can get into an infinite loop
- info_w_unf | loop_breaker = new_bndr_info
- | otherwise = new_bndr_info `setUnfoldingInfo` mkUnfolding top_lvl new_rhs'
-
- final_id = new_bndr `setIdInfo` info_w_unf
- in
- -- These seqs forces the Id, and hence its IdInfo,
- -- and hence any inner substitutions
- final_id `seq`
- addLetBind (NonRec final_id new_rhs') $
- modifyInScope new_bndr final_id thing_inside
+ = transformRhs new_rhs finally_bind_it
where
- old_info = idInfo old_bndr
- occ_info = occInfo old_info
- loop_breaker = isLoopBreaker occ_info
+ old_info = idInfo old_bndr
+ occ_info = occInfo old_info
+ loop_breaker = isLoopBreaker occ_info
+ trivial_rhs = exprIsTrivial new_rhs
+ must_keep_binding = black_listed || loop_breaker || isExportedId old_bndr
+
+ finally_bind_it arity_info new_rhs
+ = getSubst `thenSmpl` \ subst ->
+ let
+ -- We make new IdInfo for the new binder by starting from the old binder,
+ -- doing appropriate substitutions.
+ -- Then we add arity and unfolding info to get the new binder
+ new_bndr_info = substIdInfo subst old_info (idInfo new_bndr)
+ `setArityInfo` arity_info
+
+ -- Add the unfolding *only* for non-loop-breakers
+ -- Making loop breakers not have an unfolding at all
+ -- means that we can avoid tests in exprIsConApp, for example.
+ -- This is important: if exprIsConApp says 'yes' for a recursive
+ -- thing, then we can get into an infinite loop
+ info_w_unf | loop_breaker = new_bndr_info
+ | otherwise = new_bndr_info `setUnfoldingInfo` mkUnfolding top_lvl new_rhs
+
+ final_id = new_bndr `setIdInfo` info_w_unf
+ in
+ -- These seqs forces the Id, and hence its IdInfo,
+ -- and hence any inner substitutions
+ final_id `seq`
+ addLetBind (NonRec final_id new_rhs) $
+ modifyInScope new_bndr final_id thing_inside
\end{code}
-\begin{code}
-completeTrivialBinding old_bndr new_bndr black_listed loop_breaker new_rhs thing_inside
- -- We're looking at a binding with a trivial RHS, so
- -- perhaps we can discard it altogether!
- --
- -- NB: a loop breaker never has postInlineUnconditionally True
- -- and non-loop-breakers only have *forward* references
- -- Hence, it's safe to discard the binding
- --
- -- NB: You might think that postInlineUnconditionally is an optimisation,
- -- but if we have
- -- let x = f Bool in (x, y)
- -- then because of the constructor, x will not be *inlined* in the pair,
- -- so the trivial binding will stay. But in this postInlineUnconditionally
- -- gag we use the *substitution* to substitute (f Bool) for x, and that *will*
- -- happen.
-
- -- NOTE: This isn't our last opportunity to inline.
- -- We're at the binding site right now, and
- -- we'll get another opportunity when we get to the ocurrence(s)
-
- -- Note that we do this unconditional inlining only for trival RHSs.
- -- Don't inline even WHNFs inside lambdas; doing so may
- -- simply increase allocation when the function is called
- -- This isn't the last chance; see NOTE above.
- --
- -- NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here
- -- Why? Because we don't even want to inline them into the
- -- RHS of constructor arguments. See NOTE above
- --
- -- NB: Even NOINLINEis ignored here: if the rhs is trivial
- -- it's best to inline it anyway. We often get a=E; b=a
- -- from desugaring, with both a and b marked NOINLINE.
-
- | not keep_binding -- Can discard binding, inlining everywhere
- = extendSubst old_bndr (DoneEx new_rhs) $
- tick (PostInlineUnconditionally old_bndr) `thenSmpl_`
- thing_inside
-
- | otherwise -- We must keep the binding, but we may still inline
- = getSubst `thenSmpl` \ subst ->
- let
- new_bndr_info = substIdInfo subst (idInfo old_bndr) (idInfo new_bndr)
- final_id = new_bndr `setIdInfo` new_bndr_info
- in
- addLetBind (NonRec final_id new_rhs) $
- if dont_inline then
- modifyInScope new_bndr final_id thing_inside
- else
- extendSubst old_bndr (DoneEx new_rhs) thing_inside
- where
- dont_inline = black_listed || loop_breaker
- keep_binding = dont_inline || isExportedId old_bndr
-\end{code}
-
%************************************************************************
%* *
-- See notes with WwLib.worthSplitting
= find_strictness id str_ds str_res abs_ds
-findStrictness id str_val abs_val = NoStrictnessInfo
+findStrictness id str_val abs_val
+ | isBot str_val = mkStrictnessInfo ([], True)
+ | otherwise = NoStrictnessInfo
-- The list of absence demands passed to combineDemands
-- can be shorter than the list of absence demands
import CoreSyn
import CoreUnfold ( Unfolding, certainlyWillInline )
-import CmdLineOpts ( opt_UF_CreationThreshold , opt_D_verbose_core2core,
- opt_D_dump_worker_wrapper
- )
+import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_worker_wrapper )
import CoreLint ( beginPass, endPass )
import CoreUtils ( exprType, exprEtaExpandArity )
import MkId ( mkWorkerId )
= foldlTc tcPrag vanillaIdInfo info_ins
where
tcPrag info (HsArity arity) = returnTc (info `setArityInfo` arity)
- tcPrag info (HsUpdate upd) = returnTc (info `setUpdateInfo` upd)
tcPrag info (HsNoCafRefs) = returnTc (info `setCafInfo` NoCafRefs)
tcPrag info HsCprInfo = returnTc (info `setCprInfo` ReturnsCPR)
----------------------------------------------------
get_con_details (VanillaCon btys) = unionManyUniqSets (map get_bty btys)
get_con_details (InfixCon bty1 bty2) = unionUniqSets (get_bty bty1) (get_bty bty2)
-get_con_details (NewCon ty _) = get_ty ty
get_con_details (RecCon nbtys) = unionManyUniqSets (map (get_bty.snd) nbtys)
----------------------------------------------------
returnTc (tycon_name, SynTyDetails rhs_ty)
-tcTyDecl1 (TyData _ context tycon_name _ con_decls _ derivings _ src_loc)
+tcTyDecl1 (TyData new_or_data context tycon_name _ con_decls _ derivings _ src_loc)
= tcLookupTy tycon_name `thenNF_Tc` \ (ATyCon tycon) ->
let
tyvars = tyConTyVars tycon
tcExtendTyVarEnv tyvars $
-- Typecheck the pieces
- tcClassContext context `thenTc` \ ctxt ->
- tc_derivs derivings `thenTc` \ derived_classes ->
- mapTc (tcConDecl tycon tyvars ctxt) con_decls `thenTc` \ data_cons ->
+ tcClassContext context `thenTc` \ ctxt ->
+ tc_derivs derivings `thenTc` \ derived_classes ->
+ mapTc (tcConDecl new_or_data tycon tyvars ctxt) con_decls `thenTc` \ data_cons ->
returnTc (tycon_name, DataTyDetails ctxt data_cons derived_classes)
where
where
kc_con_details (VanillaCon btys) = mapTc_ kc_bty btys
kc_con_details (InfixCon bty1 bty2) = mapTc_ kc_bty [bty1,bty2]
- kc_con_details (NewCon ty _) = kcHsSigType ty
kc_con_details (RecCon flds) = mapTc_ kc_field flds
kc_field (_, bty) = kc_bty bty
kc_bty bty = kcHsSigType (getBangType bty)
-tcConDecl :: TyCon -> [TyVar] -> ClassContext -> RenamedConDecl -> TcM s DataCon
+tcConDecl :: NewOrData -> TyCon -> [TyVar] -> ClassContext -> RenamedConDecl -> TcM s DataCon
-tcConDecl tycon tyvars ctxt (ConDecl name wkr_name ex_tvs ex_ctxt details src_loc)
+tcConDecl new_or_data tycon tyvars ctxt (ConDecl name wkr_name ex_tvs ex_ctxt details src_loc)
= tcAddSrcLoc src_loc $
kcTyVarScope ex_tvs (kcConDetails ex_ctxt details) `thenTc` \ ex_tv_kinds ->
let
case details of
VanillaCon btys -> tc_datacon ex_tyvars ex_theta btys
InfixCon bty1 bty2 -> tc_datacon ex_tyvars ex_theta [bty1,bty2]
- NewCon ty mb_f -> tc_newcon ex_tyvars ex_theta ty mb_f
RecCon fields -> tc_rec_con ex_tyvars ex_theta fields
where
+ tc_sig_type = case new_or_data of
+ DataType -> tcHsSigType
+ NewType -> tcHsBoxedSigType
+ -- Can't allow an unboxed type here, because we're effectively
+ -- going to remove the constructor while coercing it to a boxed type.
+
tc_datacon ex_tyvars ex_theta btys
= let
arg_stricts = map getBangStrictness btys
tys = map getBangType btys
in
- mapTc tcHsSigType tys `thenTc` \ arg_tys ->
+ mapTc tc_sig_type tys `thenTc` \ arg_tys ->
mk_data_con ex_tyvars ex_theta arg_stricts arg_tys []
- tc_newcon ex_tyvars ex_theta ty mb_f
- = tcHsBoxedSigType ty `thenTc` \ arg_ty ->
- -- can't allow an unboxed type here, because we're effectively
- -- going to remove the constructor while coercing it to a boxed type.
- let
- field_label =
- case mb_f of
- Nothing -> []
- Just f -> [mkFieldLabel (getName f) tycon arg_ty (head allFieldLabelTags)]
- in
- mk_data_con ex_tyvars ex_theta [notMarkedStrict] [arg_ty] field_label
-
tc_rec_con ex_tyvars ex_theta fields
= checkTc (null ex_tyvars) (exRecConErr name) `thenTc_`
mapTc tc_field (fields `zip` allFieldLabelTags) `thenTc` \ field_labels_s ->
(map fieldLabelType field_labels) field_labels
tc_field ((field_label_names, bty), tag)
- = tcHsSigType (getBangType bty) `thenTc` \ field_ty ->
+ = tc_sig_type (getBangType bty) `thenTc` \ field_ty ->
returnTc [mkFieldLabel (getName name) tycon field_ty tag | name <- field_label_names]
mk_data_con ex_tyvars ex_theta arg_stricts arg_tys fields
</VarListEntry>
<VarListEntry>
+<Term><Option>-ddump-hi-diffs</Option>:</Term>
+<ListItem>
+<Para>
+Dump to stdout a summary of the differences between the existing interface file (if any)
+for this module, and the new one.
+</Para>
+</ListItem>
+</VarListEntry>
+
+<VarListEntry>
<Term><Option>-ddump-tc</Option>:</Term>
<ListItem>
<Para>
</Para>
</ListItem>
</VarListEntry>
+
<VarListEntry>
-<Term><Option>-funfolding-con-discount<n></Option>:</Term>
+<Term><Option>-funfolding-update-in-place<n></Option>:</Term>
<ListItem>
-<Para>
-<IndexTerm><Primary>-funfolding-con-discount option</Primary></IndexTerm>
-<IndexTerm><Primary>inlining, controlling</Primary></IndexTerm>
-<IndexTerm><Primary>unfolding, controlling</Primary></IndexTerm>
-(Default: 2) If the compiler decides that it can eliminate some
-computation by performing an unfolding, then this is a discount factor
-that it applies to the funciton size before deciding whether to unfold
-it or not.
-</Para>
-
-<Para>
-OK, folks, these magic numbers `30', `8', and '2' are mildly
-arbitrary; they are of the “seem to be OK” variety. The `8' is the
-more critical one; it's what determines how eager GHC is about
-expanding unfoldings.
+Switches on an experimental "optimisation". Switching it on makes the compiler
+a little keener to inline a function that returns a constructor, if the context is
+that of a thunk.
+<ProgramListing>
+ x = plusInt a b
+</ProgramListing>
+If we inlined plusInt we might get an opportunity to use update-in-place for
+the thunk 'x'.
</Para>
</ListItem>
</VarListEntry>
+
<VarListEntry>
<Term><Option>-funbox-strict-fields</Option>:</Term>
<ListItem>
% -----------------------------------------------------------------------------
-% $Id: CPUTime.lhs,v 1.24 2000/07/07 11:03:57 simonmar Exp $
+% $Id: CPUTime.lhs,v 1.25 2000/09/14 13:46:42 simonpj Exp $
%
% (c) The University of Glasgow, 1995-2000
%
import PrelByteArr ( ByteArray(..), newIntArray )
import PrelArrExtra ( unsafeFreezeByteArray )
import PrelNum ( fromInt )
-import PrelIOBase ( IOError(..), IOException(..),
+import PrelIOBase ( IOError, IOException(..),
IOErrorType( UnsupportedOperation ),
unsafePerformIO, stToIO, ioException )
import Ratio
% ------------------------------------------------------------------------------
-% $Id: PrelList.lhs,v 1.21 2000/08/29 16:35:56 simonpj Exp $
+% $Id: PrelList.lhs,v 1.22 2000/09/14 13:46:42 simonpj Exp $
%
% (c) The University of Glasgow, 1994-2000
%
concatMap f = foldr ((++) . f) []
concat :: [[a]] -> [a]
-{-# INLINE concat #-}
concat = foldr (++) []
+
+{-# RULES
+ "concat" forall xs. concat xs = build (\c n -> foldr (\x y -> foldr c y x) n xs)
+ #-}
\end{code}
% ------------------------------------------------------------------------------
-% $Id: PrelShow.lhs,v 1.11 2000/06/30 13:39:36 simonmar Exp $
+% $Id: PrelShow.lhs,v 1.12 2000/09/14 13:46:42 simonpj Exp $
%
% (c) The University of Glasgow, 1992-2000
%
instance Show a => Show (Maybe a) where
showsPrec _p Nothing s = showString "Nothing" s
- showsPrec p@(I# p#) (Just x) s
+ showsPrec (I# p#) (Just x) s
= (showParen (p# >=# 10#) $
showString "Just " .
showsPrec (I# 10#) x) s
instance (Show a, Show b) => Show (Either a b) where
- showsPrec p@(I# p#) e s =
+ showsPrec (I# p#) e s =
(showParen (p# >=# 10#) $
case e of
Left a -> showString "Left " . showsPrec (I# 10#) a
\begin{code}
showLitChar :: Char -> ShowS
-showLitChar c | c > '\DEL' = \s -> showChar '\\' (protectEsc isDigit (shows (ord c)) s)
-showLitChar '\DEL' = showString "\\DEL"
-showLitChar '\\' = showString "\\\\"
-showLitChar c | c >= ' ' = showChar c
-showLitChar '\a' = showString "\\a"
-showLitChar '\b' = showString "\\b"
-showLitChar '\f' = showString "\\f"
-showLitChar '\n' = showString "\\n"
-showLitChar '\r' = showString "\\r"
-showLitChar '\t' = showString "\\t"
-showLitChar '\v' = showString "\\v"
-showLitChar '\SO' = \s -> protectEsc (== 'H') (showString "\\SO") s
-showLitChar c = \s -> showString ('\\' : asciiTab!!ord c) s
- -- The "\s ->" here means that GHC knows it's ok to put the
- -- asciiTab!!ord c inside the lambda. Otherwise we get an extra
- -- lambda allocated, and that can be pretty bad
+showLitChar c s | c > '\DEL' = showChar '\\' (protectEsc isDigit (shows (ord c)) s)
+showLitChar '\DEL' s = showString "\\DEL" s
+showLitChar '\\' s = showString "\\\\" s
+showLitChar c s | c >= ' ' = showChar c s
+showLitChar '\a' s = showString "\\a" s
+showLitChar '\b' s = showString "\\b" s
+showLitChar '\f' s = showString "\\f" s
+showLitChar '\n' s = showString "\\n" s
+showLitChar '\r' s = showString "\\r" s
+showLitChar '\t' s = showString "\\t" s
+showLitChar '\v' s = showString "\\v" s
+showLitChar '\SO' s = protectEsc (== 'H') (showString "\\SO") s
+showLitChar c s = showString ('\\' : asciiTab!!ord c) s
+ -- I've done manual eta-expansion here, becuase otherwise it's
+ -- impossible to stop (asciiTab!!ord) getting floated out as an MFE
protectEsc :: (Char -> Bool) -> ShowS -> ShowS
protectEsc p f = f . cont
\begin{code}
isAscii, isLatin1, isControl, isPrint, isSpace, isUpper,
- isLower, isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum :: Char -> Bool
+ isLower, isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum,
+ isAsciiUpper, isAsciiLower :: Char -> Bool
isAscii c = c < '\x80'
isLatin1 c = c <= '\xff'
isControl c = c < ' ' || c >= '\DEL' && c <= '\x9f'
% -----------------------------------------------------------------------------
-% $Id: PrelTup.lhs,v 1.9 2000/06/30 13:39:36 simonmar Exp $
+% $Id: PrelTup.lhs,v 1.10 2000/09/14 13:46:42 simonpj Exp $
%
% (c) The University of Glasgow, 1992-2000
%
module PrelTup where
-import {-# SOURCE #-} PrelErr ( error )
import PrelBase
default () -- Double isn't available yet
projects / ghc-hetmet.git / commitdiff