ghc/compiler/specialise/SpecMisc.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
   3 %
   4 \section[SpecMisc]{Miscellaneous stuff for the Specialiser}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module SpecMisc where
  10
  11 import PlainCore
  12 import SpecTyFuns
  13 import SpecMonad
  14
  15 IMPORT_Trace
  16 import Outputable       -- ToDo: these may be removable...
  17 import Pretty
  18
  19 import AbsUniType
  20 import Bag
  21 import CmdLineOpts      ( GlobalSwitch(..) )
  22 import CoreLift         ( mkLiftedId, liftExpr, bindUnlift, applyBindUnlifts )
  23 import IdEnv
  24 import Id
  25 import IdInfo
  26 import InstEnv          ( lookupClassInstAtSimpleType )
  27 import Maybes           ( catMaybes, firstJust, maybeToBool, Maybe(..) )
  28 import TyVarEnv         -- ( growTyVarEnvList, nullTyVarEnv, TyVarEnv, TypeEnv(..) )
  29 import Util
  30 import UniqSet
  31 import SplitUniq
  32
  33 infixr 9 `thenSM`
  34 \end{code}
  35
  36 %************************************************************************
  37 %*                                                                      *
  38 \subsubsection[CallInstances]{@CallInstances@ data type}
  39 %*                                                                      *
  40 %************************************************************************
  41
  42 \begin{code}
  43 type FreeVarsSet   = UniqSet Id
  44 type FreeTyVarsSet = UniqSet TyVar
  45
  46 data CallInstance
  47   = CallInstance
  48                 Id                      -- This Id; *new* ie *cloned* id
  49                 [Maybe UniType]         -- Specialised at these types (*new*, cloned)
  50                                         -- Nothing => no specialisation on this type arg
  51                                         --            is required (flag dependent).
  52                 [PlainCoreArg]          -- And these dictionaries; all ValArgs
  53                 FreeVarsSet             -- Free vars of the dict-args in terms of *new* ids
  54                 (Maybe SpecInfo)        -- For specialisation with explicit SpecId
  55 \end{code}
  56
  57 \begin{code}
  58 pprCI :: CallInstance -> Pretty
  59 pprCI (CallInstance id spec_tys dicts _ maybe_specinfo)
  60   = ppHang (ppCat [ppStr "Call inst for", ppr PprDebug id])
  61          4 (ppAboves [ppCat (ppStr "types" : [pprMaybeTy PprDebug ty | ty <- spec_tys]),
  62                       case maybe_specinfo of
  63                         Nothing -> ppCat (ppStr "dicts" : [ppr PprDebug dict | dict <- dicts])
  64                         Just (SpecInfo _ _ spec_id)
  65                                 -> ppCat [ppStr "Explicit SpecId", ppr PprDebug spec_id]
  66                      ])
  67
  68 isUnboxedCI :: CallInstance -> Bool
  69 isUnboxedCI (CallInstance _ spec_tys _ _ _)
  70   = any isUnboxedDataType (catMaybes spec_tys)
  71
  72 isExplicitCI :: CallInstance -> Bool
  73 isExplicitCI (CallInstance _ _ _ _ (Just _))
  74   = True
  75 isExplicitCI (CallInstance _ _ _ _ Nothing)
  76   = False
  77 \end{code}
  78
  79 Comparisons are based on the {\em types}, ignoring the dictionary args:
  80
  81 \begin{code}
  82
  83 cmpCI :: CallInstance -> CallInstance -> TAG_
  84 cmpCI (CallInstance id1 tys1 _ _ _) (CallInstance id2 tys2 _ _ _)
  85   = case cmpId id1 id2 of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other }
  86
  87 cmpCI_tys :: CallInstance -> CallInstance -> TAG_
  88 cmpCI_tys (CallInstance _ tys1 _ _ _) (CallInstance _ tys2 _ _ _)
  89   = cmpUniTypeMaybeList tys1 tys2
  90
  91 eqCI_tys :: CallInstance -> CallInstance -> Bool
  92 eqCI_tys c1 c2
  93   = case cmpCI_tys c1 c2 of { EQ_ -> True; other -> False }
  94
  95 isCIofTheseIds :: [Id] -> CallInstance -> Bool
  96 isCIofTheseIds ids (CallInstance ci_id _ _ _ _)
  97   = any (eqId ci_id) ids
  98
  99 singleCI :: Id -> [Maybe UniType] -> [PlainCoreArg] -> UsageDetails
 100 singleCI id tys dicts
 101   = UsageDetails (unitBag (CallInstance id tys dicts fv_set Nothing))
 102                  emptyBag [] emptyUniqSet 0 0
 103   where
 104     fv_set = mkUniqSet (id : [dict | ValArg (CoVarAtom dict) <- dicts])
 105
 106 explicitCI :: Id -> [Maybe UniType] -> SpecInfo -> UsageDetails
 107 explicitCI id tys specinfo
 108   = UsageDetails (unitBag call_inst) emptyBag [] emptyUniqSet 0 0
 109   where
 110     call_inst = CallInstance id tys dicts fv_set (Just specinfo)
 111     dicts  = panic "Specialise:explicitCI:dicts"
 112     fv_set = singletonUniqSet id
 113
 114 -- We do not process the CIs for top-level dfuns or defms
 115 -- Instead we require an explicit SPEC inst pragma for dfuns
 116 -- and an explict method within any instances for the defms
 117
 118 getCIids :: Bool -> [Id] -> [Id]
 119 getCIids True ids = filter not_dict_or_defm ids
 120 getCIids _    ids = ids
 121
 122 not_dict_or_defm id
 123   = not (isDictTy (getIdUniType id) || maybeToBool (isDefaultMethodId_maybe id))
 124
 125 getCIs :: Bool -> [Id] -> UsageDetails -> ([CallInstance], UsageDetails)
 126 getCIs top_lev ids (UsageDetails cis tycon_cis dbs fvs c i)
 127   = let
 128         (cis_here, cis_not_here) = partitionBag (isCIofTheseIds (getCIids top_lev ids)) cis
 129         cis_here_list = bagToList cis_here
 130     in
 131     -- pprTrace "getCIs:"
 132     -- (ppHang (ppBesides [ppStr "{", ppr PprDebug ids, ppStr "}"])
 133     --       4 (ppAboves (map pprCI cis_here_list)))
 134     (cis_here_list, UsageDetails cis_not_here tycon_cis dbs fvs c i)
 135
 136 dumpCIs :: Bag CallInstance     -- The call instances
 137         -> Bool                 -- True <=> top level bound Ids
 138         -> Bool                 -- True <=> dict bindings to be floated (specBind only)
 139         -> [CallInstance]       -- Call insts for bound ids (instBind only)
 140         -> [Id]                 -- Bound ids *new*
 141         -> [Id]                 -- Full bound ids: includes dumped dicts
 142         -> Bag CallInstance     -- Kept call instances
 143
 144         -- CIs are dumped if:
 145         --   1) they are a CI for one of the bound ids, or
 146         --   2) they mention any of the dicts in a local unfloated binding
 147         --
 148         -- For top-level bindings we allow the call instances to
 149         -- float past a dict bind and place all the top-level binds
 150         -- in a *global* CoRec.
 151         -- We leave it to the simplifier will sort it all out ...
 152
 153 dumpCIs cis top_lev floating inst_cis bound_ids full_ids
 154  = (if not (isEmptyBag cis_of_bound_id) &&
 155        not (isEmptyBag cis_of_bound_id_without_inst_cis)
 156     then
 157        pprTrace ("dumpCIs: dumping CI which was not instantiated ... \n" ++
 158                  "         (may be a non-HM recursive call)\n")
 159        (ppHang (ppBesides [ppStr "{", ppr PprDebug bound_ids, ppStr "}"])
 160              4 (ppAboves [ppStr "Dumping CIs:",
 161                           ppAboves (map pprCI (bagToList cis_of_bound_id)),
 162                           ppStr "Instantiating CIs:",
 163                           ppAboves (map pprCI inst_cis)]))
 164     else id) (
 165    if top_lev || floating then
 166        cis_not_bound_id
 167    else
 168        (if not (isEmptyBag cis_dump_unboxed)
 169         then pprTrace "dumpCIs: bound dictionary arg ... WITH UNBOXED TYPES!\n"
 170              (ppHang (ppBesides [ppStr "{", ppr PprDebug full_ids, ppStr "}"])
 171                    4 (ppAboves (map pprCI (bagToList cis_dump))))
 172         else id)
 173        cis_keep_not_bound_id
 174    )
 175  where
 176    (cis_of_bound_id, cis_not_bound_id)
 177       = partitionBag (isCIofTheseIds (getCIids top_lev bound_ids)) cis
 178
 179    (cis_dump, cis_keep_not_bound_id)
 180       = partitionBag ok_to_dump_ci cis_not_bound_id
 181
 182    ok_to_dump_ci (CallInstance _ _ _ fv_set _)
 183         = or [i `elementOfUniqSet` fv_set | i <- full_ids]
 184
 185    (_, cis_of_bound_id_without_inst_cis) = partitionBag have_inst_ci cis_of_bound_id
 186    have_inst_ci ci = any (eqCI_tys ci) inst_cis
 187
 188    (cis_dump_unboxed, _) = partitionBag isUnboxedCI cis_dump
 189
 190 \end{code}
 191
 192 Any call instances of a bound_id can be safely dumped, because any
 193 recursive calls should be at the same instance as the parent instance.
 194
 195    letrec f = /\a -> \x::a -> ...(f t x')...
 196
 197 Here, the type, t, at which f is used in its own RHS should be
 198 just "a"; that is, the recursive call is at the same type as
 199 the original call. That means that when specialising f at some
 200 type, say Int#, we shouldn't find any *new* instances of f
 201 arising from specialising f's RHS.  The only instance we'll find
 202 is another call of (f Int#).
 203
 204 We check this in dumpCIs by passing in all the instantiated call
 205 instances (inst_cis) and reporting any dumped cis (cis_of_bound_id)
 206 for which there is no such instance.
 207
 208 We also report CIs dumped due to a bound dictionary arg if they
 209 contain unboxed types.
 210
 211 %************************************************************************
 212 %*                                                                      *
 213 \subsubsection[TyConInstances]{@TyConInstances@ data type}
 214 %*                                                                      *
 215 %************************************************************************
 216
 217 \begin{code}
 218 data TyConInstance
 219   = TyConInstance TyCon                 -- Type Constructor
 220                   [Maybe UniType]       -- Applied to these specialising types
 221
 222 cmpTyConI :: TyConInstance -> TyConInstance -> TAG_
 223 cmpTyConI (TyConInstance tc1 tys1) (TyConInstance tc2 tys2)
 224   = case cmpTyCon tc1 tc2 of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other }
 225
 226 cmpTyConI_tys :: TyConInstance -> TyConInstance -> TAG_
 227 cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2)
 228   = cmpUniTypeMaybeList tys1 tys2
 229
 230 singleTyConI :: TyCon -> [Maybe UniType] -> UsageDetails
 231 singleTyConI ty_con spec_tys
 232   = UsageDetails emptyBag (unitBag (TyConInstance ty_con spec_tys)) [] emptyUniqSet 0 0
 233
 234 isTyConIofThisTyCon :: TyCon -> TyConInstance -> Bool
 235 isTyConIofThisTyCon ty_con (TyConInstance inst_ty_con _) = eqTyCon ty_con inst_ty_con
 236
 237 isLocalSpecTyConI :: Bool -> TyConInstance -> Bool
 238 isLocalSpecTyConI comp_prel (TyConInstance inst_ty_con _) = isLocalSpecTyCon comp_prel inst_ty_con
 239
 240 getLocalSpecTyConIs :: Bool -> UsageDetails -> ([TyConInstance], UsageDetails)
 241 getLocalSpecTyConIs comp_prel (UsageDetails cis tycon_cis dbs fvs c i)
 242   = let
 243         (tycon_cis_local, tycon_cis_global)
 244           = partitionBag (isLocalSpecTyConI comp_prel) tycon_cis
 245         tycon_cis_local_list = bagToList tycon_cis_local
 246     in
 247     (tycon_cis_local_list, UsageDetails cis tycon_cis_global dbs fvs c i)
 248 \end{code}
 249
 250
 251 %************************************************************************
 252 %*                                                                      *
 253 \subsubsection[UsageDetails]{@UsageDetails@ data type}
 254 %*                                                                      *
 255 %************************************************************************
 256
 257 \begin{code}
 258 data UsageDetails
 259   = UsageDetails
 260         (Bag CallInstance)      -- The collection of call-instances
 261         (Bag TyConInstance)     -- Constructor call-instances
 262         [DictBindDetails]       -- Dictionary bindings in data-dependence order!
 263         FreeVarsSet             -- Free variables (excl imported ones, incl top level) (cloned)
 264         Int                     -- no. of spec calls
 265         Int                     -- no. of spec insts
 266 \end{code}
 267
 268 The DictBindDetails are fully processed; their call-instance information is
 269 incorporated in the call-instances of the
 270 UsageDetails which includes the DictBindDetails.  The free vars in a usage details
 271 will *include* the binders of the DictBind details.
 272
 273 A @DictBindDetails@ contains bindings for dictionaries *only*.
 274
 275 \begin{code}
 276 data DictBindDetails
 277   = DictBindDetails
 278         [Id]                    -- Main binders, originally visible in scope of binding (cloned)
 279         PlainCoreBinding        -- Fully processed
 280         FreeVarsSet             -- Free in binding group (cloned)
 281         FreeTyVarsSet           -- Free in binding group
 282 \end{code}
 283
 284 \begin{code}
 285 emptyUDs    :: UsageDetails
 286 unionUDs    :: UsageDetails -> UsageDetails -> UsageDetails
 287 unionUDList :: [UsageDetails] -> UsageDetails
 288
 289 tickSpecCall :: Bool -> UsageDetails -> UsageDetails
 290 tickSpecInsts :: UsageDetails -> UsageDetails
 291
 292 tickSpecCall found (UsageDetails cis ty_cis dbs fvs c i)
 293  = UsageDetails cis ty_cis dbs fvs (c + (if found then 1 else 0)) i
 294
 295 tickSpecInsts (UsageDetails cis ty_cis dbs fvs c i)
 296  = UsageDetails cis ty_cis dbs fvs c (i+1)
 297
 298 emptyUDs = UsageDetails emptyBag emptyBag [] emptyUniqSet 0 0
 299
 300 unionUDs (UsageDetails cis1 tycon_cis1 dbs1 fvs1 c1 i1) (UsageDetails cis2 tycon_cis2 dbs2 fvs2 c2 i2)
 301  = UsageDetails (unionBags cis1 cis2) (unionBags tycon_cis1 tycon_cis2)
 302                 (dbs1 ++ dbs2) (fvs1 `unionUniqSets` fvs2) (c1+c2) (i1+i2)
 303         -- The append here is really redundant, since the bindings don't
 304         -- scope over each other.  ToDo.
 305
 306 unionUDList = foldr unionUDs emptyUDs
 307
 308 singleFvUDs (CoVarAtom v) | not (isImportedId v)
 309  = UsageDetails emptyBag emptyBag [] (singletonUniqSet v) 0 0
 310 singleFvUDs other
 311  = emptyUDs
 312
 313 singleConUDs con = UsageDetails emptyBag emptyBag [] (singletonUniqSet con) 0 0
 314
 315 dumpDBs :: [DictBindDetails]
 316         -> Bool                 -- True <=> top level bound Ids
 317         -> [TyVar]              -- TyVars being bound (cloned)
 318         -> [Id]                 -- Ids being bound (cloned)
 319         -> FreeVarsSet          -- Fvs of body
 320         -> ([PlainCoreBinding], -- These ones have to go here
 321             [DictBindDetails],  -- These can float further
 322             [Id],               -- Incoming list + names of dicts bound here
 323             FreeVarsSet         -- Incoming fvs + fvs of dicts bound here
 324            )
 325
 326         -- It is just to complex to try to float top-level
 327         -- dict bindings with constant methods, inst methods,
 328         -- auxillary derived instance defns and user instance
 329         -- defns all getting in the way.
 330         -- So we dump all dbinds as soon as we get to the top
 331         -- level and place them in a *global* CoRec.
 332         -- We leave it to the simplifier will sort it all out ...
 333
 334 dumpDBs [] top_lev bound_tyvars bound_ids fvs
 335   = ([], [], bound_ids, fvs)
 336
 337 dumpDBs ((db@(DictBindDetails dbinders dbind db_fvs db_ftv)):dbs)
 338         top_lev bound_tyvars bound_ids fvs
 339   | top_lev
 340     || or [i `elementOfUniqSet` db_fvs  | i <- bound_ids]
 341     || or [tv `elementOfUniqSet` db_ftv | tv <- bound_tyvars]
 342   = let         -- Ha!  Dump it!
 343         (dbinds_here, dbs_outer, full_bound_ids, full_fvs)
 344            = dumpDBs dbs top_lev bound_tyvars (dbinders ++ bound_ids) (db_fvs `unionUniqSets` fvs)
 345     in
 346     (dbind : dbinds_here, dbs_outer, full_bound_ids, full_fvs)
 347
 348   | otherwise   -- This one can float out further
 349   = let
 350         (dbinds_here, dbs_outer, full_bound_ids, full_fvs)
 351            = dumpDBs dbs top_lev bound_tyvars bound_ids fvs
 352     in
 353     (dbinds_here, db : dbs_outer, full_bound_ids, full_fvs)
 354
 355
 356
 357 dumpUDs :: UsageDetails
 358         -> Bool                 -- True <=> top level bound Ids
 359         -> Bool                 -- True <=> dict bindings to be floated (specBind only)
 360         -> [CallInstance]       -- Call insts for bound Ids (instBind only)
 361         -> [Id]                 -- Ids which are just being bound; *new*
 362         -> [TyVar]              -- TyVars which are just being bound
 363         -> ([PlainCoreBinding], -- Bindings from UsageDetails which mention the ids
 364             UsageDetails)       -- The above bindings removed, and
 365                                 -- any call-instances which mention the ids dumped too
 366
 367 dumpUDs (UsageDetails cis tycon_cis dbs fvs c i) top_lev floating inst_cis bound_ids tvs
 368   = let
 369         (dict_binds_here, dbs_outer, full_bound_ids, full_fvs)
 370                   = dumpDBs dbs top_lev tvs bound_ids fvs
 371         cis_outer = dumpCIs cis top_lev floating inst_cis bound_ids full_bound_ids
 372         fvs_outer = full_fvs `minusUniqSet` (mkUniqSet full_bound_ids)
 373     in
 374     (dict_binds_here, UsageDetails cis_outer tycon_cis dbs_outer fvs_outer c i)
 375 \end{code}
 376
 377 \begin{code}
 378 addDictBinds :: [Id] -> PlainCoreBinding -> UsageDetails        -- Dict binding and RHS usage
 379              -> UsageDetails                                    -- The usage to augment
 380              -> UsageDetails
 381 addDictBinds dbinders dbind (UsageDetails db_cis db_tycon_cis db_dbs db_fvs db_c db_i)
 382                             (UsageDetails cis    tycon_cis    dbs    fvs    c    i)
 383   = UsageDetails (db_cis `unionBags` cis)
 384                  (db_tycon_cis `unionBags` tycon_cis)
 385                  (db_dbs ++ [DictBindDetails dbinders dbind db_fvs db_ftvs] ++ dbs)
 386                  fvs c i
 387                  -- NB: We ignore counts from dictbinds since it is not user code
 388   where
 389         -- The free tyvars of the dictionary bindings should really be
 390         -- gotten from the RHSs, but I'm pretty sure it's good enough just
 391         -- to look at the type of the dictionary itself.
 392         -- Doing the proper job would entail keeping track of free tyvars as
 393         -- well as free vars, which would be a bore.
 394     db_ftvs = mkUniqSet (extractTyVarsFromTys (map getIdUniType dbinders))
 395 \end{code}
 396
 397 %************************************************************************
 398 %*                                                                      *
 399 \subsection[Misc]{Miscellaneous junk}
 400 %*                                                                      *
 401 %************************************************************************
 402
 403 \begin{code}
 404 mkCallInstance :: Id
 405                -> Id
 406                -> [(PlainCoreArg, UsageDetails, PlainCoreExpr -> PlainCoreExpr)]
 407                -> SpecM UsageDetails
 408
 409 mkCallInstance id new_id []
 410   = returnSM emptyUDs
 411
 412 mkCallInstance id new_id args
 413
 414         -- No specialised versions for "error" and friends are req'd.
 415         -- This is a special case in core lint etc.
 416
 417   | isBottomingId id
 418   = returnSM emptyUDs
 419
 420         -- No call instances for SuperDictSelIds
 421         -- These are a special case in mkCall
 422
 423   | maybeToBool (isSuperDictSelId_maybe id)
 424   = returnSM emptyUDs
 425
 426         -- There are also no call instances for ClassOpIds
 427         -- However, we need to process it to get any second-level call
 428         -- instances for a ConstMethodId extracted from its SpecEnv
 429
 430   | otherwise
 431   = getSwitchCheckerSM          `thenSM` \ sw_chkr ->
 432     let
 433         spec_overloading = sw_chkr SpecialiseOverloaded
 434         spec_unboxed     = sw_chkr SpecialiseUnboxed
 435         spec_all         = sw_chkr SpecialiseAll
 436
 437         (tyvars, class_tyvar_pairs) = getIdOverloading id
 438
 439         arg_res = take_type_args tyvars class_tyvar_pairs args
 440         enough_args = maybeToBool arg_res
 441
 442         (Just (tys, dicts, rest_args)) = arg_res
 443
 444         record_spec id tys
 445           = (record, lookup, spec_tys)
 446           where
 447             spec_tys = specialiseCallTys spec_all spec_unboxed spec_overloading
 448                                          (mkConstraintVector id) tys
 449
 450             record = any (not . isTyVarTy) (catMaybes spec_tys)
 451
 452             lookup = lookupSpecEnv (getIdSpecialisation id) tys
 453     in
 454     if (not enough_args) then
 455         pprPanic "Specialise:recordCallInst: Unsaturated Type & Dict Application:\n\t"
 456                  (ppCat [ppr PprDebug id, ppr PprDebug [arg | (arg,_,_) <- args] ])
 457     else
 458     case record_spec id tys of
 459         (False, _, _)
 460              -> -- pprTrace "CallInst:NotReqd\n"
 461                 -- (ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)])
 462                 (returnSM emptyUDs)
 463
 464         (True, Nothing, spec_tys)
 465              -> if isClassOpId id then  -- No CIs for class ops, dfun will give SPEC inst
 466                     returnSM emptyUDs
 467                 else
 468                     -- pprTrace "CallInst:Reqd\n"
 469                     -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
 470                     --            ppCat [ppStr "CI", ppCat (map (pprMaybeTy PprDebug) spec_tys),
 471                     --                               ppCat (map (ppr PprDebug) dicts)]])
 472                     (returnSM (singleCI new_id spec_tys dicts))
 473
 474         (True, Just (spec_id, tys_left, toss), _)
 475              -> if maybeToBool (isConstMethodId_maybe spec_id) then
 476                         -- If we got a const method spec_id see if further spec required
 477                         -- NB: const method is top-level so spec_id will not be cloned
 478                     case record_spec spec_id tys_left of
 479                       (False, _, _)
 480                         -> -- pprTrace "CallInst:Exists\n"
 481                            -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
 482                            --            ppCat [ppStr "->", ppr PprDebug spec_id,
 483                            --                   ppr PprDebug (tys_left ++ drop toss dicts)]])
 484                            (returnSM emptyUDs)
 485
 486                       (True, Nothing, spec_tys)
 487                         -> -- pprTrace "CallInst:Exists:Reqd\n"
 488                            -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
 489                            --            ppCat [ppStr "->", ppr PprDebug spec_id,
 490                            --                   ppr PprDebug (tys_left ++ drop toss dicts)],
 491                            --            ppCat [ppStr "CI", ppCat (map (pprMaybeTy PprDebug) spec_tys),
 492                            --                               ppCat (map (ppr PprDebug) (drop toss dicts))]])
 493                            (returnSM (singleCI spec_id spec_tys (drop toss dicts)))
 494
 495                       (True, Just (spec_spec_id, tys_left_left, toss_toss), _)
 496                         -> -- pprTrace "CallInst:Exists:Exists\n"
 497                            -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
 498                            --            ppCat [ppStr "->", ppr PprDebug spec_id,
 499                            --                   ppr PprDebug (tys_left ++ drop toss dicts)],
 500                            --            ppCat [ppStr "->", ppr PprDebug spec_spec_id,
 501                            --                   ppr PprDebug (tys_left_left ++ drop (toss + toss_toss) dicts)]])
 502                            (returnSM emptyUDs)
 503
 504                 else
 505                     -- pprTrace "CallInst:Exists\n"
 506                     -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
 507                     --            ppCat [ppStr "->", ppr PprDebug spec_id,
 508                     --                   ppr PprDebug (tys_left ++ drop toss dicts)]])
 509                     (returnSM emptyUDs)
 510
 511
 512 take_type_args (_:tyvars) class_tyvar_pairs ((TypeArg ty,_,_):args)
 513         = case take_type_args tyvars class_tyvar_pairs args of
 514                 Nothing                   -> Nothing
 515                 Just (tys, dicts, others) -> Just (ty:tys, dicts, others)
 516 take_type_args (_:tyvars) class_tyvar_pairs []
 517         = Nothing
 518 take_type_args [] class_tyvar_pairs args
 519         = case take_dict_args class_tyvar_pairs args of
 520                 Nothing              -> Nothing
 521                 Just (dicts, others) -> Just ([], dicts, others)
 522
 523 take_dict_args (_:class_tyvar_pairs) ((dict@(ValArg _),_,_):args)
 524         = case take_dict_args class_tyvar_pairs args of
 525                 Nothing              -> Nothing
 526                 Just (dicts, others) -> Just (dict:dicts, others)
 527 take_dict_args (_:class_tyvar_pairs) []
 528         = Nothing
 529 take_dict_args [] args
 530         = Just ([], args)
 531 \end{code}
 532
 533 \begin{code}
 534 mkCall :: Id
 535        -> [(PlainCoreArg, UsageDetails, PlainCoreExpr -> PlainCoreExpr)]
 536        -> SpecM (Bool, PlainCoreExpr)
 537
 538 mkCall new_id args
 539   | maybeToBool (isSuperDictSelId_maybe new_id)
 540     && any isUnboxedDataType ty_args
 541         -- No specialisations for super-dict selectors
 542         -- Specialise unboxed calls to SuperDictSelIds by extracting
 543         -- the super class dictionary directly form the super class
 544         -- NB: This should be dead code since all uses of this dictionary should
 545         --     have been specialised. We only do this to keep core-lint happy.
 546     = let
 547          Just (_, super_class) = isSuperDictSelId_maybe new_id
 548          super_dict_id = case lookupClassInstAtSimpleType super_class (head ty_args) of
 549                          Nothing -> panic "Specialise:mkCall:SuperDictId"
 550                          Just id -> id
 551       in
 552       returnSM (False, CoVar super_dict_id)
 553
 554   | otherwise
 555     = case lookupSpecEnv (getIdSpecialisation new_id) ty_args of
 556         Nothing -> checkUnspecOK new_id ty_args (
 557                    returnSM (False, unspec_call)
 558                    )
 559
 560         Just spec_1_details@(spec_id_1, tys_left_1, dicts_to_toss_1)
 561                 -> let
 562                         -- It may be necessary to specialsie a constant method spec_id again
 563                        (spec_id, tys_left, dicts_to_toss) =
 564                             case (maybeToBool (isConstMethodId_maybe spec_id_1),
 565                                   lookupSpecEnv (getIdSpecialisation spec_id_1) tys_left_1) of
 566                                  (False, _ )     -> spec_1_details
 567                                  (True, Nothing) -> spec_1_details
 568                                  (True, Just (spec_id_2, tys_left_2, dicts_to_toss_2))
 569                                                  -> (spec_id_2, tys_left_2, dicts_to_toss_1 + dicts_to_toss_2)
 570
 571                        args_left = toss_dicts dicts_to_toss val_args
 572                    in
 573                    checkSpecOK new_id ty_args spec_id tys_left (
 574
 575                         -- The resulting spec_id may be a top-level unboxed value
 576                         -- This can arise for:
 577                         -- 1) constant method values
 578                         --    eq: class Num a where pi :: a
 579                         --        instance Num Double# where pi = 3.141#
 580                         -- 2) specilised overloaded values
 581                         --    eq: i1 :: Num a => a
 582                         --        i1 Int# d.Num.Int# ==> i1.Int#
 583                         -- These top level defns should have been lifted.
 584                         -- We must add code to unlift such a spec_id.
 585
 586                    if isUnboxedDataType (getIdUniType spec_id) then
 587                        ASSERT (null tys_left && null args_left)
 588                        if toplevelishId spec_id then
 589                            liftId spec_id       `thenSM` \ (lift_spec_id, unlift_spec_id) ->
 590                            returnSM (True, bindUnlift lift_spec_id unlift_spec_id
 591                                                       (CoVar unlift_spec_id))
 592                        else
 593                            pprPanic "Specialise:mkCall: unboxed spec_id not top-level ...\n"
 594                                     (ppCat [ppr PprDebug new_id,
 595                                             ppInterleave ppNil (map (pprParendUniType PprDebug) ty_args),
 596                                             ppStr "==>",
 597                                             ppr PprDebug spec_id])
 598                    else
 599                    let
 600                        (vals_left, _, unlifts_left) = unzip3 args_left
 601                        applied_tys  = mkCoTyApps (CoVar spec_id) tys_left
 602                        applied_vals = applyToArgs applied_tys vals_left
 603                    in
 604                    returnSM (True, applyBindUnlifts unlifts_left applied_vals)
 605                    )
 606   where
 607     (tys_and_vals, _, unlifts) = unzip3 args
 608     unspec_call = applyBindUnlifts unlifts (applyToArgs (CoVar new_id) tys_and_vals)
 609
 610
 611         -- ty_args is the types at the front of the arg list
 612         -- val_args is the rest of the arg-list
 613
 614     (ty_args, val_args) = get args
 615       where
 616         get ((TypeArg ty,_,_) : args) = (ty : tys, rest) where (tys,rest) = get args
 617         get args                      = ([],       args)
 618
 619
 620         -- toss_dicts chucks away dict args, checking that they ain't types!
 621     toss_dicts 0 args                = args
 622     toss_dicts n ((ValArg _,_,_) : args) = toss_dicts (n-1) args
 623
 624 \end{code}
 625
 626 \begin{code}
 627 checkUnspecOK :: Id -> [UniType] -> a -> a
 628 checkUnspecOK check_id tys
 629   = if isLocallyDefined check_id && any isUnboxedDataType tys
 630     then pprPanic "Specialise:checkUnspecOK: unboxed instance for local id not found\n"
 631                   (ppCat [ppr PprDebug check_id,
 632                           ppInterleave ppNil (map (pprParendUniType PprDebug) tys)])
 633     else id
 634
 635 checkSpecOK :: Id -> [UniType] -> Id -> [UniType] -> a -> a
 636 checkSpecOK check_id tys spec_id tys_left
 637   = if any isUnboxedDataType tys_left
 638     then pprPanic "Specialise:checkSpecOK: unboxed type args in specialised application\n"
 639                   (ppAboves [ppCat [ppr PprDebug check_id,
 640                                     ppInterleave ppNil (map (pprParendUniType PprDebug) tys)],
 641                              ppCat [ppr PprDebug spec_id,
 642                                     ppInterleave ppNil (map (pprParendUniType PprDebug) tys_left)]])
 643     else id
 644 \end{code}
 645
 646 \begin{code}
 647 mkTyConInstance :: Id
 648                 -> [UniType]
 649                 -> SpecM UsageDetails
 650 mkTyConInstance con tys
 651   = recordTyConInst con tys     `thenSM` \ record_inst ->
 652     case record_inst of
 653       Nothing                           -- No TyCon instance
 654         -> -- pprTrace "NoTyConInst:"
 655            -- (ppCat [ppr PprDebug tycon, ppStr "at",
 656            --         ppr PprDebug con, ppCat (map (ppr PprDebug) tys)])
 657            (returnSM (singleConUDs con))
 658
 659       Just spec_tys                     -- Record TyCon instance
 660         -> -- pprTrace "TyConInst:"
 661            -- (ppCat [ppr PprDebug tycon, ppStr "at",
 662            --         ppr PprDebug con, ppCat (map (ppr PprDebug) tys),
 663            --         ppBesides [ppStr "(",
 664            --                    ppCat [pprMaybeTy PprDebug ty | ty <- spec_tys],
 665            --                    ppStr ")"]])
 666            (returnSM (singleTyConI tycon spec_tys `unionUDs` singleConUDs con))
 667   where
 668     tycon = getDataConTyCon con
 669 \end{code}
 670
 671 \begin{code}
 672 recordTyConInst :: Id
 673                 -> [UniType]
 674                 -> SpecM (Maybe [Maybe UniType])
 675
 676 recordTyConInst con tys
 677   = let
 678         spec_tys = specialiseConstrTys tys
 679
 680         do_tycon_spec = maybeToBool (firstJust spec_tys)
 681
 682         spec_exists = maybeToBool (lookupSpecEnv
 683                                       (getIdSpecialisation con)
 684                                       tys)
 685     in
 686     -- pprTrace "ConSpecExists?: "
 687     -- (ppAboves [ppStr (if spec_exists then "True" else "False"),
 688     --            ppr PprShowAll con, ppCat (map (ppr PprDebug) tys)])
 689     (if (not spec_exists && do_tycon_spec)
 690      then returnSM (Just spec_tys)
 691      else returnSM Nothing)
 692 \end{code}
 693