import OccName ( occNameString, occNameFS )
import BasicTypes ( Arity )
import StaticFlags ( opt_RuntimeTypes )
-import PackageConfig ( PackageId )
+import Module
import Outputable
infixr 9 `thenLne`
(getLiveVars alts_lv_info)
bndr'
(mkSRT alts_lv_info)
- (mkStgAltType (idType bndr) alts)
+ (mkStgAltType bndr alts)
alts2,
scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
\end{code}
\begin{code}
-mkStgAltType scrut_ty alts
- = case splitTyConApp_maybe (repType scrut_ty) of
+mkStgAltType bndr alts
+ = case splitTyConApp_maybe (repType (idType bndr)) of
Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc
| isUnLiftedTyCon tc -> PrimAlt tc
| isHiBootTyCon tc -> look_for_better_tycon
| isAlgTyCon tc -> AlgAlt tc
- | isFunTyCon tc -> PolyAlt
- | isPrimTyCon tc -> PolyAlt -- for "Any"
- | otherwise -> pprPanic "mkStgAlts" (ppr tc)
+ | otherwise -> ASSERT( _is_poly_alt_tycon tc )
+ PolyAlt
Nothing -> PolyAlt
where
- -- Sometimes, the TyCon in the type of the scrutinee is an HiBootTyCon,
- -- which may not have any constructors inside it. If so, then we
- -- can get a better TyCon by grabbing the one from a constructor alternative
+ _is_poly_alt_tycon tc
+ = isFunTyCon tc
+ || isPrimTyCon tc -- "Any" is lifted but primitive
+ || isOpenTyCon tc -- Type family; e.g. arising from strict
+ -- function application where argument has a
+ -- type-family type
+
+ -- Sometimes, the TyCon is a HiBootTyCon which may not have any
+ -- constructors inside it. Then we can get a better TyCon by
+ -- grabbing the one from a constructor alternative
-- if one exists.
look_for_better_tycon
| ((DataAlt con, _, _) : _) <- data_alts =
let
arg_ty = exprType arg
stg_arg_ty = stgArgType stg_arg
+ bad_args = (isUnLiftedType arg_ty && not (isUnLiftedType stg_arg_ty))
+ || (typePrimRep arg_ty /= typePrimRep stg_arg_ty)
+ -- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted),
+ -- and pass it to a function expecting an HValue (arg_ty). This is ok because
+ -- we can treat an unlifted value as lifted. But the other way round
+ -- we complain.
+ -- We also want to check if a pointer is cast to a non-ptr etc
in
- WARN( isUnLiftedType arg_ty /= isUnLiftedType stg_arg_ty,
- ptext SLIT("Dangerous-looking argument. Probable cause: bad unsafeCoerce#") $$ ppr arg)
+ WARN( bad_args, ptext SLIT("Dangerous-looking argument. Probable cause: bad unsafeCoerce#") $$ ppr arg )
returnLne (stg_arg : stg_args, fvs)