- (if opt_SpecialiseTrace then
- pprTrace "Specialising:"
- (ppHang (ppBesides [ppStr "{",
- interppSP PprDebug new_ids,
- ppStr "}"])
- 4 (ppAboves [
- ppBesides [ppStr "types: ", ppInterleave ppNil (map pp_ty arg_tys)],
- if isExplicitCI do_cis then ppNil else
- ppBesides [ppStr "dicts: ", ppInterleave ppNil (map pp_dict dict_args)],
- ppBesides [ppStr "specs: ", ppr PprDebug spec_ids]]))
- else id) (
-
- do_bind orig_bind `thenSM` \ (maybe_inst_bind, inst_uds, spec_infos) ->
-
- returnSM (maybe_inst_bind, inst_uds, spec_infos)
- )
- where
- pp_dict d = ppr_arg PprDebug d
- pp_ty t = pprParendGenType PprDebug t
-
- do_the_wotsit (tyvar:tyvars) Nothing = (tyvars, mkTyVarTy tyvar)
- do_the_wotsit tyvars (Just ty) = (tyvars, ty)
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Misc]{Miscellaneous junk}
-%* *
-%************************************************************************
-
-\begin{code}
-mkCallInstance :: Id
- -> Id
- -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)]
- -> SpecM UsageDetails
-
-mkCallInstance id new_id []
- = returnSM emptyUDs
-
-mkCallInstance id new_id args
-
- -- No specialised versions for "error" and friends are req'd.
- -- This is a special case in core lint etc.
-
- | isBottomingId id
- = returnSM emptyUDs
-
- -- No call instances for SuperDictSelIds
- -- These are a special case in mkCall
-
- | maybeToBool (isSuperDictSelId_maybe id)
- = returnSM emptyUDs
-
- -- There are also no call instances for ClassOpIds
- -- However, we need to process it to get any second-level call
- -- instances for a ConstMethodId extracted from its SpecEnv
-
- | otherwise
- = let
- spec_overloading = opt_SpecialiseOverloaded
- spec_unboxed = opt_SpecialiseUnboxed
- spec_all = opt_SpecialiseAll
-
- (tyvars, class_tyvar_pairs) = getIdOverloading id
-
- arg_res = take_type_args tyvars class_tyvar_pairs args
- enough_args = maybeToBool arg_res
-
- (Just (tys, dicts, rest_args)) = arg_res
-
- record_spec id tys
- = (record, lookup, spec_tys)
- where
- spec_tys = specialiseCallTys spec_all spec_unboxed spec_overloading
- (mkConstraintVector id) tys
-
- record = any (not . isTyVarTy) (catMaybes spec_tys)
-
- lookup = lookupSpecEnv (getIdSpecialisation id) tys
- in
- if (not enough_args) then
- pprPanic "Specialise:recordCallInst: Unsaturated Type & Dict Application:\n\t"
- (ppCat (ppr PprDebug id : map (ppr_arg PprDebug) [arg | (arg,_,_) <- args]))
- else
- case record_spec id tys of
- (False, _, _)
- -> -- pprTrace "CallInst:NotReqd\n"
- -- (ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)])
- (returnSM emptyUDs)
-
- (True, Nothing, spec_tys)
- -> if isClassOpId id then -- No CIs for class ops, dfun will give SPEC inst
- returnSM emptyUDs
- else
- -- pprTrace "CallInst:Reqd\n"
- -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
- -- ppCat [ppStr "CI", ppCat (map (pprMaybeTy PprDebug) spec_tys),
- -- ppCat (map (ppr PprDebug) dicts)]])
- (returnSM (singleCI new_id spec_tys dicts))
-
- (True, Just (spec_id, tys_left, toss), _)
- -> if maybeToBool (isConstMethodId_maybe spec_id) then
- -- If we got a const method spec_id see if further spec required
- -- NB: const method is top-level so spec_id will not be cloned
- case record_spec spec_id tys_left of
- (False, _, _)
- -> -- pprTrace "CallInst:Exists\n"
- -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
- -- ppCat [ppStr "->", ppr PprDebug spec_id,
- -- ppr PprDebug (tys_left ++ drop toss dicts)]])
- (returnSM emptyUDs)
-
- (True, Nothing, spec_tys)
- -> -- pprTrace "CallInst:Exists:Reqd\n"
- -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
- -- ppCat [ppStr "->", ppr PprDebug spec_id,
- -- ppr PprDebug (tys_left ++ drop toss dicts)],
- -- ppCat [ppStr "CI", ppCat (map (pprMaybeTy PprDebug) spec_tys),
- -- ppCat (map (ppr PprDebug) (drop toss dicts))]])
- (returnSM (singleCI spec_id spec_tys (drop toss dicts)))
-
- (True, Just (spec_spec_id, tys_left_left, toss_toss), _)
- -> -- pprTrace "CallInst:Exists:Exists\n"
- -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
- -- ppCat [ppStr "->", ppr PprDebug spec_id,
- -- ppr PprDebug (tys_left ++ drop toss dicts)],
- -- ppCat [ppStr "->", ppr PprDebug spec_spec_id,
- -- ppr PprDebug (tys_left_left ++ drop (toss + toss_toss) dicts)]])
- (returnSM emptyUDs)
-
- else
- -- pprTrace "CallInst:Exists\n"
- -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)],
- -- ppCat [ppStr "->", ppr PprDebug spec_id,
- -- ppr PprDebug (tys_left ++ drop toss dicts)]])
- (returnSM emptyUDs)
-
-
-take_type_args (_:tyvars) class_tyvar_pairs ((TyArg ty,_,_):args)
- = case (take_type_args tyvars class_tyvar_pairs args) of
- Nothing -> Nothing
- Just (tys, dicts, others) -> Just (ty:tys, dicts, others)
-
-take_type_args (_:tyvars) class_tyvar_pairs [] = Nothing
-
-take_type_args [] class_tyvar_pairs args
- = case (take_dict_args class_tyvar_pairs args) of
- Nothing -> Nothing
- Just (dicts, others) -> Just ([], dicts, others)
-
-take_dict_args (_:class_tyvar_pairs) ((dict,_,_):args) | isValArg dict
- = case (take_dict_args class_tyvar_pairs args) of
- Nothing -> Nothing
- Just (dicts, others) -> Just (dict:dicts, others)
-
-take_dict_args (_:class_tyvar_pairs) [] = Nothing
-
-take_dict_args [] args = Just ([], args)
-\end{code}
-
-\begin{code}
-mkCall :: Id
- -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)]
- -> SpecM CoreExpr
-
-mkCall new_id arg_infos = returnSM (mkGenApp (Var new_id) [arg | (arg, _, _) <- arg_infos])
-
-{-
- | maybeToBool (isSuperDictSelId_maybe new_id)
- && any isUnboxedType ty_args
- -- No specialisations for super-dict selectors
- -- Specialise unboxed calls to SuperDictSelIds by extracting
- -- the super class dictionary directly form the super class
- -- NB: This should be dead code since all uses of this dictionary should
- -- have been specialised. We only do this to keep core-lint happy.
- = let
- Just (_, super_class) = isSuperDictSelId_maybe new_id
- super_dict_id = case lookupClassInstAtSimpleType super_class (head ty_args) of
- Nothing -> panic "Specialise:mkCall:SuperDictId"
- Just id -> id
- in
- returnSM (False, Var super_dict_id)
-
- | otherwise
- = case lookupSpecEnv (getIdSpecialisation new_id) ty_args of
- Nothing -> checkUnspecOK new_id ty_args (
- returnSM (False, unspec_call)
- )
-
- Just spec_1_details@(spec_id_1, tys_left_1, dicts_to_toss_1)
- -> let
- -- It may be necessary to specialsie a constant method spec_id again
- (spec_id, tys_left, dicts_to_toss) =
- case (maybeToBool (isConstMethodId_maybe spec_id_1),
- lookupSpecEnv (getIdSpecialisation spec_id_1) tys_left_1) of
- (False, _ ) -> spec_1_details
- (True, Nothing) -> spec_1_details
- (True, Just (spec_id_2, tys_left_2, dicts_to_toss_2))
- -> (spec_id_2, tys_left_2, dicts_to_toss_1 + dicts_to_toss_2)
-
- args_left = toss_dicts dicts_to_toss val_args
- in
- checkSpecOK new_id ty_args spec_id tys_left (
-
- -- The resulting spec_id may be a top-level unboxed value
- -- This can arise for:
- -- 1) constant method values
- -- eq: class Num a where pi :: a
- -- instance Num Double# where pi = 3.141#
- -- 2) specilised overloaded values
- -- eq: i1 :: Num a => a
- -- i1 Int# d.Num.Int# ==> i1.Int#
- -- These top level defns should have been lifted.
- -- We must add code to unlift such a spec_id.
-
- if isUnboxedType (idType spec_id) then
- ASSERT (null tys_left && null args_left)
- if toplevelishId spec_id then
- liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) ->
- returnSM (True, bindUnlift lift_spec_id unlift_spec_id
- (Var unlift_spec_id))
- else
- pprPanic "Specialise:mkCall: unboxed spec_id not top-level ...\n"
- (ppCat [ppr PprDebug new_id,
- ppInterleave ppNil (map (pprParendGenType PprDebug) ty_args),
- ppStr "==>",
- ppr PprDebug spec_id])
- else
- let
- (vals_left, _, unlifts_left) = unzip3 args_left
- applied_tys = mkTyApp (Var spec_id) tys_left
- applied_vals = mkGenApp applied_tys vals_left
- in
- returnSM (True, applyBindUnlifts unlifts_left applied_vals)
- )
- where
- (tys_and_vals, _, unlifts) = unzip3 args
- unspec_call = applyBindUnlifts unlifts (mkGenApp (Var new_id) tys_and_vals)
-
-
- -- ty_args is the types at the front of the arg list
- -- val_args is the rest of the arg-list
-
- (ty_args, val_args) = get args
- where
- get ((TyArg ty,_,_) : args) = (ty : tys, rest) where (tys,rest) = get args
- get args = ([], args)
-