X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsUtils.lhs;h=66472b77a14c1e873a01dd7d4bd07090ea4ee35a;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=e6b80f2d41074a3d6b0fcc76d27bf4f84a033b96;hpb=c49d51f812da9b1c2ceca7e0dad8f2a3626041a9;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index e6b80f2..66472b7 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -13,7 +13,7 @@ module DsUtils ( combineGRHSMatchResults, combineMatchResults, - dsExprToAtom, + dsExprToAtom, SYN_IE(DsCoreArg), mkCoAlgCaseMatchResult, mkAppDs, mkConDs, mkPrimDs, mkErrorAppDs, mkCoLetsMatchResult, @@ -27,12 +27,12 @@ module DsUtils ( showForErr ) where -import Ubiq -import DsLoop ( match, matchSimply ) +IMP_Ubiq() +IMPORT_DELOOPER(DsLoop) ( match, matchSimply ) import HsSyn ( HsExpr(..), OutPat(..), HsLit(..), - Match, HsBinds, Stmt, Qual, PolyType, ArithSeqInfo ) -import TcHsSyn ( TypecheckedPat(..) ) + Match, HsBinds, Stmt, Qualifier, PolyType, ArithSeqInfo ) +import TcHsSyn ( SYN_IE(TypecheckedPat) ) import DsHsSyn ( outPatType ) import CoreSyn @@ -40,19 +40,25 @@ import DsMonad import CoreUtils ( coreExprType, mkCoreIfThenElse ) import PprStyle ( PprStyle(..) ) -import PrelInfo ( stringTy, iRREFUT_PAT_ERROR_ID ) +import PrelVals ( iRREFUT_PAT_ERROR_ID, voidId ) import Pretty ( ppShow ) import Id ( idType, dataConArgTys, mkTupleCon, - DataCon(..), DictVar(..), Id(..), GenId ) +-- pprId{-ToDo:rm-}, + SYN_IE(DataCon), SYN_IE(DictVar), SYN_IE(Id), GenId ) import Literal ( Literal(..) ) -import TyCon ( mkTupleTyCon ) -import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTys, - isUnboxedType, applyTyCon, getAppDataTyCon +import TyCon ( mkTupleTyCon, isNewTyCon, tyConDataCons ) +import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTy, + mkTheta, isUnboxedType, applyTyCon, getAppTyCon ) -import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) ) -import Util ( panic, assertPanic ) - -splitDictType = panic "DsUtils.splitDictType" +import TysPrim ( voidTy ) +import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, SYN_IE(UniqSet) ) +import Util ( panic, assertPanic{-, pprTrace ToDo:rm-} ) +import Usage ( SYN_IE(UVar) ) +--import PprCore{-ToDo:rm-} +--import PprType--ToDo:rm +--import Pretty--ToDo:rm +--import TyVar--ToDo:rm +--import Unique--ToDo:rm \end{code} %************************************************************************ @@ -129,7 +135,13 @@ mkCoPrimCaseMatchResult var alts mkCoAlgCaseMatchResult :: Id -- Scrutinee -> [(DataCon, [Id], MatchResult)] -- Alternatives -> DsM MatchResult + mkCoAlgCaseMatchResult var alts + | isNewTyCon tycon -- newtype case; use a let + = ASSERT( newtype_sanity ) + returnDs (mkCoLetsMatchResult [coercion_bind] match_result) + + | otherwise -- datatype case = -- Find all the constructors in the type which aren't -- explicitly mentioned in the alternatives: case un_mentioned_constructors of @@ -163,8 +175,21 @@ mkCoAlgCaseMatchResult var alts (mk_case alts (\fail_expr -> BindDefault wild fail_expr)) cxt1) where + -- Common stuff scrut_ty = idType var - (tycon, tycon_arg_tys, data_cons) = getAppDataTyCon scrut_ty + (tycon, tycon_arg_tys) = --pprTrace "CoAlgCase:" (pprType PprDebug scrut_ty) $ + getAppTyCon scrut_ty + + -- Stuff for newtype + (con_id, arg_ids, match_result) = head alts + arg_id = head arg_ids + coercion_bind = NonRec arg_id (Coerce (CoerceOut con_id) + (idType arg_id) + (Var var)) + newtype_sanity = null (tail alts) && null (tail arg_ids) + + -- Stuff for data types + data_cons = tyConDataCons tycon un_mentioned_constructors = uniqSetToList (mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- alts] ) @@ -215,15 +240,19 @@ combineGRHSMatchResults match_result1 match_result2 %************************************************************************ \begin{code} -dsExprToAtom :: CoreExpr -- The argument expression +dsExprToAtom :: DsCoreArg -- The argument expression -> (CoreArg -> DsM CoreExpr) -- Something taking the argument *atom*, -- and delivering an expression E -> DsM CoreExpr -- Either E or let x=arg-expr in E -dsExprToAtom (Var v) continue_with = continue_with (VarArg v) -dsExprToAtom (Lit v) continue_with = continue_with (LitArg v) +dsExprToAtom (UsageArg u) continue_with = continue_with (UsageArg u) +dsExprToAtom (TyArg t) continue_with = continue_with (TyArg t) +dsExprToAtom (LitArg l) continue_with = continue_with (LitArg l) + +dsExprToAtom (VarArg (Var v)) continue_with = continue_with (VarArg v) +dsExprToAtom (VarArg (Lit v)) continue_with = continue_with (LitArg v) -dsExprToAtom arg_expr continue_with +dsExprToAtom (VarArg arg_expr) continue_with = let ty = coreExprType arg_expr in @@ -235,12 +264,11 @@ dsExprToAtom arg_expr continue_with else Let (NonRec arg_id arg_expr) body ) -dsExprsToAtoms :: [CoreExpr] +dsExprsToAtoms :: [DsCoreArg] -> ([CoreArg] -> DsM CoreExpr) -> DsM CoreExpr -dsExprsToAtoms [] continue_with - = continue_with [] +dsExprsToAtoms [] continue_with = continue_with [] dsExprsToAtoms (arg:args) continue_with = dsExprToAtom arg $ \ arg_atom -> @@ -255,21 +283,23 @@ dsExprsToAtoms (arg:args) continue_with %************************************************************************ \begin{code} -mkAppDs :: CoreExpr -> [Type] -> [CoreExpr] -> DsM CoreExpr -mkConDs :: Id -> [Type] -> [CoreExpr] -> DsM CoreExpr -mkPrimDs :: PrimOp -> [Type] -> [CoreExpr] -> DsM CoreExpr +type DsCoreArg = GenCoreArg CoreExpr{-NB!-} TyVar UVar -mkAppDs fun tys arg_exprs - = dsExprsToAtoms arg_exprs $ \ vals -> - returnDs (mkApp fun [] tys vals) +mkAppDs :: CoreExpr -> [DsCoreArg] -> DsM CoreExpr +mkConDs :: Id -> [DsCoreArg] -> DsM CoreExpr +mkPrimDs :: PrimOp -> [DsCoreArg] -> DsM CoreExpr -mkConDs con tys arg_exprs - = dsExprsToAtoms arg_exprs $ \ vals -> - returnDs (mkCon con [] tys vals) +mkAppDs fun args + = dsExprsToAtoms args $ \ atoms -> + returnDs (mkGenApp fun atoms) -mkPrimDs op tys arg_exprs - = dsExprsToAtoms arg_exprs $ \ vals -> - returnDs (mkPrim op [] tys vals) +mkConDs con args + = dsExprsToAtoms args $ \ atoms -> + returnDs (Con con atoms) + +mkPrimDs op args + = dsExprsToAtoms args $ \ atoms -> + returnDs (Prim op atoms) \end{code} \begin{code} @@ -395,7 +425,9 @@ The general case: \begin{code} mkTupleBind tyvars dicts local_global_prs tuple_expr - = newSysLocalDs tuple_var_ty `thenDs` \ tuple_var -> + = --pprTrace "mkTupleBind:\n" (ppAboves [ppCat (map (pprId PprShowAll) locals), ppCat (map (pprId PprShowAll) globals), {-ppr PprDebug local_tuple, pprType PprDebug res_ty,-} ppr PprDebug tuple_expr]) $ + + newSysLocalDs tuple_var_ty `thenDs` \ tuple_var -> zipWithDs (mk_selector (Var tuple_var)) local_global_prs @@ -420,7 +452,7 @@ mkTupleBind tyvars dicts local_global_prs tuple_expr applyTyCon (mkTupleTyCon no_of_binders) (map idType locals) where - theta = map (splitDictType . idType) dicts + theta = mkTheta (map idType dicts) mk_selector :: CoreExpr -> (Id, Id) -> Int -> DsM (Id, CoreExpr) @@ -525,13 +557,13 @@ which is of course utterly wrong. Rather than drop the condition that only boxed types can be let-bound, we just turn the fail into a function for the primitive case: \begin{verbatim} - let fail.33 :: () -> Int# + let fail.33 :: Void -> Int# fail.33 = \_ -> error "Help" in case x of p1 -> ... - p2 -> fail.33 () - p3 -> fail.33 () + p2 -> fail.33 void + p3 -> fail.33 void p4 -> ... \end{verbatim} @@ -546,19 +578,16 @@ mkFailurePair :: Type -- Result type of the whole case expression -- applied to unit tuple mkFailurePair ty | isUnboxedType ty - = newFailLocalDs (mkFunTys [unit_ty] ty) `thenDs` \ fail_fun_var -> - newSysLocalDs unit_ty `thenDs` \ fail_fun_arg -> + = newFailLocalDs (voidTy `mkFunTy` ty) `thenDs` \ fail_fun_var -> + newSysLocalDs voidTy `thenDs` \ fail_fun_arg -> returnDs (\ body -> NonRec fail_fun_var (Lam (ValBinder fail_fun_arg) body), - App (Var fail_fun_var) (VarArg unit_id)) + App (Var fail_fun_var) (VarArg voidId)) | otherwise = newFailLocalDs ty `thenDs` \ fail_var -> returnDs (\ body -> NonRec fail_var body, Var fail_var) +\end{code} + -unit_id :: Id -- out here to avoid CAF (sigh) -unit_id = mkTupleCon 0 -unit_ty :: Type -unit_ty = idType unit_id -\end{code}