import Type
import TyCon ( isAlgTyCon )
-import Literal
import Id
-import Var ( Var, globalIdDetails, varType )
+import Var ( Var, globalIdDetails, idType )
+import TyCon ( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon, isHiBootTyCon )
#ifdef ILX
import MkId ( unsafeCoerceId )
#endif
= StgRhsCon noCCS con args
mkTopStgRhs is_static rhs_fvs srt binder_info rhs
- = ASSERT( not is_static )
+ = ASSERT2( not is_static, ppr rhs )
StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
Updatable
coreToStgExpr (Case scrut bndr alts)
= extendVarEnvLne [(bndr, LambdaBound)] (
mapAndUnzip3Lne vars_alt alts `thenLne` \ (alts2, fvs_s, escs_s) ->
- returnLne ( mkStgAlts (idType bndr) alts2,
+ returnLne ( alts2,
unionFVInfos fvs_s,
unionVarSets escs_s )
) `thenLne` \ (alts2, alts_fvs, alts_escs) ->
(getLiveVars alts_lv_info)
bndr'
(mkSRT alts_lv_info)
+ (mkStgAltType (idType bndr))
alts2,
scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
\end{code}
\begin{code}
-mkStgAlts scrut_ty orig_alts
- | is_prim_case = StgPrimAlts (tyConAppTyCon scrut_ty) prim_alts deflt
- | otherwise = StgAlgAlts maybe_tycon alg_alts deflt
- where
- is_prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
-
- prim_alts = [(lit, rhs) | (LitAlt lit, _, _, rhs) <- other_alts]
- alg_alts = [(con, bndrs, use, rhs) | (DataAlt con, bndrs, use, rhs) <- other_alts]
-
- (other_alts, deflt)
- = case orig_alts of -- DEFAULT is always first if it's there at all
- (DEFAULT, _, _, rhs) : other_alts -> (other_alts, StgBindDefault rhs)
- other -> (orig_alts, StgNoDefault)
-
- maybe_tycon = case alg_alts of
- -- Get the tycon from the data con
- (dc, _, _, _) : _rest -> Just (dataConTyCon dc)
-
- -- Otherwise just do your best
- [] -> case splitTyConApp_maybe (repType scrut_ty) of
- Just (tc,_) | isAlgTyCon tc -> Just tc
- _other -> Nothing
+mkStgAltType scrut_ty
+ = case splitTyConApp_maybe (repType scrut_ty) of
+ Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc
+ | isPrimTyCon tc -> PrimAlt tc
+ | isHiBootTyCon tc -> PolyAlt -- Algebraic, but no constructors visible
+ | isAlgTyCon tc -> AlgAlt tc
+ | isFunTyCon tc -> PolyAlt
+ | otherwise -> pprPanic "mkStgAlts" (ppr tc)
+ Nothing -> PolyAlt
\end{code}
-- Here the free variables are "f", "x" AND the type variable "a"
-- coreToStgArgs will deal with the arguments recursively
if opt_RuntimeTypes then
- fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (varType f))
+ fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (idType f))
else fvs
-- Mostly, the arity info of a function is in the fn's IdInfo
thenLne m k env lvs_cont
= k (m env lvs_cont) env lvs_cont
-mapLne :: (a -> LneM b) -> [a] -> LneM [b]
-mapLne f [] = returnLne []
-mapLne f (x:xs)
- = f x `thenLne` \ r ->
- mapLne f xs `thenLne` \ rs ->
- returnLne (r:rs)
-
mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c])
-
mapAndUnzipLne f [] = returnLne ([],[])
mapAndUnzipLne f (x:xs)
= f x `thenLne` \ (r1, r2) ->
returnLne (r1:rs1, r2:rs2)
mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
-
mapAndUnzip3Lne f [] = returnLne ([],[],[])
mapAndUnzip3Lne f (x:xs)
= f x `thenLne` \ (r1, r2, r3) ->
returnLne (r1:rs1, r2:rs2, r3:rs3)
mapAndUnzip4Lne :: (a -> LneM (b,c,d,e)) -> [a] -> LneM ([b],[c],[d],[e])
-
mapAndUnzip4Lne f [] = returnLne ([],[],[],[])
mapAndUnzip4Lne f (x:xs)
= f x `thenLne` \ (r1, r2, r3, r4) ->