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