ghc/compiler/stranal/WwLib.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section[WwLib]{A library for the ``worker/wrapper'' back-end to the strictness analyser}
   5
   6 \begin{code}
   7 module WwLib (
   8         WwBinding(..),
   9
  10         worthSplitting, setUnpackStrategy,
  11         mkWwBodies, mkWrapper
  12     ) where
  13
  14 #include "HsVersions.h"
  15
  16 import CoreSyn
  17 import Id               ( Id, idType, mkSysLocal, getIdDemandInfo, setIdDemandInfo,
  18                           mkWildId, setIdInfo
  19                         )
  20 import IdInfo           ( CprInfo(..), noCprInfo, vanillaIdInfo )
  21 import Const            ( Con(..), DataCon )
  22 import DataCon          ( splitProductType_maybe, isExistentialDataCon, dataConArgTys )
  23 import Demand           ( Demand(..) )
  24 import PrelInfo         ( realWorldPrimId, aBSENT_ERROR_ID )
  25 import TysPrim          ( realWorldStatePrimTy )
  26 import TysWiredIn       ( unboxedTupleCon, unboxedTupleTyCon )
  27 import Type             ( isUnLiftedType, mkTyVarTys, mkTyVarTy, mkFunTys,
  28                           splitForAllTys, splitFunTys, splitFunTysN,
  29                           splitAlgTyConApp_maybe, splitAlgTyConApp,
  30                           mkTyConApp, splitNewType_maybe,
  31                           Type
  32                         )
  33 import TyCon            ( isNewTyCon, isProductTyCon, TyCon )
  34 import BasicTypes       ( NewOrData(..) )
  35 import Var              ( TyVar )
  36 import UniqSupply       ( returnUs, thenUs, getUniqueUs, getUniquesUs,
  37                           mapUs, UniqSM )
  38 import Util             ( zipWithEqual, zipEqual )
  39 import Outputable
  40 \end{code}
  41
  42 %************************************************************************
  43 %*                                                                      *
  44 \subsection[datatype-WwLib]{@WwBinding@: a datatype for worker/wrapper-ing}
  45 %*                                                                      *
  46 %************************************************************************
  47
  48 In the worker/wrapper stuff, we want to carry around @CoreBindings@ in
  49 an ``intermediate form'' that can later be turned into a \tr{let} or
  50 \tr{case} (depending on strictness info).
  51
  52 \begin{code}
  53 data WwBinding
  54   = WwLet  [CoreBind]
  55   | WwCase (CoreExpr -> CoreExpr)
  56                 -- the "case" will be a "strict let" of the form:
  57                 --
  58                 --  case rhs of
  59                 --    <blah> -> body
  60                 --
  61                 -- (instead of "let <blah> = rhs in body")
  62                 --
  63                 -- The expr you pass to the function is "body" (the
  64                 -- expression that goes "in the corner").
  65 \end{code}
  66
  67 %************************************************************************
  68 %*                                                                      *
  69 \subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}
  70 %*                                                                      *
  71 %************************************************************************
  72
  73         ************   WARNING  ******************
  74         these comments are rather out of date
  75         *****************************************
  76
  77 @mkWrapperAndWorker@ is given:
  78 \begin{enumerate}
  79 \item
  80 The {\em original function} \tr{f}, of the form:
  81 \begin{verbatim}
  82 f = /\ tyvars -> \ args -> body
  83 \end{verbatim}
  84 The original-binder \tr{f}, the \tr{tyvars}, \tr{args}, and \tr{body}
  85 are given separately.
  86
  87 We use the Id \tr{f} mostly to get its type.
  88
  89 \item
  90 Strictness information about \tr{f}, in the form of a list of
  91 @Demands@.
  92
  93 \item
  94 A @UniqueSupply@.
  95 \end{enumerate}
  96
  97 @mkWrapperAndWorker@ produces (A BIT OUT-OF-DATE...):
  98 \begin{enumerate}
  99 \item
 100 Maybe @Nothing@: no worker/wrappering going on in this case. This can
 101 happen (a)~if the strictness info says that there is nothing
 102 interesting to do or (b)~if *any* of the argument types corresponding
 103 to ``active'' arg postitions is abstract or will be to the outside
 104 world (i.e., {\em this} module can see the constructors, but nobody
 105 else will be able to).  An ``active'' arg position is one which the
 106 wrapper has to unpack.  An importing module can't do this unpacking,
 107 so it simply has to give up and call the wrapper only.
 108
 109 \item
 110 Maybe \tr{Just (wrapper_Id, wrapper_body, worker_Id, worker_body)}.
 111
 112 The @wrapper_Id@ is just the one that was passed in, with its
 113 strictness IdInfo updated.
 114 \end{enumerate}
 115
 116 The \tr{body} of the original function may not be given (i.e., it's
 117 BOTTOM), in which case you'd jolly well better not tug on the
 118 worker-body output!
 119
 120 Here's an example.  The original function is:
 121 \begin{verbatim}
 122 g :: forall a . Int -> [a] -> a
 123
 124 g = /\ a -> \ x ys ->
 125         case x of
 126           0 -> head ys
 127           _ -> head (tail ys)
 128 \end{verbatim}
 129
 130 From this, we want to produce:
 131 \begin{verbatim}
 132 -- wrapper (an unfolding)
 133 g :: forall a . Int -> [a] -> a
 134
 135 g = /\ a -> \ x ys ->
 136         case x of
 137           I# x# -> g.wrk a x# ys
 138             -- call the worker; don't forget the type args!
 139
 140 -- worker
 141 g.wrk :: forall a . Int# -> [a] -> a
 142
 143 g.wrk = /\ a -> \ x# ys ->
 144         let
 145             x = I# x#
 146         in
 147             case x of               -- note: body of g moved intact
 148               0 -> head ys
 149               _ -> head (tail ys)
 150 \end{verbatim}
 151
 152 Something we have to be careful about:  Here's an example:
 153 \begin{verbatim}
 154 -- "f" strictness: U(P)U(P)
 155 f (I# a) (I# b) = a +# b
 156
 157 g = f   -- "g" strictness same as "f"
 158 \end{verbatim}
 159 \tr{f} will get a worker all nice and friendly-like; that's good.
 160 {\em But we don't want a worker for \tr{g}}, even though it has the
 161 same strictness as \tr{f}.  Doing so could break laziness, at best.
 162
 163 Consequently, we insist that the number of strictness-info items is
 164 exactly the same as the number of lambda-bound arguments.  (This is
 165 probably slightly paranoid, but OK in practice.)  If it isn't the
 166 same, we ``revise'' the strictness info, so that we won't propagate
 167 the unusable strictness-info into the interfaces.
 168
 169
 170 %************************************************************************
 171 %*                                                                      *
 172 \subsection{Functions over Demands}
 173 %*                                                                      *
 174 %************************************************************************
 175
 176 \begin{code}
 177 mAX_WORKER_ARGS :: Int          -- ToDo: set via flag
 178 mAX_WORKER_ARGS = 6
 179
 180 setUnpackStrategy :: [Demand] -> [Demand]
 181 setUnpackStrategy ds
 182   = snd (go (mAX_WORKER_ARGS - nonAbsentArgs ds) ds)
 183   where
 184     go :: Int                   -- Max number of args available for sub-components of [Demand]
 185        -> [Demand]
 186        -> (Int, [Demand])       -- Args remaining after subcomponents of [Demand] are unpacked
 187
 188     go n (WwUnpack nd _ cs : ds) | n' >= 0
 189                                  = WwUnpack nd True cs' `cons` go n'' ds
 190                                  | otherwise
 191                                  = WwUnpack nd False cs `cons` go n ds
 192                                  where
 193                                    n' = n + 1 - nonAbsentArgs cs
 194                                         -- Add one because we don't pass the top-level arg any more
 195                                         -- Delete # of non-absent args to which we'll now be committed
 196                                    (n'',cs') = go n' cs
 197
 198     go n (d:ds) = d `cons` go n ds
 199     go n []     = (n,[])
 200
 201     cons d (n,ds) = (n, d:ds)
 202
 203 nonAbsentArgs :: [Demand] -> Int
 204 nonAbsentArgs []                 = 0
 205 nonAbsentArgs (WwLazy True : ds) = nonAbsentArgs ds
 206 nonAbsentArgs (d           : ds) = 1 + nonAbsentArgs ds
 207
 208 worthSplitting :: [Demand]
 209                -> Bool  -- Result is bottom
 210                -> Bool  -- True <=> the wrapper would not be an identity function
 211 worthSplitting ds result_bot = not result_bot && any worth_it ds
 212         -- Don't split if the result is bottom; there's no efficiency to
 213         -- be gained, and (worse) the wrapper body may not look like a wrapper
 214         -- body to getWorkerIdAndCons
 215   where
 216     worth_it (WwLazy True)       = True         -- Absent arg
 217     worth_it (WwUnpack _ True _) = True         -- Arg to unpack
 218     worth_it WwStrict            = False        -- Don't w/w just because of strictness
 219     worth_it other               = False
 220
 221 allAbsent :: [Demand] -> Bool
 222 allAbsent ds = all absent ds
 223   where
 224     absent (WwLazy is_absent)   = is_absent
 225     absent (WwUnpack _ True cs) = allAbsent cs
 226     absent other                = False
 227 \end{code}
 228
 229
 230 %************************************************************************
 231 %*                                                                      *
 232 \subsection{The worker wrapper core}
 233 %*                                                                      *
 234 %************************************************************************
 235
 236 @mkWrapper@ is called when importing a function.  We have the type of
 237 the function and the name of its worker, and we want to make its body (the wrapper).
 238
 239 \begin{code}
 240 mkWrapper :: Type               -- Wrapper type
 241           -> Int                -- Arity
 242           -> [Demand]           -- Wrapper strictness info
 243           -> CprInfo            -- Wrapper cpr info
 244           -> UniqSM (Id -> CoreExpr)    -- Wrapper body, missing worker Id
 245
 246 mkWrapper fun_ty arity demands cpr_info
 247   = getUniquesUs arity          `thenUs` \ wrap_uniqs ->
 248     let
 249         (tyvars, tau_ty)   = splitForAllTys fun_ty
 250         (arg_tys, body_ty) = splitFunTysN "mkWrapper" arity tau_ty
 251                 -- The "expanding dicts" part here is important, even for the splitForAll
 252                 -- The imported thing might be a dictionary, such as Functor Foo
 253                 -- But Functor Foo = forall a b. (a->b) -> Foo a -> Foo b
 254                 -- and as such might have some strictness info attached.
 255                 -- Then we need to have enough args to zip to the strictness info
 256
 257         wrap_args          = zipWith mk_ww_local wrap_uniqs arg_tys
 258     in
 259     mkWwBodies tyvars wrap_args body_ty demands cpr_info        `thenUs` \ (wrap_fn, _, _) ->
 260     returnUs wrap_fn
 261 \end{code}
 262
 263 @mkWwBodies@ is called when doing the worker/wrapper split inside a module.
 264
 265 \begin{code}
 266 mkWwBodies :: [TyVar] -> [Id]                   -- Original fn args
 267            -> Type                              -- Type of result of original function
 268            -> [Demand]                          -- Strictness info for original fn; corresp 1-1 with args
 269            -> CprInfo                           -- Result of CPR analysis
 270            -> UniqSM (Id -> CoreExpr,           -- Wrapper body, lacking only the worker Id
 271                       CoreExpr -> CoreExpr,     -- Worker body, lacking the original function body
 272                       [Demand])                 -- Strictness info for worker
 273
 274 mkWwBodies tyvars wrap_args res_ty demands cpr_info
 275   = let
 276         -- demands may be longer than number of args.  If we aren't doing w/w
 277         -- for strictness then demands is an infinite list of 'lazy' args.
 278         wrap_args_w_demands = zipWith setIdDemandInfo wrap_args demands
 279
 280     in
 281     mkWWstr wrap_args_w_demands                 `thenUs` \ (wrap_fn_str,    work_fn_str,    work_arg_dmds) ->
 282     mkWWcoerce res_ty                           `thenUs` \ (wrap_fn_coerce, work_fn_coerce, coerce_res_ty) ->
 283     mkWWcpr coerce_res_ty cpr_info              `thenUs` \ (wrap_fn_cpr,    work_fn_cpr,    cpr_res_ty) ->
 284     mkWWfixup cpr_res_ty (null work_arg_dmds)   `thenUs` \ (wrap_fn_fixup,  work_fn_fixup) ->
 285
 286     returnUs (\ work_id -> Note InlineMe $
 287                            mkLams tyvars $ mkLams wrap_args_w_demands $
 288                            (wrap_fn_coerce . wrap_fn_cpr . wrap_fn_str . wrap_fn_fixup) $
 289                            mkVarApps (Var work_id) tyvars,
 290
 291               \ work_body  -> mkLams tyvars $
 292                               (work_fn_fixup . work_fn_str . work_fn_cpr . work_fn_coerce)
 293                               work_body,
 294
 295               work_arg_dmds)
 296 \end{code}
 297
 298
 299 %************************************************************************
 300 %*                                                                      *
 301 \subsection{Coercion stuff}
 302 %*                                                                      *
 303 %************************************************************************
 304
 305 The "coerce" transformation is
 306         f :: T1 -> T2 -> R
 307         f = \xy -> e
 308 ===>
 309         f = \xy -> coerce R R' (fw x y)
 310         fw = \xy -> coerce R' R e
 311
 312 where R' is the representation type for R.
 313
 314 \begin{code}
 315 mkWWcoerce body_ty
 316   = case splitNewType_maybe body_ty of
 317
 318         Nothing     -> returnUs (id, id, body_ty)
 319
 320         Just rep_ty -> returnUs (mkNote (Coerce body_ty rep_ty),
 321                                  mkNote (Coerce rep_ty body_ty),
 322                                  rep_ty)
 323 \end{code}
 324
 325
 326
 327 %************************************************************************
 328 %*                                                                      *
 329 \subsection{Fixup stuff}
 330 %*                                                                      *
 331 %************************************************************************
 332
 333 \begin{code}
 334 mkWWfixup res_ty no_worker_args
 335   | no_worker_args && isUnLiftedType res_ty
 336         -- Horrid special case.  If the worker would have no arguments, and the
 337         -- function returns a primitive type value, that would make the worker into
 338         -- an unboxed value.  We box it by passing a dummy void argument, thus:
 339         --
 340         --      f = /\abc. \xyz. fw abc void
 341         --      fw = /\abc. \v. body
 342         --
 343         -- We use the state-token type which generates no code
 344   = getUniqueUs                 `thenUs` \ void_arg_uniq ->
 345     let
 346             void_arg = mk_ww_local void_arg_uniq realWorldStatePrimTy
 347     in
 348     returnUs (\ call_to_worker -> App call_to_worker (Var void_arg),
 349               \ worker_body    -> Lam void_arg worker_body)
 350
 351   | otherwise
 352   = returnUs (id, id)
 353 \end{code}
 354
 355
 356 %************************************************************************
 357 %*                                                                      *
 358 \subsection{Strictness stuff}
 359 %*                                                                      *
 360 %************************************************************************
 361
 362 \begin{code}
 363 mkWWstr :: [Id]                                 -- Wrapper args; have their demand info on them
 364         -> UniqSM (CoreExpr -> CoreExpr,        -- Wrapper body, lacking the worker call
 365                                                 -- and without its lambdas
 366                                                 -- This fn adds the unboxing, and makes the
 367                                                 -- call passing the unboxed things
 368
 369                    CoreExpr -> CoreExpr,        -- Worker body, lacking the original body of the function,
 370                                                 -- but *with* lambdas
 371                    [Demand])                    -- Worker arg demands
 372
 373 mkWWstr wrap_args
 374   = mk_ww_str wrap_args         `thenUs` \ (work_args_w_demands, wrap_fn, work_fn) ->
 375     returnUs ( \ wrapper_body -> wrap_fn (mkVarApps wrapper_body work_args_w_demands),
 376                \ worker_body  -> mkLams work_args_w_demands (work_fn worker_body),
 377                map getIdDemandInfo work_args_w_demands)
 378
 379         -- Empty case
 380 mk_ww_str []
 381   = returnUs ([],
 382               \ wrapper_body -> wrapper_body,
 383               \ worker_body  -> worker_body)
 384
 385
 386 mk_ww_str (arg : ds)
 387   = case getIdDemandInfo arg of
 388
 389         -- Absent case
 390       WwLazy True ->
 391         mk_ww_str ds            `thenUs` \ (worker_args, wrap_fn, work_fn) ->
 392         returnUs (worker_args, wrap_fn, mk_absent_let arg . work_fn)
 393
 394         -- Unpack case
 395       WwUnpack new_or_data True cs ->
 396         getUniquesUs (length inst_con_arg_tys)          `thenUs` \ uniqs ->
 397         let
 398           unpk_args      = zipWith mk_ww_local uniqs inst_con_arg_tys
 399           unpk_args_w_ds = zipWithEqual "mk_ww_str" setIdDemandInfo unpk_args cs
 400         in
 401         mk_ww_str (unpk_args_w_ds ++ ds)                `thenUs` \ (worker_args, wrap_fn, work_fn) ->
 402         returnUs (worker_args,
 403                   mk_unpk_case new_or_data arg unpk_args data_con arg_tycon . wrap_fn,
 404                   work_fn . mk_pk_let new_or_data arg data_con tycon_arg_tys unpk_args)
 405         where
 406           (arg_tycon, tycon_arg_tys, data_con, inst_con_arg_tys) = splitProductType "mk_ww_str" (idType arg)
 407
 408         -- Other cases
 409       other_demand ->
 410         mk_ww_str ds            `thenUs` \ (worker_args, wrap_fn, work_fn) ->
 411         returnUs (arg : worker_args, wrap_fn, work_fn)
 412 \end{code}
 413
 414
 415 %************************************************************************
 416 %*                                                                      *
 417 \subsection{CPR stuff}
 418 %*                                                                      *
 419 %************************************************************************
 420
 421
 422 @mkWWcpr@ takes the worker/wrapper pair produced from the strictness
 423 info and adds in the CPR transformation.  The worker returns an
 424 unboxed tuple containing non-CPR components.  The wrapper takes this
 425 tuple and re-produces the correct structured output.
 426
 427 The non-CPR results appear ordered in the unboxed tuple as if by a
 428 left-to-right traversal of the result structure.
 429
 430
 431 \begin{code}
 432 mkWWcpr :: Type                              -- function body type
 433         -> CprInfo                           -- CPR analysis results
 434         -> UniqSM (CoreExpr -> CoreExpr,             -- New wrapper
 435                    CoreExpr -> CoreExpr,             -- New worker
 436                    Type)                        -- Type of worker's body
 437
 438 mkWWcpr body_ty NoCPRInfo
 439     = returnUs (id, id, body_ty)      -- Must be just the strictness transf.
 440 mkWWcpr body_ty (CPRInfo cpr_args)
 441     = getUniqueUs               `thenUs` \ body_arg_uniq ->
 442       let
 443         body_var = mk_ww_local body_arg_uniq body_ty
 444       in
 445       cpr_reconstruct body_ty cpr_info'                   `thenUs` \reconst_fn ->
 446       cpr_flatten body_ty cpr_info'                       `thenUs` \(flatten_fn, res_ty) ->
 447       returnUs (reconst_fn, flatten_fn, res_ty)
 448     where
 449             -- We only make use of the outer level of CprInfo,  otherwise we
 450             -- may lose laziness.  :-(  Hopefully,  we will find a use for the
 451             -- extra info some day (e.g. creating versions specialized to
 452             -- the use made of the components of the result by the callee)
 453       cpr_info' = CPRInfo (map (const NoCPRInfo) cpr_args)
 454 \end{code}
 455
 456
 457 @cpr_flatten@ takes the result type produced by the body and the info
 458 from the CPR analysis and flattens the constructed product components.
 459 These are returned in an unboxed tuple.
 460
 461 \begin{code}
 462 cpr_flatten :: Type -> CprInfo -> UniqSM (CoreExpr -> CoreExpr, Type)
 463 cpr_flatten ty cpr_info
 464     = mk_cpr_case (ty, cpr_info)       `thenUs` \(res_id, tup_ids, flatten_exp) ->
 465       let
 466         (unbx_tuple, unbx_tuple_ty) = mk_unboxed_tuple tup_ids
 467       in
 468       returnUs (\body -> Case body res_id [(DEFAULT, [], flatten_exp unbx_tuple)],
 469                 unbx_tuple_ty)
 470
 471
 472
 473 mk_cpr_case :: (Type, CprInfo) ->
 474                UniqSM (CoreBndr,                     -- Name of binder for this part of result
 475                       [(CoreExpr, Type)],            -- expressions for flattened result
 476                       CoreExpr -> CoreExpr)          -- add in code to flatten result
 477
 478 mk_cpr_case (ty, NoCPRInfo)
 479       -- this component must be returned as a component of the unboxed tuple result
 480     = getUniqueUs            `thenUs`     \id_uniq   ->
 481       let id_id = mk_ww_local id_uniq ty in
 482         returnUs (id_id, [(Var id_id, ty)], id)
 483 mk_cpr_case (ty, cpr_info@(CPRInfo ci_args))
 484     | isNewTyCon tycon  -- a new type: under the coercions must be a
 485                         -- constructed product
 486     = ASSERT ( null $ tail inst_con_arg_tys )
 487       mk_cpr_case (target_of_from_type, cpr_info)
 488                                  `thenUs`  \(arg, tup, exp) ->
 489       getUniqueUs                `thenUs`  \id_uniq   ->
 490       let id_id = mk_ww_local id_uniq ty
 491           new_exp_case = \var -> Case (Note (Coerce (idType arg) ty) (Var id_id))
 492                                       arg
 493                                       [(DEFAULT,[], exp var)]
 494       in
 495         returnUs (id_id, tup, new_exp_case)
 496
 497     | otherwise            -- a data type
 498                            -- flatten components
 499     = mapUs mk_cpr_case (zip inst_con_arg_tys ci_args)
 500                                  `thenUs`  \sub_builds ->
 501       getUniqueUs                `thenUs`  \id_uniq   ->
 502       let id_id = mk_ww_local id_uniq ty
 503           (args, tup, exp) = unzip3 sub_builds
 504           -- not used: con_app = mkConApp data_con (map Var args)
 505           new_tup = concat tup
 506           new_exp_case = \var -> Case (Var id_id) (mkWildId ty)
 507                                  [(DataCon data_con, args,
 508                                   foldl (\e f -> f e) var exp)]
 509       in
 510         returnUs (id_id, new_tup, new_exp_case)
 511     where
 512       (tycon, tycon_arg_tys, data_con, inst_con_arg_tys) = splitProductType "mk_cpr_case" ty
 513       from_type = head inst_con_arg_tys
 514       -- if coerced from a function 'look through' to find result type
 515       target_of_from_type = (snd.splitFunTys.snd.splitForAllTys) from_type
 516
 517 \end{code}
 518
 519 @cpr_reconstruct@ does the opposite of @cpr_flatten@.  It takes the unboxed
 520 tuple produced by the worker and reconstructs the structured result.
 521
 522 \begin{code}
 523 cpr_reconstruct :: Type -> CprInfo -> UniqSM (CoreExpr -> CoreExpr)
 524 cpr_reconstruct ty cpr_info
 525     = mk_cpr_let (ty,cpr_info)     `thenUs`  \(res_id, tup_ids, reconstruct_exp) ->
 526       returnUs (\worker -> Case worker (mkWildId $ worker_type tup_ids)
 527                            [(DataCon $ unboxedTupleCon $ length tup_ids,
 528                             tup_ids, reconstruct_exp $ Var res_id)])
 529
 530     where
 531         worker_type ids = mkTyConApp (unboxedTupleTyCon (length ids)) (map idType ids)
 532
 533
 534 mk_cpr_let :: (Type, CprInfo) ->
 535               UniqSM (CoreBndr,                -- Binder for this component of result
 536                       [CoreBndr],              -- Binders which will appear in worker's result
 537                       CoreExpr -> CoreExpr)    -- Code to produce structured result.
 538 mk_cpr_let (ty, NoCPRInfo)
 539       -- this component will appear explicitly in the unboxed tuple.
 540     = getUniqueUs            `thenUs`     \id_uniq   ->
 541       let
 542         id_id = mk_ww_local id_uniq ty
 543       in
 544       returnUs (id_id, [id_id], id)
 545
 546 mk_cpr_let (ty, cpr_info@(CPRInfo ci_args))
 547
 548 {- Should not be needed now:  mkWWfixup does this job
 549     | isNewTyCon tycon   -- a new type: must coerce the argument to this type
 550     = ASSERT ( null $ tail inst_con_arg_tys )
 551       mk_cpr_let (target_of_from_type, cpr_info)
 552                                  `thenUs`  \(arg, tup, exp) ->
 553       getUniqueUs                `thenUs`  \id_uniq   ->
 554       let id_id = mk_ww_local id_uniq ty
 555           new_exp = \var -> exp (Let (NonRec id_id (Note (Coerce ty (idType arg)) (Var arg))) var)
 556       in
 557         returnUs (id_id, tup, new_exp)
 558
 559     | otherwise     -- a data type
 560                     -- reconstruct components then apply data con
 561 -}
 562     = mapUs mk_cpr_let (zip inst_con_arg_tys ci_args)
 563                                  `thenUs`  \sub_builds ->
 564       getUniqueUs                `thenUs`  \id_uniq   ->
 565       let id_id = mk_ww_local id_uniq ty
 566           (args, tup, exp) = unzip3 sub_builds
 567           con_app = mkConApp data_con $ (map Type tycon_arg_tys) ++ (map Var args)
 568           new_tup = concat tup
 569           new_exp = \var -> foldl (\e f -> f e) (Let (NonRec id_id con_app) var) exp
 570       in
 571         returnUs (id_id, new_tup, new_exp)
 572     where
 573       (tycon, tycon_arg_tys, data_con, inst_con_arg_tys) = splitProductType "mk_cpr_let" ty
 574       from_type = head inst_con_arg_tys
 575       -- if coerced from a function 'look through' to find result type
 576       target_of_from_type = (snd.splitFunTys.snd.splitForAllTys) from_type
 577
 578
 579 splitProductType :: String -> Type -> (TyCon, [Type], DataCon, [Type])
 580   -- For a tiresome reason, the type might not look like a product type
 581   -- This happens when compiling the compiler!  The module Name
 582   -- imports {-# SOURCE #-} TyCon and Id
 583   --    data Name = Name NameSort Unique OccName Provenance
 584   --    data NameSort = WiredInId Module Id | ...
 585   -- So Name does not look recursive (because Id is imported via a hi-boot file,
 586   -- which says nothing about Id's rep) but actually it is, because Ids have Names.
 587   -- Modules that *import* Name have a more complete view, see that Name is recursive,
 588   -- and therefore that it isn't a ProductType.  This conflicts with the CPR info
 589   -- in exports from Name that say "do CPR".
 590   --
 591   -- Arguably we should regard Name as a product anyway because it isn't recursive
 592   -- via products all the way... but we don't have that info to hand, and even if
 593   -- we did this case might *still* arise.
 594
 595   --
 596   -- So we hack our way out for now, by trusting the pragma that said "do CPR"
 597   -- that means we can't use splitProductType_maybe
 598
 599 splitProductType fname ty
 600    = case splitAlgTyConApp_maybe ty of
 601         Just (tycon, tycon_args, (con:other_cons))
 602           | null other_cons && not (isExistentialDataCon con)
 603           -> WARN( not (isProductTyCon tycon),
 604                    text "splitProductType hack: I happened!" <+> ppr ty )
 605              (tycon, tycon_args, con, dataConArgTys con tycon_args)
 606
 607         Nothing -> pprPanic (fname ++ ": not a product") (ppr ty)
 608 \end{code}
 609
 610
 611 %************************************************************************
 612 %*                                                                      *
 613 \subsection{Utilities}
 614 %*                                                                      *
 615 %************************************************************************
 616
 617
 618 \begin{code}
 619 mk_absent_let arg body
 620   | not (isUnLiftedType arg_ty)
 621   = Let (NonRec arg (mkTyApps (Var aBSENT_ERROR_ID) [arg_ty])) body
 622   | otherwise
 623   = panic "WwLib: haven't done mk_absent_let for primitives yet"
 624   where
 625     arg_ty = idType arg
 626
 627 mk_unpk_case NewType arg unpk_args boxing_con boxing_tycon body
 628         -- A newtype!  Use a coercion not a case
 629   = ASSERT( null other_args )
 630     Case (Note (Coerce (idType unpk_arg) (idType arg)) (Var arg))
 631          (sanitiseCaseBndr unpk_arg)
 632          [(DEFAULT,[],body)]
 633   where
 634     (unpk_arg:other_args) = unpk_args
 635
 636 mk_unpk_case DataType arg unpk_args boxing_con boxing_tycon body
 637         -- A data type
 638   = Case (Var arg)
 639          (sanitiseCaseBndr arg)
 640          [(DataCon boxing_con, unpk_args, body)]
 641
 642 sanitiseCaseBndr :: Id -> Id
 643 -- The argument we are scrutinising has the right type to be
 644 -- a case binder, so it's convenient to re-use it for that purpose.
 645 -- But we *must* throw away all its IdInfo.  In particular, the argument
 646 -- will have demand info on it, and that demand info may be incorrect for
 647 -- the case binder.  e.g.       case ww_arg of ww_arg { I# x -> ... }
 648 -- Quite likely ww_arg isn't used in '...'.  The case may get discarded
 649 -- if the case binder says "I'm demanded".  This happened in a situation
 650 -- like         (x+y) `seq` ....
 651 sanitiseCaseBndr id = id `setIdInfo` vanillaIdInfo
 652
 653 mk_pk_let NewType arg boxing_con con_tys unpk_args body
 654   = ASSERT( null other_args )
 655     Let (NonRec arg (Note (Coerce (idType arg) (idType unpk_arg)) (Var unpk_arg))) body
 656   where
 657     (unpk_arg:other_args) = unpk_args
 658
 659 mk_pk_let DataType arg boxing_con con_tys unpk_args body
 660   = Let (NonRec arg (Con (DataCon boxing_con) con_args)) body
 661   where
 662     con_args = map Type con_tys ++ map Var unpk_args
 663
 664
 665 mk_ww_local uniq ty = mkSysLocal SLIT("ww") uniq ty
 666
 667
 668 mk_unboxed_tuple :: [(CoreExpr, Type)] -> (CoreExpr, Type)
 669 mk_unboxed_tuple contents
 670     = (mkConApp (unboxedTupleCon (length contents))
 671                 (map (Type . snd) contents ++
 672                  map fst contents),
 673        mkTyConApp (unboxedTupleTyCon (length contents))
 674                   (map snd contents))
 675 \end{code}