WwLib.hs 32.3 KB
Newer Older
1 2 3
{-
(c) The GRASP/AQUA Project, Glasgow University, 1993-1998

Ian Lynagh's avatar
Ian Lynagh committed
4
\section[WwLib]{A library for the ``worker\/wrapper'' back-end to the strictness analyser}
5
-}
6

7 8
{-# LANGUAGE CPP #-}

9 10
module WwLib ( mkWwBodies, mkWWstr, mkWorkerArgs
             , deepSplitProductType_maybe, findTypeShape
11
             , isWorkerSmallEnough
12
 ) where
13

14
#include "HsVersions.h"
15

16
import CoreSyn
17
import CoreUtils        ( exprType, mkCast )
18
import Id
19
import IdInfo           ( vanillaIdInfo )
20
import DataCon
21
import Demand
22
import MkCore           ( mkRuntimeErrorApp, aBSENT_ERROR_ID, mkCoreUbxTup )
23 24
import MkId             ( voidArgId, voidPrimId )
import TysPrim          ( voidPrimTy )
25
import TysWiredIn       ( tupleDataCon )
26
import VarEnv           ( mkInScopeSet )
27
import VarSet           ( VarSet )
28
import Type
29
import RepType          ( isVoidTy )
30
import Coercion
31
import FamInstEnv
32
import BasicTypes       ( Boxity(..) )
33
import Literal          ( absentLiteralOf )
34
import TyCon
35
import UniqSupply
36
import Unique
37
import Maybes
38
import Util
sof's avatar
sof committed
39
import Outputable
40
import DynFlags
41
import FastString
42
import ListSetOps
43

44 45 46
{-
************************************************************************
*                                                                      *
47
\subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}
48 49
*                                                                      *
************************************************************************
50 51

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

53 54 55
\begin{verbatim}
g :: forall a . Int -> [a] -> a

Ian Lynagh's avatar
Ian Lynagh committed
56
g = \/\ a -> \ x ys ->
57 58 59
        case x of
          0 -> head ys
          _ -> head (tail ys)
60 61 62 63 64 65 66
\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
67
g = \/\ a -> \ x ys ->
68 69 70
        case x of
          I# x# -> $wg a x# ys
            -- call the worker; don't forget the type args!
71 72

-- worker
73
$wg :: forall a . Int# -> [a] -> a
74

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

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

86 87 88 89
\begin{verbatim}
-- "f" strictness: U(P)U(P)
f (I# a) (I# b) = a +# b

90
g = f   -- "g" strictness same as "f"
91
\end{verbatim}
92

93 94 95 96 97 98 99 100 101 102 103
\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.


104 105
************************************************************************
*                                                                      *
106
\subsection{The worker wrapper core}
107 108
*                                                                      *
************************************************************************
109

Ian Lynagh's avatar
Ian Lynagh committed
110
@mkWwBodies@ is called when doing the worker\/wrapper split inside a module.
111
-}
112

113 114 115 116 117
type WwResult
  = ([Demand],              -- Demands for worker (value) args
     Id -> CoreExpr,        -- Wrapper body, lacking only the worker Id
     CoreExpr -> CoreExpr)  -- Worker body, lacking the original function rhs

118
mkWwBodies :: DynFlags
119
           -> FamInstEnvs
120 121 122 123 124 125
           -> VarSet         -- Free vars of RHS
                             -- See Note [Freshen WW arguments]
           -> Type           -- Type of original function
           -> [Demand]       -- Strictness of original function
           -> DmdResult      -- Info about function result
           -> UniqSM (Maybe WwResult)
126 127 128 129 130 131 132 133 134 135 136

-- 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
137

138 139 140
mkWwBodies dflags fam_envs rhs_fvs fun_ty demands res_info
  = do  { let empty_subst = mkEmptyTCvSubst (mkInScopeSet rhs_fvs)
                -- See Note [Freshen WW arguments]
141 142

        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) <- mkWWargs empty_subst fun_ty demands
143
        ; (useful1, work_args, wrap_fn_str, work_fn_str) <- mkWWstr dflags fam_envs wrap_args
144

145
        -- Do CPR w/w.  See Note [Always do CPR w/w]
146 147
        ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty)
              <- mkWWcpr (gopt Opt_CprAnal dflags) fam_envs res_ty res_info
148

149
        ; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args cpr_res_ty
150 151 152 153
              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

154 155
        ; if isWorkerSmallEnough dflags work_args
             && (useful1 && not only_one_void_argument || useful2)
156 157 158
          then return (Just (worker_args_dmds, wrapper_body, worker_body))
          else return Nothing
        }
159 160 161 162 163 164 165
        -- 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
166 167 168 169 170 171 172 173 174
  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
175 176 177 178 179 180

-- See Note [Limit w/w arity]
isWorkerSmallEnough :: DynFlags -> [Var] -> Bool
isWorkerSmallEnough dflags vars = count isId vars <= maxWorkerArgs dflags
    -- We count only Free variables (isId) to skip Type, Kind
    -- variables which have no runtime representation.
181

182
{-
183 184 185 186 187
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
188
Note [CPR for thunks] in DmdAnal.
189 190 191 192 193 194

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.

195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218
Note [Limit w/w arity]
~~~~~~~~~~~~~~~~~~~~~~~~
Guard against high worker arity as it generates a lot of stack traffic.
A simplified example is Trac #11565#comment:6

Current strategy is very simple: don't perform w/w transformation at all
if the result produces a wrapper with arity higher than -fmax-worker-args=.

It is a bit all or nothing, consider

        f (x,y) (a,b,c,d,e ... , z) = rhs

Currently we will remove all w/w ness entirely. But actually we could
w/w on the (x,y) pair... it's the huge product that is the problem.

Could we instead refrain from w/w on an arg-by-arg basis? Yes, that'd
solve f. But we can get a lot of args from deeply-nested products:

        g (a, (b, (c, (d, ...)))) = rhs

This is harder to spot on an arg-by-arg basis. Previously mkWwStr was
given some "fuel" saying how many arguments it could add; when we ran
out of fuel it would stop w/wing.
Still not very clever because it had a left-right bias.
219

220 221
************************************************************************
*                                                                      *
222
\subsection{Making wrapper args}
223 224
*                                                                      *
************************************************************************
225 226 227 228 229

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.

230
        f = /\a -> \x y z -> E::Int#    -- E does not mention x,y,z
231
==>
232 233
        fw = /\ a -> \void -> E
        f  = /\ a -> \x y z -> fw realworld
234 235

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

238
mkWorkerArgs :: DynFlags -> [Var]
239 240 241
             -> Type    -- Type of body
             -> ([Var], -- Lambda bound args
                 [Var]) -- Args at call site
242
mkWorkerArgs dflags args res_ty
243
    | any isId args || not needsAValueLambda
244
    = (args, args)
245
    | otherwise
246
    = (args ++ [voidArgId], args ++ [voidPrimId])
247
    where
248
      needsAValueLambda =
249
        isUnliftedType res_ty
250 251 252
        || not (gopt Opt_FunToThunk dflags)
           -- see Note [Protecting the last value argument]

253
{-
254 255 256 257 258 259 260
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.

261 262 263 264 265
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*.
266

267

268 269
************************************************************************
*                                                                      *
270
\subsection{Coercion stuff}
271 272
*                                                                      *
************************************************************************
273

274 275 276
We really want to "look through" coerces.
Reason: I've seen this situation:

277 278 279 280 281
        let f = coerce T (\s -> E)
        in \x -> case x of
                    p -> coerce T' f
                    q -> \s -> E2
                    r -> coerce T' f
282 283

If only we w/w'd f, we'd get
284 285 286
        let f = coerce T (\s -> fw s)
            fw = \s -> E
        in ...
287 288 289

Now we'll inline f to get

290 291 292 293 294
        let fw = \s -> E
        in \x -> case x of
                    p -> fw
                    q -> \s -> E2
                    r -> fw
295 296 297

Now we'll see that fw has arity 1, and will arity expand
the \x to get what we want.
298
-}
299

300 301
-- mkWWargs just does eta expansion
-- is driven off the function type and arity.
302 303
-- It chomps bites off foralls, arrows, newtypes
-- and keeps repeating that until it's satisfied the supplied arity
304

305
mkWWargs :: TCvSubst            -- Freshening substitution to apply to the type
306
                                --   See Note [Freshen WW arguments]
307
         -> Type                -- The type of the function
308
         -> [Demand]     -- Demands and one-shot info for value arguments
309
         -> UniqSM  ([Var],            -- Wrapper args
310 311 312
                     CoreExpr -> CoreExpr,      -- Wrapper fn
                     CoreExpr -> CoreExpr,      -- Worker fn
                     Type)                      -- Type of wrapper body
313

314 315
mkWWargs subst fun_ty demands
  | null demands
316 317
  = return ([], id, id, substTy subst fun_ty)

318
  | (dmd:demands') <- demands
319
  , Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty
320 321
  = do  { uniq <- getUniqueM
        ; let arg_ty' = substTy subst arg_ty
322
              id = mk_wrap_arg uniq arg_ty' dmd
323
        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)
324
              <- mkWWargs subst fun_ty' demands'
325 326 327 328
        ; return (id : wrap_args,
                  Lam id . wrap_fn_args,
                  work_fn_args . (`App` varToCoreExpr id),
                  res_ty) }
329

330
  | Just (tv, fun_ty') <- splitForAllTy_maybe fun_ty
331 332 333
  = do  { uniq <- getUniqueM
        ; let (subst', tv') = cloneTyVarBndr subst tv uniq
                -- See Note [Freshen WW arguments]
334
        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)
335
             <- mkWWargs subst' fun_ty' demands
336 337
        ; return (tv' : wrap_args,
                  Lam tv' . wrap_fn_args,
338
                  work_fn_args . (`mkTyApps` [mkTyVarTy tv']),
339
                  res_ty) }
340 341

  | Just (co, rep_ty) <- topNormaliseNewType_maybe fun_ty
342 343 344 345 346 347 348
        -- 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.
349 350

  = do { (wrap_args, wrap_fn_args, work_fn_args, res_ty)
351
            <-  mkWWargs subst rep_ty demands
352 353 354 355
       ; let co' = substCo subst co
       ; return (wrap_args,
                  \e -> Cast (wrap_fn_args e) (mkSymCo co'),
                  \e -> work_fn_args (Cast e co'),
356
                  res_ty) }
357

358
  | otherwise
359 360
  = 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
361 362

applyToVars :: [Var] -> CoreExpr -> CoreExpr
363 364
applyToVars vars fn = mkVarApps fn vars

365 366
mk_wrap_arg :: Unique -> Type -> Demand -> Id
mk_wrap_arg uniq ty dmd
367
  = mkSysLocalOrCoVar (fsLit "w") uniq ty
368
       `setIdDemandInfo` dmd
369

370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398
{- Note [Freshen WW arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Wen we do a worker/wrapper split, we must not in-scope names as the arguments
of the worker, else we'll get name capture.  E.g.

   -- y1 is in scope from further out
   f x = ..y1..

If we accidentally choose y1 as a worker argument disaster results:

   fww y1 y2 = let x = (y1,y2) in ...y1...

To avoid this:

  * We use a fresh unique for both type-variable and term-variable binders
    Originally we lacked this freshness for type variables, and that led
    to the very obscure Trac #12562.  (A type varaible in the worker shadowed
    an outer term-variable binding.)

  * Because of this cloning we have to substitute in the type/kind of the
    new binders.  That's why we carry the TCvSubst through mkWWargs.

    So we need a decent in-scope set, just in case that type/kind
    itself has foralls.  We get this from the free vars of the RHS of the
    function since those are the only variables that might be captured.
    It's a lazy thunk, which will only be poked if the type/kind has a forall.

    Another tricky case was when f :: forall a. a -> forall a. a->a
    (i.e. with shadowing), and then the worker used the same 'a' twice.
399

400 401
************************************************************************
*                                                                      *
402
\subsection{Strictness stuff}
403 404 405
*                                                                      *
************************************************************************
-}
406

407
mkWWstr :: DynFlags
408
        -> FamInstEnvs
409 410
        -> [Var]                                -- Wrapper args; have their demand info on them
                                                --  *Includes type variables*
411 412
        -> UniqSM (Bool,                        -- Is this useful
                   [Var],                       -- Worker args
413 414 415 416 417 418 419
                   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
420
mkWWstr _ _ []
421
  = return (False, [], nop_fn, nop_fn)
422

423 424 425
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
426
    return (useful1 || useful2, args1 ++ args2, wrap_fn1 . wrap_fn2, work_fn1 . work_fn2)
427

428
{-
429 430 431
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
432
strict *and* used demand put on it. I.e., arguments, with demands such
433 434
as the following ones:

Simon Peyton Jones's avatar
Simon Peyton Jones committed
435 436
   <S,U(U, L)>
   <S(L,S),U>
437

Simon Peyton Jones's avatar
Simon Peyton Jones committed
438
will be unpacked, but
439

Simon Peyton Jones's avatar
Simon Peyton Jones committed
440 441 442 443 444
   <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:

445 446
        f :: ((Int,Int) -> String) -> (Int,Int) -> a
        f g pr = error (g pr)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
447

448
        main = print (f fst (1, error "no"))
Simon Peyton Jones's avatar
Simon Peyton Jones committed
449 450 451 452 453

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
454
as-yet-un-filled-in pkgState files.
455
-}
456

457
----------------------
458
-- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn)
459
--   *  wrap_fn assumes wrap_arg is in scope,
460
--        brings into scope work_args (via cases)
461
--   * work_fn assumes work_args are in scope, a
462
--        brings into scope wrap_arg (via lets)
463 464 465
mkWWstr_one :: DynFlags -> FamInstEnvs -> Var
    -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr_one dflags fam_envs arg
466
  | isTyVar arg
467
  = return (False, [arg],  nop_fn, nop_fn)
468

469
  -- See Note [Worker-wrapper for bottoming functions]
470 471 472 473 474
  | 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)
475
  = return (True, [], nop_fn, work_fn)
476

477
  -- See Note [Worthy functions for Worker-Wrapper split]
478 479 480
  | isSeqDmd dmd  -- `seq` demand; evaluate in wrapper in the hope
                  -- of dropping seqs in the worker
  = let arg_w_unf = arg `setIdUnfolding` evaldUnfolding
481
          -- Tell the worker arg that it's sure to be evaluated
482
          -- so that internal seqs can be dropped
483
    in return (True, [arg_w_unf], mk_seq_case arg, nop_fn)
484 485 486 487 488 489 490 491 492 493 494 495
                -- 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
496 497

  | isStrictDmd dmd
498
  , Just cs <- splitProdDmd_maybe dmd
Simon Peyton Jones's avatar
Simon Peyton Jones committed
499
      -- See Note [Unpacking arguments with product and polymorphic demands]
500
  , Just (data_con, inst_tys, inst_con_arg_tys, co)
501
             <- deepSplitProductType_maybe fam_envs (idType arg)
502
  , cs `equalLength` inst_con_arg_tys
Krzysztof Gogolewski's avatar
Krzysztof Gogolewski committed
503
      -- See Note [mkWWstr and unsafeCoerce]
504 505 506 507 508 509 510 511
  =  do { (uniq1:uniqs) <- getUniquesM
        ; let   unpk_args      = zipWith mk_ww_local uniqs inst_con_arg_tys
                unpk_args_w_ds = zipWithEqual "mkWWstr" setIdDemandInfo unpk_args cs
                unbox_fn       = mkUnpackCase (Var arg) co uniq1
                                              data_con unpk_args
                rebox_fn       = Let (NonRec arg con_app)
                con_app        = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co
         ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs unpk_args_w_ds
512
         ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }
513 514 515
                           -- Don't pass the arg, rebox instead

  | otherwise   -- Other cases
516
  = return (False, [arg], nop_fn, nop_fn)
517

518
  where
519
    dmd = idDemandInfo arg
520 521 522 523

----------------------
nop_fn :: CoreExpr -> CoreExpr
nop_fn body = body
524

525
{-
526 527
Note [mkWWstr and unsafeCoerce]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Gabor Greif's avatar
Gabor Greif committed
528
By using unsafeCoerce, it is possible to make the number of demands fail to
529 530 531 532
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.

533 534
************************************************************************
*                                                                      *
535
         Type scrutiny that is specific to demand analysis
536 537
*                                                                      *
************************************************************************
538

539 540 541 542 543
Note [Do not unpack class dictionaries]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we have
   f :: Ord a => [a] -> Int -> a
   {-# INLINABLE f #-}
544
and we worker/wrapper f, we'll get a worker with an INLINABLE pragma
545 546 547 548 549 550
(see Note [Worker-wrapper for INLINABLE functions] in WorkWrap), which
can still be specialised by the type-class specialiser, something like
   fw :: Ord a => [a] -> Int# -> a

BUT if f is strict in the Ord dictionary, we might unpack it, to get
   fw :: (a->a->Bool) -> [a] -> Int# -> a
Simon Peyton Jones's avatar
Simon Peyton Jones committed
551 552
and the type-class specialiser can't specialise that.  An example is
Trac #6056.
553

554
Moreover, dictionaries can have a lot of fields, so unpacking them can
555 556 557
increase closure sizes.

Conclusion: don't unpack dictionaries.
558
-}
559

560
deepSplitProductType_maybe :: FamInstEnvs -> Type -> Maybe (DataCon, [Type], [Type], Coercion)
561
-- If    deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co)
562 563
-- then  dc @ tys (args::arg_tys) :: rep_ty
--       co :: ty ~ rep_ty
564 565
deepSplitProductType_maybe fam_envs ty
  | let (co, ty1) = topNormaliseType_maybe fam_envs ty
566
                    `orElse` (mkRepReflCo ty, ty)
567 568
  , Just (tc, tc_args) <- splitTyConApp_maybe ty1
  , Just con <- isDataProductTyCon_maybe tc
569
  , not (isClassTyCon tc)  -- See Note [Do not unpack class dictionaries]
570
  = Just (con, tc_args, dataConInstArgTys con tc_args, co)
571
deepSplitProductType_maybe _ _ = Nothing
572

573
deepSplitCprType_maybe :: FamInstEnvs -> ConTag -> Type -> Maybe (DataCon, [Type], [Type], Coercion)
574 575 576
-- If    deepSplitCprType_maybe n ty = Just (dc, tys, arg_tys, co)
-- then  dc @ tys (args::arg_tys) :: rep_ty
--       co :: ty ~ rep_ty
577 578
deepSplitCprType_maybe fam_envs con_tag ty
  | let (co, ty1) = topNormaliseType_maybe fam_envs ty
579
                    `orElse` (mkRepReflCo ty, ty)
580 581 582
  , Just (tc, tc_args) <- splitTyConApp_maybe ty1
  , isDataTyCon tc
  , let cons = tyConDataCons tc
583 584
  , cons `lengthAtLeast` con_tag -- This might not be true if we import the
                                 -- type constructor via a .hs-bool file (#8743)
585 586
  , let con  = cons `getNth` (con_tag - fIRST_TAG)
  = Just (con, tc_args, dataConInstArgTys con tc_args, co)
587
deepSplitCprType_maybe _ _ _ = Nothing
588 589 590 591 592 593 594 595 596 597 598 599 600

findTypeShape :: FamInstEnvs -> Type -> TypeShape
-- Uncover the arrow and product shape of a type
-- The data type TypeShape is defined in Demand
-- See Note [Trimming a demand to a type] in Demand
findTypeShape fam_envs ty
  | Just (tc, tc_args)  <- splitTyConApp_maybe ty
  , Just con <- isDataProductTyCon_maybe tc
  = TsProd (map (findTypeShape fam_envs) $ dataConInstArgTys con tc_args)

  | Just (_, res) <- splitFunTy_maybe ty
  = TsFun (findTypeShape fam_envs res)

601 602 603
  | Just (_, ty') <- splitForAllTy_maybe ty
  = findTypeShape fam_envs ty'

604 605 606 607 608
  | Just (_, ty') <- topNormaliseType_maybe fam_envs ty
  = findTypeShape fam_envs ty'

  | otherwise
  = TsUnk
609

610 611 612
{-
************************************************************************
*                                                                      *
613
\subsection{CPR stuff}
614 615
*                                                                      *
************************************************************************
616 617


618 619 620 621 622 623 624
@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.
625
-}
626

627 628
mkWWcpr :: Bool
        -> FamInstEnvs
629
        -> Type                              -- function body type
630
        -> DmdResult                         -- CPR analysis results
631 632 633 634
        -> UniqSM (Bool,                     -- Is w/w'ing useful?
                   CoreExpr -> CoreExpr,     -- New wrapper
                   CoreExpr -> CoreExpr,     -- New worker
                   Type)                     -- Type of worker's body
635

636 637 638 639 640
mkWWcpr opt_CprAnal fam_envs body_ty res
    -- CPR explicitly turned off (or in -O0)
  | not opt_CprAnal = return (False, id, id, body_ty)
    -- CPR is turned on by default for -O and O2
  | otherwise
641
  = case returnsCPR_maybe res of
642
       Nothing      -> return (False, id, id, body_ty)  -- No CPR info
643
       Just con_tag | Just stuff <- deepSplitCprType_maybe fam_envs con_tag body_ty
644 645
                    -> mkWWcpr_help stuff
                    |  otherwise
646
                       -- See Note [non-algebraic or open body type warning]
647
                    -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )
648
                       return (False, id, id, body_ty)
649

650
mkWWcpr_help :: (DataCon, [Type], [Type], Coercion)
651
             -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
652 653

mkWWcpr_help (data_con, inst_tys, arg_tys, co)
654
  | [arg_ty1] <- arg_tys
655
  , isUnliftedType arg_ty1
656 657 658 659
        -- 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
660
  = do { (work_uniq : arg_uniq : _) <- getUniquesM
661
       ; let arg       = mk_ww_local arg_uniq  arg_ty1
662
             con_app   = mkConApp2 data_con inst_tys [arg] `mkCast` mkSymCo co
663

664 665
       ; return ( True
                , \ wkr_call -> Case wkr_call arg (exprType con_app) [(DEFAULT, [], con_app)]
666 667 668
                , \ body     -> mkUnpackCase body co work_uniq data_con [arg] (varToCoreExpr arg)
                                -- varToCoreExpr important here: arg can be a coercion
                                -- Lacking this caused Trac #10658
669
                , arg_ty1 ) }
670

671 672 673
  | otherwise   -- The general case
        -- Wrapper: case (..call worker..) of (# a, b #) -> C a b
        -- Worker:  case (   ...body...  ) of C a b -> (# a, b #)
674 675 676 677 678
  = do { (work_uniq : uniqs) <- getUniquesM
       ; let (wrap_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : arg_tys)
             ubx_tup_ty   = exprType ubx_tup_app
             ubx_tup_app  = mkCoreUbxTup arg_tys (map varToCoreExpr args)
             con_app      = mkConApp2 data_con inst_tys args `mkCast` mkSymCo co
679

680
       ; return (True
681
                , \ wkr_call -> Case wkr_call wrap_wild (exprType con_app)  [(DataAlt (tupleDataCon Unboxed (length arg_tys)), args, con_app)]
682 683
                , \ body     -> mkUnpackCase body co work_uniq data_con args ubx_tup_app
                , ubx_tup_ty ) }
684

685 686
mkUnpackCase ::  CoreExpr -> Coercion -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr
-- (mkUnpackCase e co uniq Con args body)
687
--      returns
688 689 690 691 692 693
-- 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)
694
         [(DataAlt boxing_con, unpk_args, body)]
695 696
  where
    casted_scrut = scrut `mkCast` co
697
    bndr = mk_ww_local uniq (exprType casted_scrut)
698

699
{-
700 701 702 703 704 705 706
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
Krzysztof Gogolewski's avatar
Typos  
Krzysztof Gogolewski committed
707
  foo = unsafeCoerce c_exit
708 709 710 711 712
  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
713
It does not seem feasible to avoid all such cases already in the analyser (and
714 715 716 717 718
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.


719 720 721
Note [Profiling and unpacking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If the original function looked like
722
        f = \ x -> {-# SCC "foo" #-} E
723 724

then we want the CPR'd worker to look like
725
        \ x -> {-# SCC "foo" #-} (case E of I# x -> x)
726
and definitely not
727
        \ x -> case ({-# SCC "foo" #-} E) of I# x -> x)
728 729 730 731 732 733 734 735 736

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.

737

738 739
************************************************************************
*                                                                      *
740
\subsection{Utilities}
741 742
*                                                                      *
************************************************************************
743

744 745
Note [Absent errors]
~~~~~~~~~~~~~~~~~~~~
746 747
We make a new binding for Ids that are marked absent, thus
   let x = absentError "x :: Int"
748
The idea is that this binding will never be used; but if it
749 750
buggily is used we'll get a runtime error message.

751 752 753 754 755 756 757
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,
758 759
    by making absentError
      (a) *not* be a bottoming Id,
760 761
      (b) be "ok for speculation"
    But that relies on the simplifier finding that it really
762
    is dead code, which is fragile, and indeed failed when
763 764
    profiling is on, which disables various optimisations.  So
    using a literal will do.]
765
-}
766

767 768
mk_absent_let :: DynFlags -> Id -> Maybe (CoreExpr -> CoreExpr)
mk_absent_let dflags arg
769
  | not (isUnliftedType arg_ty)
770
  = Just (Let (NonRec lifted_arg abs_rhs))
771
  | Just tc <- tyConAppTyCon_maybe arg_ty
772 773
  , Just lit <- absentLiteralOf tc
  = Just (Let (NonRec arg (Lit lit)))
774 775
  | arg_ty `eqType` voidPrimTy
  = Just (Let (NonRec arg (Var voidPrimId)))
776
  | otherwise
777
  = WARN( True, text "No absent value for" <+> ppr arg_ty )
778
    Nothing
779
  where
780 781 782 783 784 785 786 787
    arg_ty     = idType arg
    abs_rhs    = mkRuntimeErrorApp aBSENT_ERROR_ID arg_ty msg
    lifted_arg = arg `setIdStrictness` exnSig
              -- Note in strictness signature that this is bottoming
              -- (for the sake of the "empty case scrutinee not known to
              -- diverge for sure lint" warning)
    msg        = showSDoc (gopt_set dflags Opt_SuppressUniques)
                          (ppr arg <+> ppr (idType arg))
788 789 790 791 792 793
              -- We need to suppress uniques here because otherwise they'd
              -- end up in the generated code as strings. This is bad for
              -- determinism, because with different uniques the strings
              -- will have different lengths and hence different costs for
              -- the inliner leading to different inlining.
              -- See also Note [Unique Determinism] in Unique
794

795
mk_seq_case :: Id -> CoreExpr -> CoreExpr
796
mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) (exprType body) [(DEFAULT, [], body)]
797

798 799 800 801 802
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
803
-- the case binder.  e.g.       case ww_arg of ww_arg { I# x -> ... }
804
-- Quite likely ww_arg isn't used in '...'.  The case may get discarded
805 806
-- if the case binder says "I'm demanded".  This happened in a situation
-- like         (x+y) `seq` ....
807
sanitiseCaseBndr id = id `setIdInfo` vanillaIdInfo
808

809 810
mk_ww_local :: Unique -> Type -> Id
mk_ww_local uniq ty = mkSysLocalOrCoVar (fsLit "ww") uniq ty