-mkCallInstance old_id new_id args
- = recordCallInst old_id args `thenSM` \ record_call ->
- case record_call of
- Nothing -- No specialisation required
- -> -- pprTrace "NoSpecReqd:"
- -- (ppCat [ppr PprDebug old_id, ppStr "at", ppCat (map (ppr PprDebug) args)])
-
- (returnSM call_fv_uds)
-
- Just (True, spec_tys, dict_args, rest_args) -- Requires specialisation: spec already exists
- -> -- pprTrace "SpecExists:"
- -- (ppCat [ppr PprDebug old_id, ppStr " at ", ppCat (map (ppr PprDebug) args),
- -- ppBesides [ppStr "(", ppCat [pprMaybeTy PprDebug ty | ty <- spec_tys],
- -- ppCat [ppr PprDebug dict | dict <- dict_args],
- -- ppStr ")"]])
-
- (returnSM call_fv_uds)
-
- Just (False, spec_tys, dict_args, rest_args) -- Requires specialisation: record call-instance
- -> -- pprTrace "CallInst:"
- -- (ppCat [ppr PprDebug old_id, ppStr " at ", ppCat (map (ppr PprDebug) args),
- -- ppBesides [ppStr "(", ppCat [pprMaybeTy PprDebug ty | ty <- spec_tys],
- -- ppCat [ppr PprDebug dict | dict <- dict_args],
- -- ppStr ")"]])
-
- (returnSM (singleCI new_id spec_tys dict_args `unionUDs` call_fv_uds))
- where
- call_fv_uds = singleFvUDs (CoVarAtom new_id) `unionUDs` unionUDList [uds | (_,uds,_) <- args]
-\end{code}
-
-\begin{code}
-recordCallInst :: Id
- -> [(PlainCoreArg, UsageDetails, PlainCoreExpr -> PlainCoreExpr)]
- -> SpecM (Maybe (Bool, [Maybe UniType], [PlainCoreArg],
- [(PlainCoreArg, UsageDetails, PlainCoreExpr -> PlainCoreExpr)]))
-
-recordCallInst id [] -- No args => no call instance
- = returnSM Nothing
-
-recordCallInst id args
- | isBottomingId id -- No specialised versions for "error" and friends are req'd.
- = returnSM Nothing -- This is a special case in core lint etc.
-
- -- No call instances for Ids associated with a Class declaration,
- -- i.e. default methods, super-dict selectors and class ops.
- -- We rely on the instance declarations to provide suitable specialisations.
- -- These are dealt with in mkCall.
-
- | isDefaultMethodId id
- = returnSM Nothing
-
- | maybeToBool (isSuperDictSelId_maybe id)
- = returnSM Nothing
-
- | isClassOpId id
- = returnSM Nothing
-
- -- Finally, the default case ...
-
- | otherwise
- = getSwitchCheckerSM `thenSM` \ sw_chkr ->
- let
- spec_overloading = sw_chkr SpecialiseOverloaded
- spec_unboxed = sw_chkr SpecialiseUnboxed
- spec_all = sw_chkr SpecialiseAll
-
- (tyvar_tmpls, class_tyvar_pairs) = getIdOverloading id
- constraint_vec = mkConstraintVector tyvar_tmpls class_tyvar_pairs
-
- arg_res = take_type_args tyvar_tmpls class_tyvar_pairs args
- enough_args = maybeToBool arg_res
-
- (Just (inst_tys, dict_args, rest_args)) = arg_res
- spec_tys = specialiseCallTys spec_all spec_unboxed spec_overloading
- constraint_vec inst_tys
-
- spec_exists = maybeToBool (lookupSpecEnv
- (getIdSpecialisation id)
- inst_tys)
-
- -- We record the call instance if there is some meaningful
- -- type which we want to specialise on ...
- record_spec = any (not . isTyVarTy) (catMaybes spec_tys)
- in
- if (not enough_args) then
- pprPanic "Specialise:recordCallInst: Unsaturated Type & Dict Application:\n\t"
- (ppCat [ppr PprDebug id, ppr PprDebug [arg | (arg,_,_) <- args] ])
- else
- if record_spec then
- returnSM (Just (spec_exists, spec_tys, dict_args, rest_args))
- else
- returnSM Nothing
-
-
-take_type_args (_:tyvars) class_tyvar_pairs ((TypeArg 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@(ValArg _),_,_):args)
- = 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
- -> [(PlainCoreArg, UsageDetails, PlainCoreExpr -> PlainCoreExpr)]
- -> SpecM PlainCoreExpr
-
-mkCall main_id args
- | isDefaultMethodId main_id
- && any isUnboxedDataType ty_args
- -- No specialisations for default methods
- -- Unboxed calls to DefaultMethodIds should not occur
- -- The method should be specified in the instance declaration
- = panic "Specialise:mkCall:DefaultMethodId"
-
- | maybeToBool (isSuperDictSelId_maybe main_id)
- && any isUnboxedDataType 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 keep core-lint happy.
- = let
- Just (_, super_class) = isSuperDictSelId_maybe main_id
- super_dict_id = case lookupClassInstAtSimpleType super_class (head ty_args) of
- Nothing -> panic "Specialise:mkCall:SuperDictId"
- Just id -> id
- in
- returnSM (CoVar super_dict_id)