diff options
Diffstat (limited to 'compiler/stgSyn/CoreToStg.lhs')
| -rw-r--r-- | compiler/stgSyn/CoreToStg.lhs | 27 |
1 files changed, 14 insertions, 13 deletions
diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs index c4f289c68e..6dc091961a 100644 --- a/compiler/stgSyn/CoreToStg.lhs +++ b/compiler/stgSyn/CoreToStg.lhs @@ -277,7 +277,7 @@ mkTopStgRhs :: DynFlags -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs -mkTopStgRhs _ rhs_fvs srt binder_info (StgLam _ bndrs body) +mkTopStgRhs _ rhs_fvs srt binder_info (StgLam bndrs body) = StgRhsClosure noCCS binder_info (getFVs rhs_fvs) ReEntrant @@ -343,7 +343,7 @@ coreToStgExpr expr@(Lam _ _) fvs = args' `minusFVBinders` body_fvs escs = body_escs `delVarSetList` args' result_expr | null args' = body - | otherwise = StgLam (exprType expr) args' body + | otherwise = StgLam args' body return (result_expr, fvs, escs) @@ -454,15 +454,15 @@ coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e) \begin{code} mkStgAltType :: Id -> [CoreAlt] -> AltType -mkStgAltType bndr alts - = case tyConAppTyCon_maybe (repType (idType bndr)) of - Just tc | isUnboxedTupleTyCon tc -> UbxTupAlt 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 +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 + UbxTupleRep rep_tys -> UbxTupAlt (length rep_tys) where _is_poly_alt_tycon tc @@ -623,7 +623,8 @@ 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)) - || (typePrimRep arg_ty /= typePrimRep stg_arg_ty) + || (map typePrimRep (flattenRepType (repType arg_ty)) + /= map typePrimRep (flattenRepType (repType 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 @@ -783,7 +784,7 @@ mkStgRhs :: FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs mkStgRhs _ _ _ (StgConApp con args) = StgRhsCon noCCS con args -mkStgRhs rhs_fvs srt binder_info (StgLam _ bndrs body) +mkStgRhs rhs_fvs srt binder_info (StgLam bndrs body) = StgRhsClosure noCCS binder_info (getFVs rhs_fvs) ReEntrant |