diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index 474059d93b99a45b25efd65014fee60aa62abb57..4f54e347907657df9a32605966c671f5a759f3da 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgCase.lhs,v 1.19 1998/12/18 17:40:48 simonpj Exp $ +% $Id: CgCase.lhs,v 1.20 1998/12/22 12:55:54 simonm Exp $ % %******************************************************** %* * @@ -11,7 +11,7 @@ \begin{code} module CgCase ( cgCase, saveVolatileVarsAndRegs, restoreCurrentCostCentre, - splitAlgTyConAppThroughNewTypes ) where + splitTyConAppThroughNewTypes ) where #include "HsVersions.h" @@ -61,7 +61,7 @@ import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..) import TyCon ( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon, isNewTyCon, isAlgTyCon, tyConDataCons, tyConFamilySize ) -import Type ( Type, typePrimRep, splitAlgTyConApp, splitAlgTyConApp_maybe, +import Type ( Type, typePrimRep, splitAlgTyConApp, splitTyConApp_maybe, splitFunTys, applyTys ) import Unique ( Unique, Uniquable(..) ) import Maybes ( maybeToBool ) @@ -155,6 +155,11 @@ cgCase (StgCon (PrimOp op) args res_ty) live_in_whole_case live_in_alts bndr srt cgInlineAlts bndr alts \end{code} +TODO: Case-of-case of primop can probably be done inline too (but +maybe better to translate it out beforehand). See +ghc/lib/misc/PackedString.lhs for examples where this crops up (with +4.02). + Another special case: scrutinising a primitive-typed variable. No evaluation required. We don't save volatile variables, nor do we do a heap-check in the alternatives. Instead, the heap usage of the @@ -993,7 +998,7 @@ possibleHeapCheck NoGC _ _ tags lbl code = code \end{code} -splitTyConAppThroughNewTypes is like splitAlgTyConApp_maybe except +splitTyConAppThroughNewTypes is like splitTyConApp_maybe except that it looks through newtypes in addition to synonyms. It's useful in the back end where we're not interested in newtypes anymore. @@ -1005,10 +1010,11 @@ SEQ_FRAME to evaluate the case scrutinee. \begin{code} getScrutineeTyCon :: Type -> Maybe TyCon getScrutineeTyCon ty = - case (splitAlgTyConAppThroughNewTypes ty) of + case (splitTyConAppThroughNewTypes ty) of Nothing -> Nothing Just (tc,_) -> if not (isAlgTyCon tc) then Just tc else + -- works for primitive TyCons too case (tyConFamilySize tc) of 0 -> pprTrace "Warning" (hcat [ text "constructors for ", @@ -1017,14 +1023,15 @@ getScrutineeTyCon ty = ]) Nothing _ -> Just tc -splitAlgTyConAppThroughNewTypes :: Type -> Maybe (TyCon, [Type]) -splitAlgTyConAppThroughNewTypes ty - = case splitAlgTyConApp_maybe ty of - Just (tc, tys, cons) - | isNewTyCon tc -> splitAlgTyConAppThroughNewTypes ty - | otherwise -> Just (tc, tys) - where - ([ty], _) = splitFunTys (applyTys (dataConType (head cons)) tys) +splitTyConAppThroughNewTypes :: Type -> Maybe (TyCon, [Type]) +splitTyConAppThroughNewTypes ty + = case splitTyConApp_maybe ty of + Just (tc, tys) + | isNewTyCon tc -> splitTyConAppThroughNewTypes ty + | otherwise -> Just (tc, tys) + where + ([ty], _) = splitFunTys (applyTys (dataConType (head (tyConDataCons tc))) tys) + + other -> Nothing - other -> Nothing \end{code} diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index 01a700317347528e3884fa3f25964b5ae605ddb0..3cc58a675d20b1c7ed5d57920df16e411438fec8 100644 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgExpr.lhs,v 1.17 1998/12/18 17:40:50 simonpj Exp $ +% $Id: CgExpr.lhs,v 1.18 1998/12/22 12:55:55 simonm Exp $ % %******************************************************** %* * @@ -24,7 +24,7 @@ import SMRep ( fixedHdrSize ) import CgBindery ( getArgAmodes, CgIdInfo, nukeDeadBindings ) import CgCase ( cgCase, saveVolatileVarsAndRegs, restoreCurrentCostCentre, - splitAlgTyConAppThroughNewTypes ) + splitTyConAppThroughNewTypes ) import CgClosure ( cgRhsClosure, cgStdRhsClosure ) import CgCon ( buildDynCon, cgReturnDataCon ) import CgLetNoEscape ( cgLetNoEscapeClosure ) @@ -423,7 +423,7 @@ Little helper for primitives that return unboxed tuples. \begin{code} primRetUnboxedTuple :: PrimOp -> [StgArg] -> Type -> Code primRetUnboxedTuple op args res_ty - = let (tc,ty_args) = case splitAlgTyConAppThroughNewTypes res_ty of + = let (tc,ty_args) = case splitTyConAppThroughNewTypes res_ty of Nothing -> pprPanic "primRetUnboxedTuple" (ppr res_ty) Just pr -> pr