Commit d3f61314 authored by simonpj's avatar simonpj
Browse files

[project @ 2001-09-07 12:42:46 by simonpj]

------------------------
	Fix the demand analyser
	------------------------

A spiffy new domain for demands, and definitions for lub/both
which are actually monotonic.   Quite a bit of related jiggling
around.

One of the original motivations was to do with functions like:

	sum n []     = n
	sum n (x:xs) = sum (n+x) xs

Even though n is returned boxed from the first case, we don't want
to get strictness
	S(L)V -> T
because that means we pass the box for n, and that is TERRIBLE.
So the new version errs on the side of unboxing, more like the forwards
analyser, and only passes the box if it is *definitely* needed, rather
than if it *may* be needed.
parent 3446ed6c
......@@ -97,8 +97,8 @@ import FieldLabel ( FieldLabel )
import Type ( usOnce, usMany )
import Demand hiding( Demand )
import qualified Demand
import NewDemand ( Demand(..), Keepity(..), Deferredness(..), DmdResult(..),
lazyDmd, topDmd,
import NewDemand ( Demand(..), Keepity(..), DmdResult(..),
lazyDmd, topDmd, dmdTypeDepth,
StrictSig, mkStrictSig, mkTopDmdType
)
import Outputable
......@@ -138,15 +138,19 @@ mkNewStrictnessInfo id arity (Demand.StrictnessInfo ds res) cpr
| length ds <= arity
-- Sometimes the old strictness analyser has more
-- demands than the arity justifies
= mkStrictSig id arity $
= mk_strict_sig id arity $
mkTopDmdType (map newDemand ds) (newRes res cpr)
mkNewStrictnessInfo id arity other cpr
= -- Either no strictness info, or arity is too small
-- In either case we can't say anything useful
mkStrictSig id arity $
mk_strict_sig id arity $
mkTopDmdType (replicate arity lazyDmd) (newRes False cpr)
mk_strict_sig id arity dmd_ty
= WARN( arity /= dmdTypeDepth dmd_ty, ppr id <+> (ppr arity $$ ppr dmd_ty) )
mkStrictSig dmd_ty
newRes True _ = BotRes
newRes False ReturnsCPR = RetCPR
newRes False NoCPRInfo = TopRes
......@@ -155,18 +159,18 @@ newDemand :: Demand.Demand -> NewDemand.Demand
newDemand (WwLazy True) = Abs
newDemand (WwLazy False) = Lazy
newDemand WwStrict = Eval
newDemand (WwUnpack unpk ds) = Seq Drop Now (map newDemand ds)
newDemand (WwUnpack unpk ds) = Seq Drop (map newDemand ds)
newDemand WwPrim = Lazy
newDemand WwEnum = Eval
oldDemand :: NewDemand.Demand -> Demand.Demand
oldDemand Abs = WwLazy True
oldDemand Lazy = WwLazy False
oldDemand Bot = WwStrict
oldDemand Err = WwStrict
oldDemand Eval = WwStrict
oldDemand (Seq _ _ ds) = WwUnpack True (map oldDemand ds)
oldDemand (Call _) = WwStrict
oldDemand Abs = WwLazy True
oldDemand Lazy = WwLazy False
oldDemand Bot = WwStrict
oldDemand Err = WwStrict
oldDemand Eval = WwStrict
oldDemand (Seq _ ds) = WwUnpack True (map oldDemand ds)
oldDemand (Call _) = WwStrict
\end{code}
......
......@@ -5,10 +5,10 @@
\begin{code}
module NewDemand(
Demand(..), Keepity(..), Deferredness(..),
topDmd, lazyDmd, seqDmd, evalDmd, isStrictDmd, isAbsentDmd,
Demand(..), Keepity(..),
mkSeq, topDmd, lazyDmd, seqDmd, evalDmd, isStrictDmd, defer,
DmdType(..), topDmdType, mkDmdType, mkTopDmdType,
DmdType(..), topDmdType, botDmdType, mkDmdType, mkTopDmdType,
dmdTypeDepth, dmdTypeRes,
DmdEnv, emptyDmdEnv,
DmdResult(..), isBotRes, returnsCPR,
......@@ -21,10 +21,8 @@ module NewDemand(
#include "HsVersions.h"
import BasicTypes ( Arity )
import Var ( Id )
import VarEnv ( VarEnv, emptyVarEnv )
import UniqFM ( ufmToList )
import qualified Demand
import Outputable
\end{code}
......@@ -145,10 +143,8 @@ instance Outputable StrictSig where
instance Show StrictSig where
show (StrictSig ty) = showSDoc (ppr ty)
mkStrictSig :: Id -> Arity -> DmdType -> StrictSig
mkStrictSig id arity dmd_ty
= WARN( arity /= dmdTypeDepth dmd_ty, ppr id <+> (ppr arity $$ ppr dmd_ty) )
StrictSig dmd_ty
mkStrictSig :: DmdType -> StrictSig
mkStrictSig dmd_ty = StrictSig dmd_ty
splitStrictSig :: StrictSig -> ([Demand], DmdResult)
splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
......@@ -184,58 +180,69 @@ data Demand
= Lazy -- L; used for unlifted types too, so that
-- A `lub` L = L
| Abs -- A
| Call Demand -- C(d)
| Eval -- V
| Seq Keepity -- S/U(ds)
Deferredness
[Demand]
| Seq Keepity -- S/U/D(ds)
[Demand] -- S(ds) = L `both` U(ds)
-- D(ds) = A `lub` U(ds)
-- *** Invariant: these demands are never Bot or Abs
-- *** Invariant: if all demands are Abs, get []
| Err -- X
| Bot -- B
deriving( Eq )
-- Equality needed for fixpoints in DmdAnal
data Deferredness = Now | Defer
deriving( Eq )
data Keepity = Keep | Drop
data Keepity = Keep | Drop | Defer
deriving( Eq )
mkSeq :: Keepity -> [Demand] -> Demand
mkSeq k ds | all is_absent ds = Seq k []
| otherwise = Seq k ds
where
is_absent Abs = True
is_absent d = False
defer :: Demand -> Demand
-- Computes (Abs `lub` d)
-- For the Bot case consider
-- f x y = if ... then x else error x
-- Then for y we get Abs `lub` Bot, and we really
-- want Abs overall
defer Bot = Abs
defer Abs = Abs
defer (Seq Keep ds) = Lazy
defer (Seq _ ds) = Seq Defer ds
defer d = Lazy
topDmd, lazyDmd, seqDmd :: Demand
topDmd = Lazy -- The most uninformative demand
topDmd = Lazy -- The most uninformative demand
lazyDmd = Lazy
seqDmd = Seq Keep Now [] -- Polymorphic seq demand
seqDmd = Seq Keep [] -- Polymorphic seq demand
evalDmd = Eval
isStrictDmd :: Demand -> Bool
isStrictDmd Bot = True
isStrictDmd Err = True
isStrictDmd (Seq _ Now _) = True
isStrictDmd Eval = True
isStrictDmd (Call _) = True
isStrictDmd other = False
isAbsentDmd :: Demand -> Bool
isAbsentDmd Bot = True
isAbsentDmd Err = True
isAbsentDmd Abs = True
isAbsentDmd other = False
isStrictDmd Bot = True
isStrictDmd Err = True
isStrictDmd (Seq _ _) = True
isStrictDmd Eval = True
isStrictDmd (Call _) = True
isStrictDmd other = False
instance Outputable Demand where
ppr Lazy = char 'L'
ppr Abs = char 'A'
ppr Eval = char 'V'
ppr Err = char 'X'
ppr Bot = char 'B'
ppr (Call d) = char 'C' <> parens (ppr d)
ppr (Seq k l []) = ppr k <> ppr l
ppr (Seq k l ds) = ppr k <> ppr l <> parens (hcat (map ppr ds))
instance Outputable Deferredness where
ppr Now = empty
ppr Defer = char '*'
ppr Lazy = char 'L'
ppr Abs = char 'A'
ppr Eval = char 'V'
ppr Err = char 'X'
ppr Bot = char 'B'
ppr (Call d) = char 'C' <> parens (ppr d)
ppr (Seq k []) = ppr k
ppr (Seq k ds) = ppr k <> parens (hcat (map ppr ds))
instance Outputable Keepity where
ppr Keep = char 'S'
ppr Drop = char 'U'
ppr Keep = char 'S'
ppr Drop = char 'U'
ppr Defer = char 'D'
\end{code}
......@@ -41,7 +41,7 @@ import PrelNames ( mkTupNameStr )
import CmdLineOpts ( opt_HiVersion, opt_NoHiCheck )
import ForeignCall ( Safety(..) )
import NewDemand ( StrictSig(..), Demand(..), Keepity(..),
DmdResult(..), Deferredness(..), mkTopDmdType )
DmdResult(..), mkTopDmdType )
import UniqFM ( listToUFM, lookupUFM )
import BasicTypes ( Boxity(..) )
import SrcLoc ( SrcLoc, incSrcLine, srcLocFile, srcLocLine,
......@@ -833,19 +833,19 @@ lex_demand cont buf =
'B'# -> read_em (Bot : acc) (stepOn buf)
')'# -> (reverse acc, stepOn buf)
'C'# -> do_call acc (stepOnBy# buf 2#)
'U'# -> do_unpack1 Drop Now acc (stepOnBy# buf 1#)
'S'# -> do_unpack1 Keep Now acc (stepOnBy# buf 1#)
'D'# -> do_unpack1 Defer acc (stepOnBy# buf 1#)
'U'# -> do_unpack1 Drop acc (stepOnBy# buf 1#)
'S'# -> do_unpack1 Keep acc (stepOnBy# buf 1#)
_ -> (reverse acc, buf)
do_unpack1 keepity defer acc buf
do_unpack1 keepity acc buf
= case currentChar# buf of
'*'# -> do_unpack1 keepity Defer acc (stepOnBy# buf 1#)
'('# -> do_unpack2 keepity defer acc (stepOnBy# buf 1#)
_ -> read_em (Seq keepity defer [] : acc) buf
'('# -> do_unpack2 keepity acc (stepOnBy# buf 1#)
_ -> read_em (Seq keepity [] : acc) buf
do_unpack2 keepity defer acc buf
do_unpack2 keepity acc buf
= case read_em [] buf of
(stuff, rest) -> read_em (Seq keepity defer stuff : acc) rest
(stuff, rest) -> read_em (Seq keepity stuff : acc) rest
do_call acc buf
= case read_em [] buf of
......
This diff is collapsed.
......@@ -14,12 +14,9 @@ import CoreLint ( showPass, endPass )
import CoreUtils ( exprType )
import Id ( Id, idType, idNewStrictness, idArity, isOneShotLambda,
setIdNewStrictness, zapIdNewStrictness, idInlinePragma, mkWorkerId,
setIdWorkerInfo, idCprInfo, setInlinePragma )
setIdWorkerInfo, setInlinePragma )
import Type ( Type )
import IdInfo ( mkStrictnessInfo, noStrictnessInfo, StrictnessInfo(..),
CprInfo(..), InlinePragInfo(..), isNeverInlinePrag,
WorkerInfo(..)
)
import IdInfo ( InlinePragInfo(..), isNeverInlinePrag, WorkerInfo(..) )
import NewDemand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..),
mkTopDmdType, isBotRes, returnsCPR
)
......@@ -297,9 +294,9 @@ worthSplitting (StrictSig (DmdType _ ds res))
-- [We don't do reboxing now, but in general it's better to pass
-- an unboxed thing to f, and have it reboxed in the error cases....]
where
worth_it Abs = True -- Absent arg
worth_it (Seq _ _ ds) = True -- Arg to evaluate
worth_it other = False
worth_it Abs = True -- Absent arg
worth_it (Seq _ ds) = True -- Arg to evaluate
worth_it other = False
\end{code}
......@@ -324,5 +321,3 @@ mkWrapper fun_ty (StrictSig (DmdType _ demands res_info))
noOneShotInfo = repeat False
\end{code}
......@@ -16,7 +16,7 @@ import Id ( Id, idType, mkSysLocal, idNewDemandInfo, setIdNewDemandInfo,
)
import IdInfo ( vanillaIdInfo )
import DataCon ( splitProductType_maybe, splitProductType )
import NewDemand ( Demand(..), Keepity(..), DmdResult(..), isAbsentDmd )
import NewDemand ( Demand(..), Keepity(..), DmdResult(..) )
import DmdAnal ( both )
import PrelInfo ( realWorldPrimId, aBSENT_ERROR_ID, eRROR_CSTRING_ID )
import TysPrim ( realWorldStatePrimTy )
......@@ -271,7 +271,7 @@ mkWWstr :: Type -- Result type
-- but *with* lambdas
mkWWstr res_ty wrap_args
= mk_ww_str wrap_args `thenUs` \ (work_args, take_apart, put_together) ->
= mk_ww_str_s wrap_args `thenUs` \ (work_args, take_apart, put_together) ->
let
work_dmds = [idNewDemandInfo v | v <- work_args, isId v]
apply_to args fn = mkVarApps fn args
......@@ -297,17 +297,23 @@ mkWWstr res_ty wrap_args
take_apart . applyToVars [realWorldPrimId] . apply_to work_args,
mkLams work_args . Lam void_arg . put_together)
-- Empty case
mk_ww_str []
= returnUs ([],
\ wrapper_body -> wrapper_body,
\ worker_body -> worker_body)
----------------------
nop_fn body = body
----------------------
mk_ww_str_s []
= returnUs ([], nop_fn, nop_fn)
mk_ww_str (arg : ds)
mk_ww_str_s (arg : args)
= mk_ww_str arg `thenUs` \ (args1, wrap_fn1, work_fn1) ->
mk_ww_str_s args `thenUs` \ (args2, wrap_fn2, work_fn2) ->
returnUs (args1 ++ args2, wrap_fn1 . wrap_fn2, work_fn1 . work_fn2)
----------------------
mk_ww_str arg
| isTyVar arg
= mk_ww_str ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
returnUs (arg : worker_args, wrap_fn, work_fn)
= returnUs ([arg], nop_fn, nop_fn)
| otherwise
= case idNewDemandInfo arg of
......@@ -316,19 +322,16 @@ mk_ww_str (arg : ds)
-- though, because it's not so easy to manufacture a placeholder
-- We'll see if this turns out to be a problem
Abs | not (isUnLiftedType (idType arg)) ->
mk_ww_str ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
returnUs (worker_args, wrap_fn, mk_absent_let arg . work_fn)
returnUs ([], nop_fn, mk_absent_let arg)
-- Seq and keep
Seq _ _ cs
| all isAbsentDmd cs
-> mk_ww_str ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
let
Seq _ []
-> let
arg_w_unf = arg `setIdUnfolding` mkOtherCon []
-- Tell the worker arg that it's sure to be evaluated
-- so that internal seqs can be dropped
in
returnUs (arg_w_unf : worker_args, mk_seq_case arg . wrap_fn, work_fn)
returnUs ([arg_w_unf], mk_seq_case arg, nop_fn)
-- Pass the arg, anyway, even if it is in theory discarded
-- Consider
-- f x y = x `seq` y
......@@ -342,9 +345,8 @@ mk_ww_str (arg : ds)
-- But the Evald flag is pretty wierd, and I worry that it might disappear
-- during simplification, so for now I've just nuked this whole case
-- Unpack case
Seq keep _ cs
Seq keep cs
| Just (arg_tycon, tycon_arg_tys, data_con, inst_con_arg_tys)
<- splitProductType_maybe (idType arg)
-> getUniquesUs `thenUs` \ uniqs ->
......@@ -352,7 +354,8 @@ mk_ww_str (arg : ds)
unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys
unpk_args_w_ds = zipWithEqual "mk_ww_str" set_worker_arg_info unpk_args cs'
unbox_fn = mk_unpk_case arg unpk_args data_con arg_tycon
rebox_fn = mk_pk_let arg data_con tycon_arg_tys unpk_args
rebox_fn = Let (NonRec arg con_app)
con_app = mkConApp data_con (map Type tycon_arg_tys ++ map Var unpk_args)
cs' = case keep of
Keep -> map (DmdAnal.both Lazy) cs -- Careful! Now we don't pass
......@@ -361,7 +364,7 @@ mk_ww_str (arg : ds)
-- S(LA) --> U(LL)
Drop -> cs
in
mk_ww_str (unpk_args_w_ds ++ ds) `thenUs` \ (worker_args, wrap_fn, work_fn) ->
mk_ww_str_s unpk_args_w_ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
-- case keep of
-- Keep -> returnUs (arg : worker_args, unbox_fn . wrap_fn, work_fn)
......@@ -380,13 +383,11 @@ mk_ww_str (arg : ds)
| otherwise ->
WARN( True, ppr arg )
mk_ww_str ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
returnUs (arg : worker_args, wrap_fn, work_fn)
returnUs ([arg], nop_fn, nop_fn)
-- Other cases
other_demand ->
mk_ww_str ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
returnUs (arg : worker_args, wrap_fn, work_fn)
other_demand -> returnUs ([arg], nop_fn, nop_fn)
where
-- If the wrapper argument is a one-shot lambda, then
-- so should (all) the corresponding worker arguments be
......@@ -512,10 +513,5 @@ sanitiseCaseBndr :: Id -> Id
-- like (x+y) `seq` ....
sanitiseCaseBndr id = id `setIdInfo` vanillaIdInfo
mk_pk_let arg boxing_con con_tys unpk_args body
= Let (NonRec arg (mkConApp boxing_con con_args)) body
where
con_args = map Type con_tys ++ map Var unpk_args
mk_ww_local uniq ty = mkSysLocal SLIT("ww") uniq ty
\end{code}
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment