summaryrefslogtreecommitdiff
path: root/compiler/stgSyn
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/stgSyn')
-rw-r--r--compiler/stgSyn/CoreToStg.hs33
-rw-r--r--compiler/stgSyn/StgLint.hs34
-rw-r--r--compiler/stgSyn/StgSyn.hs18
3 files changed, 46 insertions, 39 deletions
diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs
index 5531d31d30..dcb923afea 100644
--- a/compiler/stgSyn/CoreToStg.hs
+++ b/compiler/stgSyn/CoreToStg.hs
@@ -472,16 +472,25 @@ coreToStgExpr (Let bind body) = do
coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e)
mkStgAltType :: Id -> [CoreAlt] -> AltType
-mkStgAltType bndr alts = case repType (idType bndr) of
- UnaryRep rep_ty -> case tyConAppTyCon_maybe rep_ty of
- Just tc | isUnliftedTyCon tc -> PrimAlt tc
- | isAbstractTyCon tc -> look_for_better_tycon
- | isAlgTyCon tc -> AlgAlt tc
- | otherwise -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
- PolyAlt
- Nothing -> PolyAlt
- MultiRep slots -> MultiValAlt (length slots)
+mkStgAltType bndr alts
+ | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty
+ = MultiValAlt (length prim_reps) -- always use MultiValAlt for unboxed tuples
+
+ | otherwise
+ = case prim_reps of
+ [LiftedRep] -> case tyConAppTyCon_maybe (unwrapType bndr_ty) of
+ Just tc
+ | isAbstractTyCon tc -> look_for_better_tycon
+ | isAlgTyCon tc -> AlgAlt tc
+ | otherwise -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
+ PolyAlt
+ Nothing -> PolyAlt
+ [unlifted] -> PrimAlt unlifted
+ not_unary -> MultiValAlt (length not_unary)
where
+ bndr_ty = idType bndr
+ prim_reps = typePrimRep bndr_ty
+
_is_poly_alt_tycon tc
= isFunTyCon tc
|| isPrimTyCon tc -- "Any" is lifted but primitive
@@ -650,8 +659,7 @@ coreToStgArgs (arg : args) = do -- Non-type argument
arg_ty = exprType arg
stg_arg_ty = stgArgType stg_arg
bad_args = (isUnliftedType arg_ty && not (isUnliftedType stg_arg_ty))
- || (map typePrimRep (repTypeArgs arg_ty)
- /= map typePrimRep (repTypeArgs 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
@@ -802,7 +810,8 @@ mkStgRhs' con_updateable rhs_fvs bndr binder_info rhs
| StgConApp con args _ <- unticked_rhs
, not (con_updateable con args)
= -- CorePrep does this right, but just to make sure
- ASSERT(not (isUnboxedTupleCon con || isUnboxedSumCon con))
+ ASSERT2( not (isUnboxedTupleCon con || isUnboxedSumCon con)
+ , ppr bndr $$ ppr con $$ ppr args)
StgRhsCon noCCS con args
| otherwise
= StgRhsClosure noCCS binder_info
diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs
index 0dba8d8359..e31e7ae015 100644
--- a/compiler/stgSyn/StgLint.hs
+++ b/compiler/stgSyn/StgLint.hs
@@ -196,21 +196,19 @@ lintStgExpr (StgCase scrut bndr alts_type alts) = runMaybeT $ do
in_scope <- MaybeT $ liftM Just $
case alts_type of
- AlgAlt tc -> check_bndr tc >> return True
- PrimAlt tc -> check_bndr tc >> return True
+ AlgAlt tc -> check_bndr (tyConPrimRep tc) >> return True
+ PrimAlt rep -> check_bndr [rep] >> return True
MultiValAlt _ -> return False -- Binder is always dead in this case
PolyAlt -> return True
MaybeT $ addInScopeVars [bndr | in_scope] $
lintStgAlts alts scrut_ty
where
- scrut_ty = idType bndr
- UnaryRep scrut_rep = repType scrut_ty -- Not used if scrutinee is unboxed tuple or sum
- check_bndr tc = case tyConAppTyCon_maybe scrut_rep of
- Just bndr_tc -> checkL (tc == bndr_tc) bad_bndr
- Nothing -> addErrL bad_bndr
+ scrut_ty = idType bndr
+ scrut_reps = typePrimRep scrut_ty
+ check_bndr reps = checkL (scrut_reps == reps) bad_bndr
where
- bad_bndr = mkDefltMsg bndr tc
+ bad_bndr = mkDefltMsg bndr reps
lintStgAlts :: [StgAlt]
-> Type -- Type of scrutinee
@@ -418,20 +416,18 @@ stgEqType :: Type -> Type -> Bool
-- Fundamentally this is a losing battle because of unsafeCoerce
stgEqType orig_ty1 orig_ty2
- = gos (repType orig_ty1) (repType orig_ty2)
+ = gos (typePrimRep orig_ty1) (typePrimRep orig_ty2)
where
- gos :: RepType -> RepType -> Bool
- gos (MultiRep slots1) (MultiRep slots2)
- = slots1 == slots2
- gos (UnaryRep ty1) (UnaryRep ty2) = go ty1 ty2
- gos _ _ = False
+ gos :: [PrimRep] -> [PrimRep] -> Bool
+ gos [_] [_] = go orig_ty1 orig_ty2
+ gos reps1 reps2 = reps1 == reps2
go :: UnaryType -> UnaryType -> Bool
go ty1 ty2
| Just (tc1, tc_args1) <- splitTyConApp_maybe ty1
, Just (tc2, tc_args2) <- splitTyConApp_maybe ty2
, let res = if tc1 == tc2
- then equalLength tc_args1 tc_args2 && and (zipWith (gos `on` repType) tc_args1 tc_args2)
+ then equalLength tc_args1 tc_args2 && and (zipWith (gos `on` typePrimRep) tc_args1 tc_args2)
else -- TyCons don't match; but don't bleat if either is a
-- family TyCon because a coercion might have made it
-- equal to something else
@@ -462,10 +458,10 @@ _mkCaseAltMsg _alts
= ($$) (text "In some case alternatives, type of alternatives not all same:")
(Outputable.empty) -- LATER: ppr alts
-mkDefltMsg :: Id -> TyCon -> MsgDoc
-mkDefltMsg bndr tc
- = ($$) (text "Binder of a case expression doesn't match type of scrutinee:")
- (ppr bndr $$ ppr (idType bndr) $$ ppr tc)
+mkDefltMsg :: Id -> [PrimRep] -> MsgDoc
+mkDefltMsg bndr reps
+ = ($$) (text "Binder of a case expression doesn't match representation of scrutinee:")
+ (ppr bndr $$ ppr (idType bndr) $$ ppr reps)
mkFunAppMsg :: Type -> [Type] -> StgExpr -> MsgDoc
mkFunAppMsg fun_ty arg_tys expr
diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs
index 64c8448421..48e836cc56 100644
--- a/compiler/stgSyn/StgSyn.hs
+++ b/compiler/stgSyn/StgSyn.hs
@@ -62,7 +62,7 @@ import PprCore ( {- instances -} )
import PrimOp ( PrimOp, PrimCall )
import TyCon ( PrimRep(..), TyCon )
import Type ( Type )
-import RepType ( typePrimRep )
+import RepType ( typePrimRep1 )
import Unique ( Unique )
import Util
@@ -104,10 +104,10 @@ isDllConApp dflags this_mod con args
= isDllName dflags this_mod (dataConName con) || any is_dll_arg args
| otherwise = False
where
- -- NB: typePrimRep is legit because any free variables won't have
+ -- NB: typePrimRep1 is legit because any free variables won't have
-- unlifted type (there are no unlifted things at top level)
is_dll_arg :: StgArg -> Bool
- is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep (idType v))
+ is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep1 (idType v))
&& isDllName dflags this_mod (idName v)
is_dll_arg _ = False
@@ -124,9 +124,10 @@ isDllConApp dflags this_mod con args
-- $WT1 = T1 Int (Coercion (Refl Int))
-- The coercion argument here gets VoidRep
isAddrRep :: PrimRep -> Bool
-isAddrRep AddrRep = True
-isAddrRep PtrRep = True
-isAddrRep _ = False
+isAddrRep AddrRep = True
+isAddrRep LiftedRep = True
+isAddrRep UnliftedRep = True
+isAddrRep _ = False
-- | Type of an @StgArg@
--
@@ -533,10 +534,11 @@ type GenStgAlt bndr occ
GenStgExpr bndr occ) -- ...right-hand side.
data AltType
- = PolyAlt -- Polymorphic (a type variable)
+ = PolyAlt -- Polymorphic (a lifted type variable)
| MultiValAlt Int -- Multi value of this arity (unboxed tuple or sum)
+ -- the arity could indeed be 1 for unary unboxed tuple
| AlgAlt TyCon -- Algebraic data type; the AltCons will be DataAlts
- | PrimAlt TyCon -- Primitive data type; the AltCons will be LitAlts
+ | PrimAlt PrimRep -- Primitive data type; the AltCons (if any) will be LitAlts
{-
************************************************************************
View Lorry Controller Status