Commit cae34044 authored by simonpj's avatar simonpj

[project @ 2000-09-14 13:46:39 by simonpj]

---------------------------------------
	Simon's tuning changes: early Sept 2000
	---------------------------------------

Library changes
~~~~~~~~~~~~~~~
* Eta expand PrelShow.showLitChar.  It's impossible to compile this well,
  and it makes a big difference to some programs (e.g. gen_regexps)

* Make PrelList.concat into a good producer (in the foldr/build sense)


Flag changes
~~~~~~~~~~~~
* Add -ddump-hi-diffs to print out changes in interface files.  Useful
  when watching what the compiler is doing

* Add -funfolding-update-in-place to enable the experimental optimisation
  that makes the inliner a bit keener to inline if it's in the RHS of
  a thunk that might be updated in place.  Sometimes this is a bad idea
  (one example is in spectral/sphere; see notes in nofib/Simon-nofib-notes)


Tuning things
~~~~~~~~~~~~~
* Fix a bug in SetLevels.lvlMFE.  (change ctxt_lvl to dest_level)
  I don't think this has any performance effect, but it saves making
  a redundant let-binding that is later eliminated.

* Desugar.dsProgram and DsForeign
  Glom together all the bindings into a single Rec.  Previously the
  bindings generated by 'foreign' declarations were not glommed together, but
  this led to an infelicity (i.e. poorer code than necessary) in the modules
  that actually declare Float and Double (explained a bit more in Desugar.dsProgram)

* OccurAnal.shortMeOut and IdInfo.shortableIdInfo
  Don't do the occurrence analyser's shorting out stuff for things which
  have rules.  Comments near IdInfo.shortableIdInfo.
  This is deeply boring, and mainly to do with making rules work well.
  Maybe rules should have phases attached too....

* CprAnalyse.addIdCprInfo
  Be a bit more willing to add CPR information to thunks;
  in particular, if the strictness analyser has just discovered that this
  is a strict let, then the let-to-case transform will happen, and CPR is fine.
  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

* MkId.mkDataConWrapId
  Arrange that vanilla constructors, like (:) and I#, get unfoldings that are
  just a simple variable $w:, $wI#.  This ensures they'll be inlined even into
  rules etc, which makes matching a bit more reliable.  The downside is that in
  situations like (map (:) xs), we'll end up with (map (\y ys. $w: y ys) xs.
  Which is tiresome but it doesn't happen much.

* SaAbsInt.findStrictness
  Deal with the case where a thing with no arguments is bottom.  This is Good.
  E.g.   module M where { foo = error "help" }
  Suppose we have in another module
	case M.foo of ...
  Then we'd like to do the case-of-error transform, without inlining foo.


Tidying up things
~~~~~~~~~~~~~~~~~
* Reorganised Simplify.completeBinding (again).

* Removed the is_bot field in CoreUnfolding (is_cheap is true if is_bot is!)
  This is just a tidy up

* HsDecls and others
  Remove the NewCon constructor from ConDecl.  It just added code, and nothing else.
  And it led to a bug in MkIface, which though that a newtype decl was always changing!

* IdInfo and many others
  Remove all vestiges of UpdateInfo (hasn't been used for years)
parent 189333a4
......@@ -48,7 +48,6 @@ module Id (
setIdStrictness,
setIdWorkerInfo,
setIdSpecialisation,
setIdUpdateInfo,
setIdCafInfo,
setIdCprInfo,
setIdOccInfo,
......@@ -60,7 +59,6 @@ module Id (
idWorkerInfo,
idUnfolding,
idSpecialisation,
idUpdateInfo,
idCafInfo,
idCprInfo,
idLBVarInfo,
......@@ -106,7 +104,6 @@ infixl 1 `setIdUnfolding`,
`setIdStrictness`,
`setIdWorkerInfo`,
`setIdSpecialisation`,
`setIdUpdateInfo`,
`setInlinePragma`,
`idCafInfo`,
`idCprInfo`
......@@ -352,14 +349,6 @@ idDemandInfo id = demandInfo (idInfo id)
setIdDemandInfo :: Id -> Demand -> Id
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
......
......@@ -13,7 +13,7 @@ module IdInfo (
vanillaIdInfo, mkIdInfo, seqIdInfo, megaSeqIdInfo,
-- Zapping
zapFragileInfo, zapLamInfo, zapSpecPragInfo, copyIdInfo,
zapFragileInfo, zapLamInfo, zapSpecPragInfo, shortableIdInfo, copyIdInfo,
-- Flavour
IdFlavour(..), flavourInfo,
......@@ -55,10 +55,6 @@ module IdInfo (
-- Specialisation
specInfo, setSpecInfo,
-- Update
UpdateInfo, UpdateSpec,
mkUpdateInfo, updateInfo, updateInfoMaybe, ppUpdateInfo, setUpdateInfo,
-- CAF info
CafInfo(..), cafInfo, setCafInfo, ppCafInfo,
......@@ -86,8 +82,7 @@ import Demand -- Lots of stuff
import Outputable
import Maybe ( isJust )
infixl 1 `setUpdateInfo`,
`setDemandInfo`,
infixl 1 `setDemandInfo`,
`setStrictnessInfo`,
`setSpecInfo`,
`setArityInfo`,
......@@ -127,7 +122,6 @@ data IdInfo
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
......@@ -185,7 +179,6 @@ setUnfoldingInfo info uf
-- 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 }
......@@ -214,7 +207,6 @@ mkIdInfo flv = IdInfo {
workerInfo = NoWorker,
strictnessInfo = NoStrictnessInfo,
unfoldingInfo = noUnfolding,
updateInfo = NoUpdateInfo,
cafInfo = MayHaveCafRefs,
cprInfo = NoCPRInfo,
lbvarInfo = NoLBVarInfo,
......@@ -400,40 +392,6 @@ wrapperArity (HasWorker _ a) = a
\end{code}
%************************************************************************
%* *
\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}
......@@ -649,26 +607,60 @@ copyIdInfo is used when shorting out a top-level binding
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}
......@@ -258,10 +258,6 @@ mkDataConWrapId data_con
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
......@@ -270,10 +266,16 @@ mkDataConWrapId data_con
-- 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 $
......
......@@ -180,12 +180,11 @@ data Unfolding
| 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.
......@@ -208,8 +207,8 @@ noUnfolding = NoUnfolding
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` ()
......@@ -218,14 +217,14 @@ seqGuidance other = ()
\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
......@@ -233,27 +232,27 @@ otherCons other = []
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
......
......@@ -33,10 +33,8 @@ module CoreUnfold (
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
......@@ -78,9 +76,12 @@ mkTopUnfolding expr = mkUnfolding True {- Top level -} expr
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
......@@ -444,7 +445,7 @@ certainlyWillInline :: Id -> Bool
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
......@@ -526,7 +527,7 @@ callSiteInline black_listed inline_call occ id arg_infos interesting_cont
-- 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
......@@ -534,16 +535,13 @@ callSiteInline black_listed inline_call occ id arg_infos interesting_cont
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,
......@@ -622,8 +620,6 @@ callSiteInline black_listed inline_call occ id arg_infos interesting_cont
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
......
......@@ -25,7 +25,7 @@ import Id ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity,
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
......@@ -340,7 +340,6 @@ ppIdInfo b info
= hsep [
ppFlavourInfo (flavourInfo info),
ppArityInfo a,
ppUpdateInfo u,
ppWorkerInfo (workerInfo info),
ppStrictnessInfo s,
ppCafInfo c,
......@@ -353,7 +352,6 @@ ppIdInfo b info
where
a = arityInfo info
s = strictnessInfo info
u = updateInfo info
c = cafInfo info
m = cprInfo info
p = specInfo info
......
......@@ -10,9 +10,10 @@ import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_cpranal )
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
......@@ -158,16 +159,16 @@ cprAnalBind :: CPREnv -> CoreBind -> (CPREnv, CoreBind)
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.
......@@ -176,18 +177,12 @@ cprAnalBind rho (Rec prs)
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.
......@@ -264,56 +259,47 @@ cprAnalCaseAlts rho alts
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
......
......@@ -72,10 +72,15 @@ deSugar mod_name us (TcResults {tc_env = global_val_env,
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' ->
......
......@@ -63,31 +63,35 @@ is the same as
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
......@@ -128,7 +132,7 @@ dsFImport :: Id
-> 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