slopSize,
closureName, infoTableLabelFromCI,
- closureLabelFromCI, closureSRT,
+ closureLabelFromCI,
closureLFInfo, isLFThunk,closureSMRep, closureUpdReqd,
closureNeedsUpdSpace, closureIsThunk,
closureSingleEntry, closureReEntrant, isConstrClosure_maybe,
closureValDescr, closureTypeDescr, -- profiling
isStaticClosure,
- cafBlackHoleClosureInfo, seCafBlackHoleClosureInfo,
+ cafBlackHoleClosureInfo,
staticClosureNeedsLink,
) where
import PackageConfig
import StaticFlags
import Id
+import IdInfo
import DataCon
import Name
import OccName
Int -- Its arity
getCallMethod :: Name -- Function being applied
+ -> CafInfo -- Can it refer to CAF's?
-> LambdaFormInfo -- Its info
-> Int -- Number of available arguments
-> CallMethod
-getCallMethod name lf_info n_args
+getCallMethod name _ lf_info n_args
| nodeMustPointToIt lf_info && opt_Parallel
= -- If we're parallel, then we must always enter via node.
-- The reason is that the closure may have been
-- fetched since we allocated it.
EnterIt
-getCallMethod name (LFReEntrant _ arity _ _) n_args
+getCallMethod name caf (LFReEntrant _ arity _ _) n_args
| n_args == 0 = ASSERT( arity /= 0 )
ReturnIt -- No args at all
| n_args < arity = SlowCall -- Not enough args
- | otherwise = DirectEntry (enterIdLabel name) arity
+ | otherwise = DirectEntry (enterIdLabel name caf) arity
-getCallMethod name (LFCon con) n_args
+getCallMethod name _ (LFCon con) n_args
= ASSERT( n_args == 0 )
ReturnCon con
-getCallMethod name (LFThunk _ _ updatable std_form_info is_fun) n_args
+getCallMethod name caf (LFThunk _ _ updatable std_form_info is_fun) n_args
| is_fun -- it *might* be a function, so we must "call" it (which is
-- always safe)
= SlowCall -- We cannot just enter it [in eval/apply, the entry code
| otherwise -- Jump direct to code for single-entry thunks
= ASSERT( n_args == 0 )
- JumpToIt (thunkEntryLabel name std_form_info updatable)
+ JumpToIt (thunkEntryLabel name caf std_form_info updatable)
-getCallMethod name (LFUnknown True) n_args
- = SlowCall -- might be a function
+getCallMethod name _ (LFUnknown True) n_args
+ = SlowCall -- Might be a function
-getCallMethod name (LFUnknown False) n_args
- = ASSERT2 ( n_args == 0, ppr name <+> ppr n_args )
- EnterIt -- Not a function
+getCallMethod name _ (LFUnknown False) n_args
+ | n_args > 0
+ = WARN( True, ppr name <+> ppr n_args )
+ SlowCall -- Note [Unsafe coerce complications]
-getCallMethod name (LFBlackHole _) n_args
+ | otherwise
+ = EnterIt -- Not a function
+
+getCallMethod name _ (LFBlackHole _) n_args
= SlowCall -- Presumably the black hole has by now
-- been updated, but we don't know with
-- what, so we slow call it
-getCallMethod name (LFLetNoEscape 0) n_args
+getCallMethod name _ (LFLetNoEscape 0) n_args
= JumpToIt (enterReturnPtLabel (nameUnique name))
-getCallMethod name (LFLetNoEscape arity) n_args
+getCallMethod name _ (LFLetNoEscape arity) n_args
| n_args == arity = DirectEntry (enterReturnPtLabel (nameUnique name)) arity
| otherwise = pprPanic "let-no-escape: " (ppr name <+> ppr arity)
isKnownFun _ = False
\end{code}
+Note [Unsafe coerce complications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In some (badly-optimised) DPH code we see this
+ Module X: rr :: Int = error Int "Urk"
+ Module Y: ...((X.rr |> g) True) ...
+ where g is an (unsafe) coercion of kind (Int ~ Bool->Bool), say
+
+It's badly optimised, because knowing that 'X.rr' is bottom, we should
+have dumped the application to True. But it should still work. These
+strange unsafe coercions arise from the case-of-error transformation:
+ (case (error Int "foo") of { ... }) True
+---> (error Int "foo" |> g) True
+
+Anyway, the net effect is that in STG-land, when casts are discarded,
+we *can* see a value of type Int applied to an argument. This only happens
+if (a) the programmer made a mistake, or (b) the value of type Int is
+actually bottom.
+
+So it's wrong to trigger an ASSERT failure in this circumstance. Instead
+we now emit a WARN -- mainly to draw attention to a probably-badly-optimised
+program fragment -- and do the conservative thing which is SlowCall.
+
+
-----------------------------------------------------------------------------
SRT-related stuff
Label generation.
\begin{code}
-infoTableLabelFromCI :: ClosureInfo -> CLabel
+infoTableLabelFromCI :: ClosureInfo -> CafInfo -> CLabel
infoTableLabelFromCI (ClosureInfo { closureName = name,
closureLFInfo = lf_info,
- closureSMRep = rep })
+ closureSMRep = rep }) caf
= case lf_info of
LFBlackHole info -> info
LFThunk _ _ upd_flag (ApThunk arity) _ ->
mkApInfoTableLabel upd_flag arity
- LFThunk{} -> mkLocalInfoTableLabel name
+ LFThunk{} -> mkLocalInfoTableLabel name caf
- LFReEntrant _ _ _ _ -> mkLocalInfoTableLabel name
+ LFReEntrant _ _ _ _ -> mkLocalInfoTableLabel name caf
other -> panic "infoTableLabelFromCI"
infoTableLabelFromCI (ConInfo { closureCon = con,
- closureSMRep = rep })
- | isStaticRep rep = mkStaticInfoTableLabel name
- | otherwise = mkConInfoTableLabel name
+ closureSMRep = rep }) caf
+ | isStaticRep rep = mkStaticInfoTableLabel name caf
+ | otherwise = mkConInfoTableLabel name caf
where
name = dataConName con
-- ClosureInfo for a closure (as opposed to a constructor) is always local
-closureLabelFromCI (ClosureInfo { closureName = nm }) = mkLocalClosureLabel nm
-closureLabelFromCI _ = panic "closureLabelFromCI"
+closureLabelFromCI (ClosureInfo { closureName = nm }) caf = mkLocalClosureLabel nm caf
+closureLabelFromCI _ _ = panic "closureLabelFromCI"
-- thunkEntryLabel is a local help function, not exported. It's used from both
-- entryLabelFromCI and getCallMethod.
-thunkEntryLabel thunk_id (ApThunk arity) is_updatable
+thunkEntryLabel thunk_id _ (ApThunk arity) is_updatable
= enterApLabel is_updatable arity
-thunkEntryLabel thunk_id (SelectorThunk offset) upd_flag
+thunkEntryLabel thunk_id _ (SelectorThunk offset) upd_flag
= enterSelectorLabel upd_flag offset
-thunkEntryLabel thunk_id _ is_updatable
- = enterIdLabel thunk_id
+thunkEntryLabel thunk_id caf _ is_updatable
+ = enterIdLabel thunk_id caf
enterApLabel is_updatable arity
| tablesNextToCode = mkApInfoTableLabel is_updatable arity
closureType = ty,
closureDescr = "" }
cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo"
-
-seCafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
- closureType = ty })
- = ClosureInfo { closureName = nm,
- closureLFInfo = LFBlackHole mkSECAFBlackHoleInfoTableLabel,
- closureSMRep = BlackHoleRep,
- closureSRT = NoC_SRT,
- closureType = ty,
- closureDescr = "" }
-seCafBlackHoleClosureInfo _ = panic "seCafBlackHoleClosureInfo"
\end{code}
%************************************************************************
projects / ghc-hetmet.git / blobdiff