X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FstgSyn%2FCoreToStg.lhs;h=40023bf36347ee0f5fe78248d01c0383a17ee8c8;hb=235edf36cc202bb21c00d0e5e05ebf076fb0542e;hp=64f9fe3ad3b5f153ec6b5bfb23b58f682f46e8f5;hpb=6ef2fc2ebf11755a54386f8e317d83cb19913be1;p=ghc-hetmet.git diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs index 64f9fe3..40023bf 100644 --- a/compiler/stgSyn/CoreToStg.lhs +++ b/compiler/stgSyn/CoreToStg.lhs @@ -7,6 +7,13 @@ And, as we have the info in hand, we may convert some lets to let-no-escapes. \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module CoreToStg ( coreToStg, coreExprToStg ) where #include "HsVersions.h" @@ -16,10 +23,9 @@ import CoreUtils ( rhsIsStatic, manifestArity, exprType, findDefault ) import StgSyn import Type -import TyCon ( isAlgTyCon ) +import TyCon import Id import Var ( Var, globalIdDetails, idType ) -import TyCon ( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon, isHiBootTyCon ) import IdInfo import DataCon import CostCentre ( noCCS ) @@ -30,7 +36,7 @@ import Name ( getOccName, isExternalName, nameOccName ) import OccName ( occNameString, occNameFS ) import BasicTypes ( Arity ) import StaticFlags ( opt_RuntimeTypes ) -import PackageConfig ( PackageId ) +import Module import Outputable infixr 9 `thenLne` @@ -209,7 +215,6 @@ coreTopBindToStg this_pkg env body_fvs (Rec pairs) ASSERT2(consistentCafInfo (head binders) bind, ppr binders) (env', fvs' `unionFVInfo` body_fvs, bind) -#ifdef DEBUG -- Assertion helper: this checks that the CafInfo on the Id matches -- what CoreToStg has figured out about the binding's SRT. The -- CafInfo will be exact in all cases except when CorePrep has @@ -224,7 +229,6 @@ consistentCafInfo id bind exact = id_marked_caffy == binding_is_caffy id_marked_caffy = mayHaveCafRefs (idCafInfo id) binding_is_caffy = stgBindHasCafRefs bind -#endif \end{code} \begin{code} @@ -317,15 +321,11 @@ coreToStgExpr (Note (SCC cc) expr) = coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) -> returnLne (StgSCC cc expr2, fvs, escs) ) -coreToStgExpr (Note (TickBox m n) expr) +coreToStgExpr (Case (Var id) _bndr ty [(DEFAULT,[],expr)]) + | Just (TickBox m n) <- isTickBoxOp_maybe id = coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) -> returnLne (StgTick m n expr2, fvs, escs) ) --- BinaryTickBox'es are are removed by the CorePrep pass. - -coreToStgExpr expr@(Note (BinaryTickBox m t e) _) - = pprPanic "coreToStgExpr: " (ppr expr) - coreToStgExpr (Note other_note expr) = coreToStgExpr expr @@ -371,7 +371,7 @@ coreToStgExpr (Case scrut bndr _ alts) (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 @@ -411,20 +411,27 @@ coreToStgExpr (Let bind body) \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 - | isPrimTyCon tc -> PrimAlt tc + | isUnLiftedTyCon tc -> PrimAlt tc | isHiBootTyCon tc -> look_for_better_tycon | isAlgTyCon tc -> AlgAlt tc - | isFunTyCon tc -> PolyAlt - | 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 = @@ -451,6 +458,7 @@ coreToStgApp -> [CoreArg] -- Arguments -> LneM (StgExpr, FreeVarsInfo, EscVarsSet) + coreToStgApp maybe_thunk_body f args = coreToStgArgs args `thenLne` \ (args', args_fvs) -> lookupVarLne f `thenLne` \ how_bound -> @@ -508,6 +516,7 @@ coreToStgApp maybe_thunk_body f args StgOpApp (StgPrimOp op) args' res_ty FCallId call -> ASSERT( saturated ) StgOpApp (StgFCallOp call (idUnique f)) args' res_ty + TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args') _other -> StgApp f args' in @@ -560,9 +569,15 @@ coreToStgArgs (arg : args) -- Non-type argument 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) @@ -1069,7 +1084,6 @@ plusFVInfo (id1,hb1,info1) (id2,hb2,info2) = ASSERT (id1 == id2 && hb1 `check_eq_how_bound` hb2) (id1, hb1, combineStgBinderInfo info1 info2) -#ifdef DEBUG -- The HowBound info for a variable in the FVInfo should be consistent check_eq_how_bound ImportBound ImportBound = True check_eq_how_bound LambdaBound LambdaBound = True @@ -1079,7 +1093,6 @@ check_eq_how_bound hb1 hb2 = False check_eq_li (NestedLet _) (NestedLet _) = True check_eq_li TopLet TopLet = True check_eq_li li1 li2 = False -#endif \end{code} Misc. @@ -1098,8 +1111,6 @@ myCollectBinders expr where go bs (Lam b e) = go (b:bs) e go bs e@(Note (SCC _) _) = (reverse bs, e) - go bs e@(Note (TickBox {}) _) = (reverse bs, e) - go bs e@(Note (BinaryTickBox {}) _) = (reverse bs, e) go bs (Cast e co) = go bs e go bs (Note _ e) = go bs e go bs e = (reverse bs, e) @@ -1113,8 +1124,6 @@ myCollectArgs expr go (Var v) as = (v, as) go (App f a) as = go f (a:as) go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr) - go (Note (TickBox {}) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr) - go (Note (BinaryTickBox {}) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr) go (Cast e co) as = go e as go (Note n e) as = go e as go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)