WwLib.lhs 29.2 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
3
%
Ian Lynagh's avatar
Ian Lynagh committed
4
\section[WwLib]{A library for the ``worker\/wrapper'' back-end to the strictness analyser}
5 6

\begin{code}
7
module WwLib ( mkWwBodies, mkWWstr, mkWorkerArgs, deepSplitProductType_maybe ) where
8

9
#include "HsVersions.h"
10

11
import CoreSyn
12 13
import CoreUtils        ( exprType, mkCast )
import Id               ( Id, idType, mkSysLocal, idDemandInfo, setIdDemandInfo,
14 15
                          setIdUnfolding,
                          setIdInfo, idOneShotInfo, setIdOneShotInfo
16 17
                        )
import IdInfo           ( vanillaIdInfo )
18
import DataCon
19 20
import Demand
import MkCore           ( mkRuntimeErrorApp, aBSENT_ERROR_ID )
21 22
import MkId             ( voidArgId, voidPrimId )
import TysPrim          ( voidPrimTy )
23
import TysWiredIn       ( tupleCon )
24
import Type
25
import Coercion hiding  ( substTy, substTyVarBndr )
26
import FamInstEnv
27
import BasicTypes       ( TupleSort(..), OneShotInfo(..), worstOneShot )
28
import Literal          ( absentLiteralOf )
29
import TyCon
30
import UniqSupply
31
import Unique
32
import Maybes
33
import Util
sof's avatar
sof committed
34
import Outputable
35
import DynFlags
36
import FastString
37 38 39 40
\end{code}


%************************************************************************
41
%*                                                                      *
42
\subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}
43
%*                                                                      *
44 45 46
%************************************************************************

Here's an example.  The original function is:
47

48 49 50
\begin{verbatim}
g :: forall a . Int -> [a] -> a

Ian Lynagh's avatar
Ian Lynagh committed
51
g = \/\ a -> \ x ys ->
52 53 54
        case x of
          0 -> head ys
          _ -> head (tail ys)
55 56 57 58 59 60 61
\end{verbatim}

From this, we want to produce:
\begin{verbatim}
-- wrapper (an unfolding)
g :: forall a . Int -> [a] -> a

Ian Lynagh's avatar
Ian Lynagh committed
62
g = \/\ a -> \ x ys ->
63 64 65
        case x of
          I# x# -> $wg a x# ys
            -- call the worker; don't forget the type args!
66 67

-- worker
68
$wg :: forall a . Int# -> [a] -> a
69

Ian Lynagh's avatar
Ian Lynagh committed
70
$wg = \/\ a -> \ x# ys ->
71 72 73 74 75 76
        let
            x = I# x#
        in
            case x of               -- note: body of g moved intact
              0 -> head ys
              _ -> head (tail ys)
77 78 79
\end{verbatim}

Something we have to be careful about:  Here's an example:
80

81 82 83 84
\begin{verbatim}
-- "f" strictness: U(P)U(P)
f (I# a) (I# b) = a +# b

85
g = f   -- "g" strictness same as "f"
86
\end{verbatim}
87

88 89 90 91 92 93 94 95 96 97 98
\tr{f} will get a worker all nice and friendly-like; that's good.
{\em But we don't want a worker for \tr{g}}, even though it has the
same strictness as \tr{f}.  Doing so could break laziness, at best.

Consequently, we insist that the number of strictness-info items is
exactly the same as the number of lambda-bound arguments.  (This is
probably slightly paranoid, but OK in practice.)  If it isn't the
same, we ``revise'' the strictness info, so that we won't propagate
the unusable strictness-info into the interfaces.


99
%************************************************************************
100
%*                                                                      *
101
\subsection{The worker wrapper core}
102
%*                                                                      *
103
%************************************************************************
104

Ian Lynagh's avatar
Ian Lynagh committed
105
@mkWwBodies@ is called when doing the worker\/wrapper split inside a module.
106 107

\begin{code}
108
mkWwBodies :: DynFlags
109
           -> FamInstEnvs
110 111 112 113 114 115 116
           -> Type                                  -- Type of original function
           -> [Demand]                              -- Strictness of original function
           -> DmdResult                             -- Info about function result
           -> [OneShotInfo]                         -- One-shot-ness of the function, value args only
           -> UniqSM (Maybe ([Demand],              -- Demands for worker (value) args
                             Id -> CoreExpr,        -- Wrapper body, lacking only the worker Id
                             CoreExpr -> CoreExpr)) -- Worker body, lacking the original function rhs
117 118 119 120 121 122 123 124 125 126 127

-- wrap_fn_args E       = \x y -> E
-- work_fn_args E       = E x y

-- wrap_fn_str E        = case x of { (a,b) ->
--                        case a of { (a1,a2) ->
--                        E a1 a2 b y }}
-- work_fn_str E        = \a2 a2 b y ->
--                        let a = (a1,a2) in
--                        let x = (a,b) in
--                        E
128

129
mkWwBodies dflags fam_envs fun_ty demands res_info one_shots
130 131
  = do  { let arg_info = demands `zip` (one_shots ++ repeat NoOneShotInfo)
              all_one_shots = foldr (worstOneShot . snd) OneShotLam arg_info
132
        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) <- mkWWargs emptyTvSubst fun_ty arg_info
133
        ; (useful1, work_args, wrap_fn_str, work_fn_str) <- mkWWstr dflags fam_envs wrap_args
134

135
        -- Do CPR w/w.  See Note [Always do CPR w/w]
136
        ; (useful2, wrap_fn_cpr, work_fn_cpr,  cpr_res_ty) <- mkWWcpr fam_envs res_ty res_info
137

138
        ; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args all_one_shots cpr_res_ty
139 140 141 142 143 144 145 146
              worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v]
              wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var
              worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args

        ; if useful1 && not (only_one_void_argument) || useful2
          then return (Just (worker_args_dmds, wrapper_body, worker_body))
          else return Nothing
        }
147 148 149 150 151 152 153
        -- We use an INLINE unconditionally, even if the wrapper turns out to be
        -- something trivial like
        --      fw = ...
        --      f = __inline__ (coerce T fw)
        -- The point is to propagate the coerce to f's call sites, so even though
        -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent
        -- fw from being inlined into f's RHS
154 155 156 157 158 159 160 161 162 163
  where
    -- Note [Do not split void functions]
    only_one_void_argument
      | [d] <- demands
      , Just (arg_ty1, _) <- splitFunTy_maybe fun_ty
      , isAbsDmd d && isVoidTy arg_ty1
      = True
      | otherwise
      = False

164
\end{code}
165

166 167 168 169 170
Note [Always do CPR w/w]
~~~~~~~~~~~~~~~~~~~~~~~~
At one time we refrained from doing CPR w/w for thunks, on the grounds that
we might duplicate work.  But that is already handled by the demand analyser,
which doesn't give the CPR proprety if w/w might waste work: see
171
Note [CPR for thunks] in DmdAnal.
172 173 174 175 176 177

And if something *has* been given the CPR property and we don't w/w, it's
a disaster, because then the enclosing function might say it has the CPR
property, but now doesn't and there a cascade of disaster.  A good example
is Trac #5920.

178 179

%************************************************************************
180
%*                                                                      *
181
\subsection{Making wrapper args}
182
%*                                                                      *
183 184 185 186 187 188
%************************************************************************

During worker-wrapper stuff we may end up with an unlifted thing
which we want to let-bind without losing laziness.  So we
add a void argument.  E.g.

189
        f = /\a -> \x y z -> E::Int#    -- E does not mention x,y,z
190
==>
191 192
        fw = /\ a -> \void -> E
        f  = /\ a -> \x y z -> fw realworld
193 194 195 196

We use the state-token type which generates no code.

\begin{code}
197
mkWorkerArgs :: DynFlags -> [Var]
198
             -> OneShotInfo  -- Whether all arguments are one-shot
199 200 201
             -> Type    -- Type of body
             -> ([Var], -- Lambda bound args
                 [Var]) -- Args at call site
202 203
mkWorkerArgs dflags args all_one_shot res_ty
    | any isId args || not needsAValueLambda
204
    = (args, args)
205
    | otherwise
206
    = (args ++ [newArg], args ++ [voidPrimId])
207
    where
208 209 210 211 212
      needsAValueLambda =
        isUnLiftedType res_ty
        || not (gopt Opt_FunToThunk dflags)
           -- see Note [Protecting the last value argument]

213
      -- see Note [All One-Shot Arguments of a Worker]
214
      newArg = setIdOneShotInfo voidArgId all_one_shot
215 216
\end{code}

217 218 219 220 221 222 223
Note [Protecting the last value argument]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If the user writes (\_ -> E), they might be intentionally disallowing
the sharing of E. Since absence analysis and worker-wrapper are keen
to remove such unused arguments, we add in a void argument to prevent
the function from becoming a thunk.

224 225 226 227 228
The user can avoid adding the void argument with the -ffun-to-thunk
flag. However, this can create sharing, which may be bad in two ways. 1) It can
create a space leak. 2) It can prevent inlining *under a lambda*. If w/w
removes the last argument from a function f, then f now looks like a thunk, and
so f can't be inlined *under a lambda*.
229

230 231
Note [All One-Shot Arguments of a Worker]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
232
Sometimes, derived join-points are just lambda-lifted thunks, whose
233 234 235 236 237
only argument is of the unit type and is never used. This might
interfere with the absence analysis, basing on which results these
never-used arguments are eliminated in the worker. The additional
argument `all_one_shot` of `mkWorkerArgs` is to prevent this.

238 239 240 241 242 243 244 245 246 247 248 249 250 251
Example.  Suppose we have
   foo = \p(one-shot) q(one-shot). y + 3
Then we drop the unused args to give
   foo   = \pq. $wfoo void#
   $wfoo = \void(one-shot). y + 3

But suppse foo didn't have all one-shot args:
   foo = \p(not-one-shot) q(one-shot). expensive y + 3
Then we drop the unused args to give
   foo   = \pq. $wfoo void#
   $wfoo = \void(not-one-shot). y + 3

If we made the void-arg one-shot we might inline an expensive
computation for y, which would be terrible!
252

253 254

%************************************************************************
255
%*                                                                      *
256
\subsection{Coercion stuff}
257
%*                                                                      *
258 259
%************************************************************************

260 261 262
We really want to "look through" coerces.
Reason: I've seen this situation:

263 264 265 266 267
        let f = coerce T (\s -> E)
        in \x -> case x of
                    p -> coerce T' f
                    q -> \s -> E2
                    r -> coerce T' f
268 269

If only we w/w'd f, we'd get
270 271 272
        let f = coerce T (\s -> fw s)
            fw = \s -> E
        in ...
273 274 275

Now we'll inline f to get

276 277 278 279 280
        let fw = \s -> E
        in \x -> case x of
                    p -> fw
                    q -> \s -> E2
                    r -> fw
281 282 283

Now we'll see that fw has arity 1, and will arity expand
the \x to get what we want.
284 285

\begin{code}
286 287
-- mkWWargs just does eta expansion
-- is driven off the function type and arity.
288 289
-- It chomps bites off foralls, arrows, newtypes
-- and keeps repeating that until it's satisfied the supplied arity
290

291 292 293
mkWWargs :: TvSubst             -- Freshening substitution to apply to the type
                                --   See Note [Freshen type variables]
         -> Type                -- The type of the function
294 295
         -> [(Demand,OneShotInfo)]     -- Demands and one-shot info for value arguments
         -> UniqSM  ([Var],            -- Wrapper args
296 297 298
                     CoreExpr -> CoreExpr,      -- Wrapper fn
                     CoreExpr -> CoreExpr,      -- Worker fn
                     Type)                      -- Type of wrapper body
299

300 301 302 303 304 305
mkWWargs subst fun_ty arg_info
  | null arg_info
  = return ([], id, id, substTy subst fun_ty)

  | ((dmd,one_shot):arg_info') <- arg_info
  , Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty
306 307 308 309 310 311 312 313 314
  = do  { uniq <- getUniqueM
        ; let arg_ty' = substTy subst arg_ty
              id = mk_wrap_arg uniq arg_ty' dmd one_shot
        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)
              <- mkWWargs subst fun_ty' arg_info'
        ; return (id : wrap_args,
                  Lam id . wrap_fn_args,
                  work_fn_args . (`App` varToCoreExpr id),
                  res_ty) }
315

316
  | Just (tv, fun_ty') <- splitForAllTy_maybe fun_ty
317 318 319 320 321 322 323 324 325
  = do  { let (subst', tv') = substTyVarBndr subst tv
                -- This substTyVarBndr clones the type variable when necy
                -- See Note [Freshen type variables]
        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)
             <- mkWWargs subst' fun_ty' arg_info
        ; return (tv' : wrap_args,
                  Lam tv' . wrap_fn_args,
                  work_fn_args . (`App` Type (mkTyVarTy tv')),
                  res_ty) }
326 327

  | Just (co, rep_ty) <- topNormaliseNewType_maybe fun_ty
328 329 330 331 332 333 334
        -- The newtype case is for when the function has
        -- a newtype after the arrow (rare)
        --
        -- It's also important when we have a function returning (say) a pair
        -- wrapped in a  newtype, at least if CPR analysis can look
        -- through such newtypes, which it probably can since they are
        -- simply coerces.
335 336

  = do { (wrap_args, wrap_fn_args, work_fn_args, res_ty)
337 338 339 340 341
            <-  mkWWargs subst rep_ty arg_info
        ; return (wrap_args,
                  \e -> Cast (wrap_fn_args e) (mkSymCo co),
                  \e -> work_fn_args (Cast e co),
                  res_ty) }
342

343
  | otherwise
344 345
  = WARN( True, ppr fun_ty )                    -- Should not happen: if there is a demand
    return ([], id, id, substTy subst fun_ty)   -- then there should be a function arrow
346 347

applyToVars :: [Var] -> CoreExpr -> CoreExpr
348 349
applyToVars vars fn = mkVarApps fn vars

350
mk_wrap_arg :: Unique -> Type -> Demand -> OneShotInfo -> Id
351
mk_wrap_arg uniq ty dmd one_shot
352 353 354
  = mkSysLocal (fsLit "w") uniq ty
       `setIdDemandInfo` dmd
       `setIdOneShotInfo` one_shot
355
\end{code}
356

357 358
Note [Freshen type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
359
Wen we do a worker/wrapper split, we must not use shadowed names,
360
else we'll get
361 362 363 364
   f = /\ a /\a. fw a a
which is obviously wrong.  Type variables can can in principle shadow,
within a type (e.g. forall a. a -> forall a. a->a).  But type
variables *are* mentioned in <blah>, so we must substitute.
365 366

That's why we carry the TvSubst through mkWWargs
367

368
%************************************************************************
369
%*                                                                      *
370
\subsection{Strictness stuff}
371
%*                                                                      *
372 373 374
%************************************************************************

\begin{code}
375
mkWWstr :: DynFlags
376
        -> FamInstEnvs
377 378
        -> [Var]                                -- Wrapper args; have their demand info on them
                                                --  *Includes type variables*
379 380
        -> UniqSM (Bool,                        -- Is this useful
                   [Var],                       -- Worker args
381 382 383 384 385 386 387
                   CoreExpr -> CoreExpr,        -- Wrapper body, lacking the worker call
                                                -- and without its lambdas
                                                -- This fn adds the unboxing

                   CoreExpr -> CoreExpr)        -- Worker body, lacking the original body of the function,
                                                -- and lacking its lambdas.
                                                -- This fn does the reboxing
388
mkWWstr _ _ []
389
  = return (False, [], nop_fn, nop_fn)
390

391 392 393
mkWWstr dflags fam_envs (arg : args) = do
    (useful1, args1, wrap_fn1, work_fn1) <- mkWWstr_one dflags fam_envs arg
    (useful2, args2, wrap_fn2, work_fn2) <- mkWWstr dflags fam_envs args
394
    return (useful1 || useful2, args1 ++ args2, wrap_fn1 . wrap_fn2, work_fn1 . work_fn2)
395

396 397 398 399 400
\end{code}

Note [Unpacking arguments with product and polymorphic demands]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The argument is unpacked in a case if it has a product type and has a
Simon Peyton Jones's avatar
Simon Peyton Jones committed
401
strict *and* used demand put on it. I.e., arguments, with demands such
402 403
as the following ones:

Simon Peyton Jones's avatar
Simon Peyton Jones committed
404 405
   <S,U(U, L)>
   <S(L,S),U>
406

Simon Peyton Jones's avatar
Simon Peyton Jones committed
407
will be unpacked, but
408

Simon Peyton Jones's avatar
Simon Peyton Jones committed
409 410 411 412 413
   <S,U> or <B,U>

will not, because the pieces aren't used. This is quite important otherwise
we end up unpacking massive tuples passed to the bottoming function. Example:

414 415
        f :: ((Int,Int) -> String) -> (Int,Int) -> a
        f g pr = error (g pr)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
416

417
        main = print (f fst (1, error "no"))
Simon Peyton Jones's avatar
Simon Peyton Jones committed
418 419 420 421 422

Does 'main' print "error 1" or "error no"?  We don't really want 'f'
to unbox its second argument.  This actually happened in GHC's onwn
source code, in Packages.applyPackageFlag, which ended up un-boxing
the enormous DynFlags tuple, and being strict in the
Simon Peyton Jones's avatar
Simon Peyton Jones committed
423
as-yet-un-filled-in pkgState files.
424 425

\begin{code}
426
----------------------
427
-- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn)
428
--   *  wrap_fn assumes wrap_arg is in scope,
429
--        brings into scope work_args (via cases)
430
--   * work_fn assumes work_args are in scope, a
431
--        brings into scope wrap_arg (via lets)
432 433 434
mkWWstr_one :: DynFlags -> FamInstEnvs -> Var
    -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr_one dflags fam_envs arg
435
  | isTyVar arg
436
  = return (False, [arg],  nop_fn, nop_fn)
437

438
  -- See Note [Worker-wrapper for bottoming functions]
439 440 441 442 443
  | isAbsDmd dmd
  , Just work_fn <- mk_absent_let dflags arg
     -- Absent case.  We can't always handle absence for arbitrary
     -- unlifted types, so we need to choose just the cases we can
     --- (that's what mk_absent_let does)
444
  = return (True, [], nop_fn, work_fn)
445

446
  -- See Note [Worthy functions for Worker-Wrapper split]
447 448 449
  | isSeqDmd dmd  -- `seq` demand; evaluate in wrapper in the hope
                  -- of dropping seqs in the worker
  = let arg_w_unf = arg `setIdUnfolding` evaldUnfolding
450
          -- Tell the worker arg that it's sure to be evaluated
451
          -- so that internal seqs can be dropped
452
    in return (True, [arg_w_unf], mk_seq_case arg, nop_fn)
453 454 455 456 457 458 459 460 461 462 463 464
                -- Pass the arg, anyway, even if it is in theory discarded
                -- Consider
                --      f x y = x `seq` y
                -- x gets a (Eval (Poly Abs)) demand, but if we fail to pass it to the worker
                -- we ABSOLUTELY MUST record that x is evaluated in the wrapper.
                -- Something like:
                --      f x y = x `seq` fw y
                --      fw y = let x{Evald} = error "oops" in (x `seq` y)
                -- If we don't pin on the "Evald" flag, the seq doesn't disappear, and
                -- we end up evaluating the absent thunk.
                -- But the Evald flag is pretty weird, and I worry that it might disappear
                -- during simplification, so for now I've just nuked this whole case
465 466

  | isStrictDmd dmd
467
  , Just cs <- splitProdDmd_maybe dmd
Simon Peyton Jones's avatar
Simon Peyton Jones committed
468
      -- See Note [Unpacking arguments with product and polymorphic demands]
469
  , Just (data_con, inst_tys, inst_con_arg_tys, co)
470
             <- deepSplitProductType_maybe fam_envs (idType arg)
471
  , cs `equalLength` inst_con_arg_tys
Krzysztof Gogolewski's avatar
Krzysztof Gogolewski committed
472
      -- See Note [mkWWstr and unsafeCoerce]
473
  =  do { (uniq1:uniqs) <- getUniquesM
474 475 476
        ; let   unpk_args      = zipWith mk_ww_local uniqs inst_con_arg_tys
                unpk_args_w_ds = zipWithEqual "mkWWstr" set_worker_arg_info unpk_args cs
                unbox_fn       = mkUnpackCase (Var arg) co uniq1
477
                                              data_con unpk_args
478 479
                rebox_fn       = Let (NonRec arg con_app)
                con_app        = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co
480
         ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs unpk_args_w_ds
481
         ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }
482 483 484
                           -- Don't pass the arg, rebox instead

  | otherwise   -- Other cases
485
  = return (False, [arg], nop_fn, nop_fn)
486

487
  where
488
    dmd = idDemandInfo arg
489
    one_shot = idOneShotInfo arg
490 491 492
        -- If the wrapper argument is a one-shot lambda, then
        -- so should (all) the corresponding worker arguments be
        -- This bites when we do w/w on a case join point
493 494 495
    set_worker_arg_info worker_arg demand 
      = worker_arg `setIdDemandInfo`  demand
                   `setIdOneShotInfo` one_shot
496 497 498 499

----------------------
nop_fn :: CoreExpr -> CoreExpr
nop_fn body = body
500
\end{code}
501

502 503
Note [mkWWstr and unsafeCoerce]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Gabor Greif's avatar
Gabor Greif committed
504
By using unsafeCoerce, it is possible to make the number of demands fail to
505 506 507 508
match the number of constructor arguments; this happened in Trac #8037.
If so, the worker/wrapper split doesn't work right and we get a Core Lint
bug.  The fix here is simply to decline to do w/w if that happens.

509
\begin{code}
510
deepSplitProductType_maybe :: FamInstEnvs -> Type -> Maybe (DataCon, [Type], [Type], Coercion)
511
-- If    deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co)
512 513
-- then  dc @ tys (args::arg_tys) :: rep_ty
--       co :: ty ~ rep_ty
514 515 516
deepSplitProductType_maybe fam_envs ty
  | let (co, ty1) = topNormaliseType_maybe fam_envs ty
                    `orElse` (mkReflCo Representational ty, ty)
517 518 519
  , Just (tc, tc_args) <- splitTyConApp_maybe ty1
  , Just con <- isDataProductTyCon_maybe tc
  = Just (con, tc_args, dataConInstArgTys con tc_args, co)
520
deepSplitProductType_maybe _ _ = Nothing
521

522
deepSplitCprType_maybe :: FamInstEnvs -> ConTag -> Type -> Maybe (DataCon, [Type], [Type], Coercion)
523 524 525
-- If    deepSplitCprType_maybe n ty = Just (dc, tys, arg_tys, co)
-- then  dc @ tys (args::arg_tys) :: rep_ty
--       co :: ty ~ rep_ty
526 527 528
deepSplitCprType_maybe fam_envs con_tag ty
  | let (co, ty1) = topNormaliseType_maybe fam_envs ty
                    `orElse` (mkReflCo Representational ty, ty)
529 530 531 532 533
  , Just (tc, tc_args) <- splitTyConApp_maybe ty1
  , isDataTyCon tc
  , let cons = tyConDataCons tc
        con = ASSERT( cons `lengthAtLeast` con_tag ) cons !! (con_tag - fIRST_TAG)
  = Just (con, tc_args, dataConInstArgTys con tc_args, co)
534
deepSplitCprType_maybe _ _ _ = Nothing
535
\end{code}
536

537 538

%************************************************************************
539
%*                                                                      *
540
\subsection{CPR stuff}
541
%*                                                                      *
542 543 544
%************************************************************************


545 546 547 548 549 550 551 552 553 554
@mkWWcpr@ takes the worker/wrapper pair produced from the strictness
info and adds in the CPR transformation.  The worker returns an
unboxed tuple containing non-CPR components.  The wrapper takes this
tuple and re-produces the correct structured output.

The non-CPR results appear ordered in the unboxed tuple as if by a
left-to-right traversal of the result structure.


\begin{code}
555 556
mkWWcpr :: FamInstEnvs
        -> Type                              -- function body type
557
        -> DmdResult                         -- CPR analysis results
558 559 560 561
        -> UniqSM (Bool,                     -- Is w/w'ing useful?
                   CoreExpr -> CoreExpr,     -- New wrapper
                   CoreExpr -> CoreExpr,     -- New worker
                   Type)                     -- Type of worker's body
562

563
mkWWcpr fam_envs body_ty res
564
  = case returnsCPR_maybe res of
565
       Nothing      -> return (False, id, id, body_ty)  -- No CPR info
566
       Just con_tag | Just stuff <- deepSplitCprType_maybe fam_envs con_tag body_ty
567 568
                    -> mkWWcpr_help stuff
                    |  otherwise
569
                       -- See Note [non-algebraic or open body type warning]
570
                    -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )
571
                       return (False, id, id, body_ty)
572

573
mkWWcpr_help :: (DataCon, [Type], [Type], Coercion)
574
             -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
575 576 577 578

mkWWcpr_help (data_con, inst_tys, arg_tys, co)
  | [arg_ty1] <- arg_tys
  , isUnLiftedType arg_ty1
579 580 581 582
        -- Special case when there is a single result of unlifted type
        --
        -- Wrapper:     case (..call worker..) of x -> C x
        -- Worker:      case (   ..body..    ) of C x -> x
583 584
  = do { (work_uniq : arg_uniq : _) <- getUniquesM
       ; let arg       = mk_ww_local arg_uniq  arg_ty1
585
             con_app   = mkConApp2 data_con inst_tys [arg] `mkCast` mkSymCo co
586

587 588
       ; return ( True
                , \ wkr_call -> Case wkr_call arg (exprType con_app) [(DEFAULT, [], con_app)]
589
                , \ body     -> mkUnpackCase body co work_uniq data_con [arg] (Var arg)
590
                , arg_ty1 ) }
591

592 593 594
  | otherwise   -- The general case
        -- Wrapper: case (..call worker..) of (# a, b #) -> C a b
        -- Worker:  case (   ...body...  ) of C a b -> (# a, b #)
595 596
  = do { (work_uniq : uniqs) <- getUniquesM
       ; let (wrap_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : arg_tys)
597 598 599 600
             ubx_tup_con  = tupleCon UnboxedTuple (length arg_tys)
             ubx_tup_ty   = exprType ubx_tup_app
             ubx_tup_app  = mkConApp2 ubx_tup_con arg_tys args
             con_app      = mkConApp2 data_con inst_tys args `mkCast` mkSymCo co
601

602 603
       ; return (True
                , \ wkr_call -> Case wkr_call wrap_wild (exprType con_app)  [(DataAlt ubx_tup_con, args, con_app)]
604 605
                , \ body     -> mkUnpackCase body co work_uniq data_con args ubx_tup_app
                , ubx_tup_ty ) }
606

607 608
mkUnpackCase ::  CoreExpr -> Coercion -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr
-- (mkUnpackCase e co uniq Con args body)
609
--      returns
610 611 612 613 614 615
-- case e |> co of bndr { Con args -> body }

mkUnpackCase (Tick tickish e) co uniq con args body   -- See Note [Profiling and unpacking]
  = Tick tickish (mkUnpackCase e co uniq con args body)
mkUnpackCase scrut co uniq boxing_con unpk_args body
  = Case casted_scrut bndr (exprType body)
616
         [(DataAlt boxing_con, unpk_args, body)]
617 618 619
  where
    casted_scrut = scrut `mkCast` co
    bndr = mk_ww_local uniq (exprType casted_scrut)
620
\end{code}
621

622 623 624 625 626 627 628 629 630 631 632 633 634
Note [non-algebraic or open body type warning]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

There are a few cases where the W/W transformation is told that something
returns a constructor, but the type at hand doesn't really match this. One
real-world example involves unsafeCoerce:
  foo = IO a
  foo = unsafeCoere c_exit
  foreign import ccall "c_exit" c_exit :: IO ()
Here CPR will tell you that `foo` returns a () constructor for sure, but trying
to create a worker/wrapper for type `a` obviously fails.
(This was a real example until ee8e792  in libraries/base.)

Krzysztof Gogolewski's avatar
Krzysztof Gogolewski committed
635
It does not seem feasible to avoid all such cases already in the analyser (and
636 637 638 639 640
after all, the analysis is not really wrong), so we simply do nothing here in
mkWWcpr. But we still want to emit warning with -DDEBUG, to hopefully catch
other cases where something went avoidably wrong.


641 642 643
Note [Profiling and unpacking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If the original function looked like
644
        f = \ x -> {-# SCC "foo" #-} E
645 646

then we want the CPR'd worker to look like
647
        \ x -> {-# SCC "foo" #-} (case E of I# x -> x)
648
and definitely not
649
        \ x -> case ({-# SCC "foo" #-} E) of I# x -> x)
650 651 652 653 654 655 656 657 658

This transform doesn't move work or allocation
from one cost centre to another.

Later [SDM]: presumably this is because we want the simplifier to
eliminate the case, and the scc would get in the way?  I'm ok with
including the case itself in the cost centre, since it is morally
part of the function (post transformation) anyway.

659

660
%************************************************************************
661
%*                                                                      *
662
\subsection{Utilities}
663
%*                                                                      *
664 665
%************************************************************************

666 667
Note [Absent errors]
~~~~~~~~~~~~~~~~~~~~
668 669
We make a new binding for Ids that are marked absent, thus
   let x = absentError "x :: Int"
670
The idea is that this binding will never be used; but if it
671 672
buggily is used we'll get a runtime error message.

673 674 675 676 677 678 679
Coping with absence for *unlifted* types is important; see, for
example, Trac #4306.  For these we find a suitable literal,
using Literal.absentLiteralOf.  We don't have literals for
every primitive type, so the function is partial.

    [I did try the experiment of using an error thunk for unlifted
    things too, relying on the simplifier to drop it as dead code,
680 681
    by making absentError
      (a) *not* be a bottoming Id,
682 683
      (b) be "ok for speculation"
    But that relies on the simplifier finding that it really
684
    is dead code, which is fragile, and indeed failed when
685 686
    profiling is on, which disables various optimisations.  So
    using a literal will do.]
687

688
\begin{code}
689 690
mk_absent_let :: DynFlags -> Id -> Maybe (CoreExpr -> CoreExpr)
mk_absent_let dflags arg
691 692
  | not (isUnLiftedType arg_ty)
  = Just (Let (NonRec arg abs_rhs))
693
  | Just tc <- tyConAppTyCon_maybe arg_ty
694 695
  , Just lit <- absentLiteralOf tc
  = Just (Let (NonRec arg (Lit lit)))
696 697
  | arg_ty `eqType` voidPrimTy
  = Just (Let (NonRec arg (Var voidPrimId)))
698
  | otherwise
699
  = WARN( True, ptext (sLit "No absent value for") <+> ppr arg_ty )
700
    Nothing
701
  where
702 703
    arg_ty  = idType arg
    abs_rhs = mkRuntimeErrorApp aBSENT_ERROR_ID arg_ty msg
704
    msg     = showSDocDebug dflags (ppr arg <+> ppr (idType arg))
705

706
mk_seq_case :: Id -> CoreExpr -> CoreExpr
707
mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) (exprType body) [(DEFAULT, [], body)]
708

709 710 711 712 713
sanitiseCaseBndr :: Id -> Id
-- The argument we are scrutinising has the right type to be
-- a case binder, so it's convenient to re-use it for that purpose.
-- But we *must* throw away all its IdInfo.  In particular, the argument
-- will have demand info on it, and that demand info may be incorrect for
714
-- the case binder.  e.g.       case ww_arg of ww_arg { I# x -> ... }
715
-- Quite likely ww_arg isn't used in '...'.  The case may get discarded
716 717
-- if the case binder says "I'm demanded".  This happened in a situation
-- like         (x+y) `seq` ....
718
sanitiseCaseBndr id = id `setIdInfo` vanillaIdInfo
719

720
mk_ww_local :: Unique -> Type -> Id
Ian Lynagh's avatar
Ian Lynagh committed
721
mk_ww_local uniq ty = mkSysLocal (fsLit "ww") uniq ty
722
\end{code}