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