X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsUtils.lhs;h=66472b77a14c1e873a01dd7d4bd07090ea4ee35a;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=b58c6d5ebc2cd4bb6660ac054b60658feb22fae4;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index b58c6d5..66472b7 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -13,9 +13,9 @@ module DsUtils ( combineGRHSMatchResults, combineMatchResults, - dsExprToAtom, + dsExprToAtom, SYN_IE(DsCoreArg), mkCoAlgCaseMatchResult, - mkAppDs, mkConDs, mkPrimDs, + mkAppDs, mkConDs, mkPrimDs, mkErrorAppDs, mkCoLetsMatchResult, mkCoPrimCaseMatchResult, mkFailurePair, @@ -23,34 +23,42 @@ module DsUtils ( mkSelectorBinds, mkTupleBind, mkTupleExpr, - selectMatchVars + selectMatchVars, + 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 import DsMonad -import CoreUtils ( coreExprType, escErrorMsg, mkCoreIfThenElse, mkErrorApp ) -import PrelInfo ( stringTy ) -import Id ( idType, getInstantiatedDataConSig, mkTupleCon, - DataCon(..), DictVar(..), Id(..), GenId ) -import TyCon ( mkTupleTyCon ) -import Type ( mkTyVarTy, mkRhoTy, mkFunTys, - applyTyCon, getAppDataTyCon ) -import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) ) -import Util ( panic, assertPanic ) - -isUnboxedDataType = panic "DsUtils.isUnboxedDataType" -quantifyTy = panic "DsUtils.quantifyTy" -splitDictType = panic "DsUtils.splitDictType" -mkCoTyApps = panic "DsUtils.mkCoTyApps" +import CoreUtils ( coreExprType, mkCoreIfThenElse ) +import PprStyle ( PprStyle(..) ) +import PrelVals ( iRREFUT_PAT_ERROR_ID, voidId ) +import Pretty ( ppShow ) +import Id ( idType, dataConArgTys, mkTupleCon, +-- pprId{-ToDo:rm-}, + SYN_IE(DataCon), SYN_IE(DictVar), SYN_IE(Id), GenId ) +import Literal ( Literal(..) ) +import TyCon ( mkTupleTyCon, isNewTyCon, tyConDataCons ) +import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTy, + mkTheta, isUnboxedType, applyTyCon, getAppTyCon + ) +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} %************************************************************************ @@ -127,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 @@ -141,7 +155,7 @@ mkCoAlgCaseMatchResult var alts -- We need to build new locals for the args of the constructor, -- and figuring out their types is somewhat tiresome. let - (_,arg_tys,_) = getInstantiatedDataConSig con tycon_arg_tys + arg_tys = dataConArgTys con tycon_arg_tys in newSysLocalsDs arg_tys `thenDs` \ arg_ids -> @@ -161,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] ) @@ -213,32 +240,35 @@ 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 newSysLocalDs ty `thenDs` \ arg_id -> continue_with (VarArg arg_id) `thenDs` \ body -> returnDs ( - if isUnboxedDataType ty + if isUnboxedType ty then Case arg_expr (PrimAlts [] (BindDefault arg_id body)) 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 -> @@ -252,24 +282,42 @@ dsExprsToAtoms (arg:args) continue_with %* * %************************************************************************ -Plumb the desugarer's @UniqueSupply@ in/out of the @UniqSupply@ monad -world. \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 :: CoreExpr -> [DsCoreArg] -> DsM CoreExpr +mkConDs :: Id -> [DsCoreArg] -> DsM CoreExpr +mkPrimDs :: PrimOp -> [DsCoreArg] -> DsM CoreExpr -mkAppDs fun tys arg_exprs - = dsExprsToAtoms arg_exprs $ \ vals -> - returnDs (mkApp fun [] tys vals) +mkAppDs fun args + = dsExprsToAtoms args $ \ atoms -> + returnDs (mkGenApp fun atoms) -mkConDs con tys arg_exprs - = dsExprsToAtoms arg_exprs $ \ vals -> - returnDs (mkCon con [] tys vals) +mkConDs con args + = dsExprsToAtoms args $ \ atoms -> + returnDs (Con con atoms) -mkPrimDs op tys arg_exprs - = dsExprsToAtoms arg_exprs $ \ vals -> - returnDs (mkPrim op [] tys vals) +mkPrimDs op args + = dsExprsToAtoms args $ \ atoms -> + returnDs (Prim op atoms) +\end{code} + +\begin{code} +showForErr :: Outputable a => a -> String -- Boring but useful +showForErr thing = ppShow 80 (ppr PprForUser thing) + +mkErrorAppDs :: Id -- The error function + -> Type -- Type to which it should be applied + -> String -- The error message string to pass + -> DsM CoreExpr + +mkErrorAppDs err_id ty msg + = getSrcLocDs `thenDs` \ (file, line) -> + let + full_msg = file ++ "|" ++ line ++ "|" ++msg + msg_lit = NoRepStr (_PK_ full_msg) + in + returnDs (mkApp (Var err_id) [] [ty] [LitArg msg_lit]) \end{code} %************************************************************************ @@ -303,17 +351,10 @@ mkSelectorBinds :: [TyVar] -- Variables wrt which the pattern is polymorphic -> DsM [(Id,CoreExpr)] mkSelectorBinds tyvars pat locals_and_globals val_expr - = getSrcLocDs `thenDs` \ (src_file, src_line) -> - - if is_simple_tuple_pat pat then + = if is_simple_tuple_pat pat then mkTupleBind tyvars [] locals_and_globals val_expr else - newSysLocalDs stringTy `thenDs` \ str_var -> -- to hold the string - let - src_loc_str = escErrorMsg ('"' : src_file) ++ "%l" ++ src_line - error_string = src_loc_str ++ "%~" --> ": pattern-match failed on an irrefutable pattern" - error_msg = mkErrorApp res_ty str_var error_string - in + mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty "" `thenDs` \ error_msg -> matchSimply val_expr pat res_ty local_tuple error_msg `thenDs` \ tuple_expr -> mkTupleBind tyvars [] locals_and_globals tuple_expr where @@ -384,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 @@ -400,16 +443,16 @@ mkTupleBind tyvars dicts local_global_prs tuple_expr globals = [global | (local,global) <- local_global_prs] no_of_binders = length local_global_prs - tyvar_tys = map mkTyVarTy tyvars + tyvar_tys = mkTyVarTys tyvars tuple_var_ty :: Type tuple_var_ty - = case (quantifyTy tyvars (mkRhoTy theta - (applyTyCon (mkTupleTyCon no_of_binders) - (map idType locals)))) of - (_{-tossed templates-}, ty) -> ty + = mkForAllTys tyvars $ + mkRhoTy theta $ + 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) @@ -421,17 +464,14 @@ mkTupleBind tyvars dicts local_global_prs tuple_expr returnDs ( global, mkLam tyvars dicts ( - mkTupleSelector (mkApp_XX (mkCoTyApps tuple_var_expr tyvar_tys) dicts) - binders selected) + mkTupleSelector + (mkValApp (mkTyApp tuple_var_expr tyvar_tys) + (map VarArg dicts)) + binders + selected) ) - -mkApp_XX :: CoreExpr -> [Id] -> CoreExpr -mkApp_XX expr [] = expr -mkApp_XX expr (id:ids) = mkApp_XX (App expr (VarArg id)) ids \end{code} - - @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it has only one element, it is the identity function. \begin{code} @@ -517,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} @@ -537,20 +577,17 @@ mkFailurePair :: Type -- Result type of the whole case expression CoreExpr) -- Either the fail variable, or fail variable -- applied to unit tuple mkFailurePair ty - | isUnboxedDataType ty - = newFailLocalDs (mkFunTys [unit_ty] ty) `thenDs` \ fail_fun_var -> - newSysLocalDs unit_ty `thenDs` \ fail_fun_arg -> + | isUnboxedType ty + = 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}