X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsUtils.lhs;h=66472b77a14c1e873a01dd7d4bd07090ea4ee35a;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=5e0031dd67b03f69c96c4f8010f62137390ce4eb;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 5e0031d..66472b7 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \section[DsUtils]{Utilities for desugaring} @@ -13,45 +13,52 @@ module DsUtils ( combineGRHSMatchResults, combineMatchResults, - dsExprToAtom, + dsExprToAtom, SYN_IE(DsCoreArg), mkCoAlgCaseMatchResult, - mkCoAppDs, - mkCoConDs, + mkAppDs, mkConDs, mkPrimDs, mkErrorAppDs, mkCoLetsMatchResult, mkCoPrimCaseMatchResult, - mkCoPrimDs, mkFailurePair, mkGuardedMatchResult, mkSelectorBinds, mkTupleBind, mkTupleExpr, - selectMatchVars + selectMatchVars, + showForErr ) where -import AbsSyn -- the stuff being desugared -import PlainCore -- the output of desugaring; - -- importing this module also gets all the - -- CoreSyn utility functions -import DsMonad -- the monadery used in the desugarer - -import AbsPrel ( mkFunTy, stringTy - IF_ATTACK_PRAGMAS(COMMA mkListTy COMMA charTy) - ) -import AbsUniType ( mkTyVarTy, quantifyTy, mkTupleTyCon, - mkRhoTy, splitDictType, applyTyCon, - getUniDataTyCon, isUnboxedDataType, - TyVar, TyVarTemplate, TyCon, Arity(..), Class, - UniType, RhoType(..), SigmaType(..) - ) -import Id ( getIdUniType, getInstantiatedDataConSig, - mkTupleCon, DataCon(..), Id +IMP_Ubiq() +IMPORT_DELOOPER(DsLoop) ( match, matchSimply ) + +import HsSyn ( HsExpr(..), OutPat(..), HsLit(..), + Match, HsBinds, Stmt, Qualifier, PolyType, ArithSeqInfo ) +import TcHsSyn ( SYN_IE(TypecheckedPat) ) +import DsHsSyn ( outPatType ) +import CoreSyn + +import DsMonad + +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 Maybes ( Maybe(..) ) -import Match ( match, matchSimply ) -import Pretty -import Unique ( initUs, UniqueSupply, UniqSM(..) ) -import UniqSet -import Util +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} %************************************************************************ @@ -65,7 +72,7 @@ The ``equation info'' used by @match@ is relatively complicated and worthy of a type synonym and a few handy functions. \begin{code} -data EquationInfo +data EquationInfo = EqnInfo [TypecheckedPat] -- the patterns for an eqn MatchResult -- Encapsulates the guards and bindings @@ -75,9 +82,9 @@ data EquationInfo data MatchResult = MatchResult CanItFail - UniType -- Type of argument expression + Type -- Type of argument expression - (PlainCoreExpr -> PlainCoreExpr) + (CoreExpr -> CoreExpr) -- Takes a expression to plug in at the -- failure point(s). The expression should -- be duplicatable! @@ -93,11 +100,11 @@ orFail CantFail CantFail = CantFail orFail _ _ = CanFail -mkCoLetsMatchResult :: [PlainCoreBinding] -> MatchResult -> MatchResult -mkCoLetsMatchResult binds (MatchResult can_it_fail ty body_fn cxt) +mkCoLetsMatchResult :: [CoreBinding] -> MatchResult -> MatchResult +mkCoLetsMatchResult binds (MatchResult can_it_fail ty body_fn cxt) = MatchResult can_it_fail ty (\body -> mkCoLetsAny binds (body_fn body)) cxt -mkGuardedMatchResult :: PlainCoreExpr -> MatchResult -> DsM MatchResult +mkGuardedMatchResult :: CoreExpr -> MatchResult -> DsM MatchResult mkGuardedMatchResult pred_expr (MatchResult can_it_fail ty body_fn cxt) = returnDs (MatchResult CanFail ty @@ -106,10 +113,10 @@ mkGuardedMatchResult pred_expr (MatchResult can_it_fail ty body_fn cxt) ) mkCoPrimCaseMatchResult :: Id -- Scrutinee - -> [(BasicLit, MatchResult)] -- Alternatives + -> [(Literal, MatchResult)] -- Alternatives -> DsM MatchResult mkCoPrimCaseMatchResult var alts - = newSysLocalDs (getIdUniType var) `thenDs` \ wild -> + = newSysLocalDs (idType var) `thenDs` \ wild -> returnDs (MatchResult CanFail ty1 (mk_case alts wild) @@ -118,52 +125,71 @@ mkCoPrimCaseMatchResult var alts ((_,MatchResult _ ty1 _ cxt1) : _) = alts mk_case alts wild fail_expr - = CoCase (CoVar var) (CoPrimAlts final_alts (CoBindDefault wild fail_expr)) + = Case (Var var) (PrimAlts final_alts (BindDefault wild fail_expr)) where - final_alts = [ (lit, body_fn fail_expr) + final_alts = [ (lit, body_fn fail_expr) | (lit, MatchResult _ _ body_fn _) <- alts ] mkCoAlgCaseMatchResult :: Id -- Scrutinee - -> [(DataCon, [Id], MatchResult)] -- Alternatives + -> [(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 [] -> -- All constructors mentioned, so no default needed - returnDs (MatchResult can_any_alt_fail - ty1 - (mk_case alts (\ignore -> CoNoDefault)) + returnDs (MatchResult can_any_alt_fail + ty1 + (mk_case alts (\ignore -> NoDefault)) cxt1) [con] -> -- Just one constructor missing, so add a case for it - -- We need to build new locals for the args of the constructor, + -- 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 -> - + -- Now we are ready to construct the new alternative let new_alt = (con, arg_ids, MatchResult CanFail ty1 id NoMatchContext) in returnDs (MatchResult CanFail - ty1 - (mk_case (new_alt:alts) (\ignore -> CoNoDefault)) + ty1 + (mk_case (new_alt:alts) (\ignore -> NoDefault)) cxt1) other -> -- Many constructors missing, so use a default case newSysLocalDs scrut_ty `thenDs` \ wild -> returnDs (MatchResult CanFail - ty1 - (mk_case alts (\fail_expr -> CoBindDefault wild fail_expr)) + ty1 + (mk_case alts (\fail_expr -> BindDefault wild fail_expr)) cxt1) where - scrut_ty = getIdUniType var - (tycon, tycon_arg_tys, data_cons) = getUniDataTyCon scrut_ty + -- Common stuff + scrut_ty = idType var + (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] ) @@ -173,24 +199,24 @@ mkCoAlgCaseMatchResult var alts can_any_alt_fail = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ _ _ <- match_results] mk_case alts deflt_fn fail_expr - = CoCase (CoVar var) (CoAlgAlts final_alts (deflt_fn fail_expr)) + = Case (Var var) (AlgAlts final_alts (deflt_fn fail_expr)) where - final_alts = [ (con, args, body_fn fail_expr) + final_alts = [ (con, args, body_fn fail_expr) | (con, args, MatchResult _ _ body_fn _) <- alts ] combineMatchResults :: MatchResult -> MatchResult -> DsM MatchResult combineMatchResults (MatchResult CanFail ty1 body_fn1 cxt1) - (MatchResult can_it_fail2 ty2 body_fn2 cxt2) + (MatchResult can_it_fail2 ty2 body_fn2 cxt2) = mkFailurePair ty1 `thenDs` \ (bind_fn, duplicatable_expr) -> let - new_body_fn1 = \body1 -> CoLet (bind_fn body1) (body_fn1 duplicatable_expr) + new_body_fn1 = \body1 -> Let (bind_fn body1) (body_fn1 duplicatable_expr) new_body_fn2 = \body2 -> new_body_fn1 (body_fn2 body2) in returnDs (MatchResult can_it_fail2 ty1 new_body_fn2 cxt1) -combineMatchResults match_result1@(MatchResult CantFail ty body_fn1 cxt1) +combineMatchResults match_result1@(MatchResult CantFail ty body_fn1 cxt1) match_result2 = returnDs match_result1 @@ -199,7 +225,7 @@ combineMatchResults match_result1@(MatchResult CantFail ty body_fn1 cxt1) -- need to let-bind to avoid code duplication combineGRHSMatchResults :: MatchResult -> MatchResult -> DsM MatchResult combineGRHSMatchResults (MatchResult CanFail ty1 body_fn1 cxt1) - (MatchResult can_it_fail ty2 body_fn2 cxt2) + (MatchResult can_it_fail ty2 body_fn2 cxt2) = returnDs (MatchResult can_it_fail ty1 (\ body -> body_fn1 (body_fn2 body)) cxt1) combineGRHSMatchResults match_result1 match_result2 @@ -214,58 +240,84 @@ combineGRHSMatchResults match_result1 match_result2 %************************************************************************ \begin{code} -dsExprToAtom :: PlainCoreExpr -- The argument expression - -> (PlainCoreAtom -> DsM PlainCoreExpr) -- Something taking the argument *atom*, - -- and delivering an expression E - -> DsM PlainCoreExpr -- Either E or let x=arg-expr in E - -dsExprToAtom (CoVar v) continue_with = continue_with (CoVarAtom v) -dsExprToAtom (CoLit v) continue_with = continue_with (CoLitAtom v) - -dsExprToAtom arg_expr continue_with - = newSysLocalDs ty `thenDs` \ arg_id -> - continue_with (CoVarAtom arg_id) `thenDs` \ body -> - if isUnboxedDataType ty - then returnDs (CoCase arg_expr (CoPrimAlts [] (CoBindDefault arg_id body))) - else returnDs (CoLet (CoNonRec arg_id arg_expr) body) - where - ty = typeOfCoreExpr arg_expr +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 -dsExprsToAtoms :: [PlainCoreExpr] - -> ([PlainCoreAtom] -> DsM PlainCoreExpr) - -> DsM PlainCoreExpr +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) -dsExprsToAtoms [] continue_with - = continue_with [] +dsExprToAtom (VarArg (Var v)) continue_with = continue_with (VarArg v) +dsExprToAtom (VarArg (Lit v)) continue_with = continue_with (LitArg v) + +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 isUnboxedType ty + then Case arg_expr (PrimAlts [] (BindDefault arg_id body)) + else Let (NonRec arg_id arg_expr) body + ) + +dsExprsToAtoms :: [DsCoreArg] + -> ([CoreArg] -> DsM CoreExpr) + -> DsM CoreExpr + +dsExprsToAtoms [] continue_with = continue_with [] dsExprsToAtoms (arg:args) continue_with - = dsExprToAtom arg (\ arg_atom -> - dsExprsToAtoms args (\ arg_atoms -> + = dsExprToAtom arg $ \ arg_atom -> + dsExprsToAtoms args $ \ arg_atoms -> continue_with (arg_atom:arg_atoms) - )) \end{code} %************************************************************************ %* * -\subsection[mkCoAppDs]{Desugarer's versions of some Core functions} +\subsection{Desugarer's versions of some Core functions} %* * %************************************************************************ -Plumb the desugarer's @UniqueSupply@ in/out of the @UniqueSupplyMonad@ -world. \begin{code} -mkCoAppDs :: PlainCoreExpr -> PlainCoreExpr -> DsM PlainCoreExpr -mkCoConDs :: Id -> [UniType] -> [PlainCoreExpr] -> DsM PlainCoreExpr -mkCoPrimDs :: PrimOp -> [UniType] -> [PlainCoreExpr] -> DsM PlainCoreExpr +type DsCoreArg = GenCoreArg CoreExpr{-NB!-} TyVar UVar + +mkAppDs :: CoreExpr -> [DsCoreArg] -> DsM CoreExpr +mkConDs :: Id -> [DsCoreArg] -> DsM CoreExpr +mkPrimDs :: PrimOp -> [DsCoreArg] -> DsM CoreExpr + +mkAppDs fun args + = dsExprsToAtoms args $ \ atoms -> + returnDs (mkGenApp fun atoms) -mkCoAppDs fun arg_expr - = dsExprToAtom arg_expr (\ arg_atom -> returnDs (CoApp fun arg_atom)) +mkConDs con args + = dsExprsToAtoms args $ \ atoms -> + returnDs (Con con atoms) + +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) -mkCoConDs con tys arg_exprs - = dsExprsToAtoms arg_exprs (\ arg_atoms -> returnDs (CoCon con tys arg_atoms)) +mkErrorAppDs :: Id -- The error function + -> Type -- Type to which it should be applied + -> String -- The error message string to pass + -> DsM CoreExpr -mkCoPrimDs op tys arg_exprs - = dsExprsToAtoms arg_exprs (\ arg_atoms -> returnDs (CoPrim op tys arg_atoms)) +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} %************************************************************************ @@ -295,27 +347,20 @@ mkSelectorBinds :: [TyVar] -- Variables wrt which the pattern is polymorphic -> TypecheckedPat -- The pattern -> [(Id,Id)] -- Monomorphic and polymorphic binders for -- the pattern - -> PlainCoreExpr -- Expression to which the pattern is bound - -> DsM [(Id,PlainCoreExpr)] + -> CoreExpr -- Expression to which the pattern is bound + -> 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 = mkErrorCoApp 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 locals = [local | (local, _) <- locals_and_globals] local_tuple = mkTupleExpr locals - res_ty = typeOfCoreExpr local_tuple + res_ty = coreExprType local_tuple is_simple_tuple_pat (TuplePat ps) = all is_var_pat ps is_simple_tuple_pat other = False @@ -326,7 +371,7 @@ mkSelectorBinds tyvars pat locals_and_globals val_expr We're about to match against some patterns. We want to make some @Ids@ to use as match variables. If a pattern has an @Id@ readily at -hand, which should indeed be bound to the pattern as a whole, then use it; +hand, which should indeed be bound to the pattern as a whole, then use it; otherwise, make one up. \begin{code} selectMatchVars :: [TypecheckedPat] -> DsM [Id] @@ -336,27 +381,23 @@ selectMatchVars pats var_from_pat_maybe (VarPat var) = returnDs var var_from_pat_maybe (AsPat var pat) = returnDs var var_from_pat_maybe (LazyPat pat) = var_from_pat_maybe pat - --- var_from_pat_maybe (NPlusKPat n _ _ _ _ _) = returnDs n --- WRONG! We don't want to bind n to the pattern as a whole! - var_from_pat_maybe other_pat - = newSysLocalDs (typeOfPat other_pat) -- OK, better make up one... + = newSysLocalDs (outPatType other_pat) -- OK, better make up one... \end{code} \begin{code} mkTupleBind :: [TyVar] -- Abstract wrt these... -> [DictVar] -- ... and these - + -> [(Id, Id)] -- Local, global pairs, equal in number -- to the size of the tuple. The types -- of the globals is the generalisation of -- the corresp local, wrt the tyvars and dicts - - -> PlainCoreExpr -- Expr whose value is a tuple; the expression + + -> CoreExpr -- Expr whose value is a tuple; the expression -- may mention the tyvars and dicts - - -> DsM [(Id, PlainCoreExpr)] -- Bindings for the globals + + -> DsM [(Id, CoreExpr)] -- Bindings for the globals \end{code} The general call is @@ -377,22 +418,24 @@ Otherwise, the result is: \begin{code} mkTupleBind tyvars dicts [(local,global)] tuple_expr - = returnDs [(global, mkCoTyLam tyvars (mkCoLam dicts tuple_expr))] + = returnDs [(global, mkLam tyvars dicts tuple_expr)] \end{code} 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]) $ - zipWithDs (mk_selector (CoVar tuple_var)) + newSysLocalDs tuple_var_ty `thenDs` \ tuple_var -> + + zipWithDs (mk_selector (Var tuple_var)) local_global_prs [(0::Int) .. (length local_global_prs - 1)] `thenDs` \ tup_selectors -> returnDs ( - (tuple_var, mkCoTyLam tyvars (mkCoLam dicts tuple_expr)) : - tup_selectors + (tuple_var, mkLam tyvars dicts tuple_expr) + : tup_selectors ) where locals, globals :: [Id] @@ -400,18 +443,18 @@ 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 :: UniType + tuple_var_ty :: Type tuple_var_ty - = case (quantifyTy tyvars (mkRhoTy theta - (applyTyCon (mkTupleTyCon no_of_binders) - (map getIdUniType locals)))) of - (_{-tossed templates-}, ty) -> ty + = mkForAllTys tyvars $ + mkRhoTy theta $ + applyTyCon (mkTupleTyCon no_of_binders) + (map idType locals) where - theta = map (splitDictType . getIdUniType) dicts + theta = mkTheta (map idType dicts) - mk_selector :: PlainCoreExpr -> (Id, Id) -> Int -> DsM (Id, PlainCoreExpr) + mk_selector :: CoreExpr -> (Id, Id) -> Int -> DsM (Id, CoreExpr) mk_selector tuple_var_expr (local, global) which_local = mapDs duplicateLocalDs locals{-the whole bunch-} `thenDs` \ binders -> @@ -419,37 +462,33 @@ mkTupleBind tyvars dicts local_global_prs tuple_expr selected = binders !! which_local in returnDs ( - (global, mkCoTyLam tyvars ( - mkCoLam dicts ( - mkTupleSelector (mkCoApp_XX (mkCoTyApps tuple_var_expr tyvar_tys) dicts) - binders selected))) + global, + mkLam tyvars dicts ( + mkTupleSelector + (mkValApp (mkTyApp tuple_var_expr tyvar_tys) + (map VarArg dicts)) + binders + selected) ) - -mkCoApp_XX :: PlainCoreExpr -> [Id] -> PlainCoreExpr -mkCoApp_XX expr [] = expr -mkCoApp_XX expr (id:ids) = mkCoApp_XX (CoApp expr (CoVarAtom id)) ids \end{code} - - -@mkTupleExpr@ builds a tuple; the inverse to mkTupleSelector. -If it has only one element, it is -the identity function. - +@mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it +has only one element, it is the identity function. \begin{code} -mkTupleExpr :: [Id] -> PlainCoreExpr - -mkTupleExpr [] = CoCon (mkTupleCon 0) [] [] -mkTupleExpr [id] = CoVar id -mkTupleExpr ids = CoCon (mkTupleCon (length ids)) - (map getIdUniType ids) - [ CoVarAtom i | i <- ids ] +mkTupleExpr :: [Id] -> CoreExpr + +mkTupleExpr [] = Con (mkTupleCon 0) [] +mkTupleExpr [id] = Var id +mkTupleExpr ids = mkCon (mkTupleCon (length ids)) + [{-usages-}] + (map idType ids) + [ VarArg i | i <- ids ] \end{code} @mkTupleSelector@ builds a selector which scrutises the given expression and extracts the one name from the list given. -If you want the no-shadowing rule to apply, the caller +If you want the no-shadowing rule to apply, the caller is responsible for making sure that none of these names are in scope. @@ -457,10 +496,10 @@ If there is just one id in the ``tuple'', then the selector is just the identity. \begin{code} -mkTupleSelector :: PlainCoreExpr -- Scrutinee +mkTupleSelector :: CoreExpr -- Scrutinee -> [Id] -- The tuple args -> Id -- The selected one - -> PlainCoreExpr + -> CoreExpr mkTupleSelector expr [] the_var = panic "mkTupleSelector" @@ -468,9 +507,9 @@ mkTupleSelector expr [var] should_be_the_same_var = ASSERT(var == should_be_the_same_var) expr -mkTupleSelector expr vars the_var - = CoCase expr (CoAlgAlts [(mkTupleCon arity, vars, CoVar the_var)] - CoNoDefault) +mkTupleSelector expr vars the_var + = Case expr (AlgAlts [(mkTupleCon arity, vars, Var the_var)] + NoDefault) where arity = length vars \end{code} @@ -515,42 +554,40 @@ there is every chance that someone will change the let into a case: \end{verbatim} 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 +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} Now fail.33 is a function, so it can be let-bound. \begin{code} -mkFailurePair :: UniType -- Result type of the whole case expression - -> DsM (PlainCoreExpr -> PlainCoreBinding, - -- Binds the newly-created fail variable - -- to either the expression or \_ -> expression - PlainCoreExpr) -- Either the fail variable, or fail variable - -- applied to unit tuple +mkFailurePair :: Type -- Result type of the whole case expression + -> DsM (CoreExpr -> CoreBinding, + -- Binds the newly-created fail variable + -- to either the expression or \ _ -> expression + CoreExpr) -- Either the fail variable, or fail variable + -- applied to unit tuple mkFailurePair ty - | isUnboxedDataType ty - = newFailLocalDs (mkFunTy unit_ty ty) `thenDs` \ fail_fun_var -> - newSysLocalDs unit_ty `thenDs` \ fail_fun_arg -> - returnDs (\ body -> CoNonRec fail_fun_var (CoLam [fail_fun_arg] body), - CoApp (CoVar fail_fun_var) (CoVarAtom unit_id)) + | 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 voidId)) | otherwise = newFailLocalDs ty `thenDs` \ fail_var -> - returnDs (\ body -> CoNonRec fail_var body, CoVar 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 :: UniType -unit_ty = getIdUniType unit_id -\end{code}