%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[DsUtils]{Utilities for desugaring}
combineMatchResults,
dsExprToAtom,
mkCoAlgCaseMatchResult,
- mkCoAppDs,
- mkCoConDs,
+ mkAppDs, mkConDs, mkPrimDs,
mkCoLetsMatchResult,
mkCoPrimCaseMatchResult,
- mkCoPrimDs,
mkFailurePair,
mkGuardedMatchResult,
mkSelectorBinds,
selectMatchVars
) 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
- )
-import Maybes ( Maybe(..) )
-import Match ( match, matchSimply )
-import Pretty
-import Unique ( initUs, UniqueSupply, UniqSM(..) )
-import UniqSet
-import Util
+import Ubiq
+import DsLoop ( match, matchSimply )
+
+import HsSyn ( HsExpr(..), OutPat(..), HsLit(..),
+ Match, HsBinds, Stmt, Qual, PolyType, ArithSeqInfo )
+import TcHsSyn ( 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"
\end{code}
%************************************************************************
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
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!
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
)
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)
((_,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
= -- 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
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
+ scrut_ty = idType var
+ (tycon, tycon_arg_tys, data_cons) = getAppDataTyCon scrut_ty
un_mentioned_constructors
= uniqSetToList (mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- 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
-- 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
%************************************************************************
\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 :: CoreExpr -- 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 (CoVar v) continue_with = continue_with (CoVarAtom v)
-dsExprToAtom (CoLit v) continue_with = continue_with (CoLitAtom v)
+dsExprToAtom (Var v) continue_with = continue_with (VarArg v)
+dsExprToAtom (Lit v) continue_with = continue_with (LitArg 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
+ = let
+ ty = coreExprType arg_expr
+ in
+ newSysLocalDs ty `thenDs` \ arg_id ->
+ continue_with (VarArg arg_id) `thenDs` \ body ->
+ returnDs (
+ if isUnboxedDataType ty
+ then Case arg_expr (PrimAlts [] (BindDefault arg_id body))
+ else Let (NonRec arg_id arg_expr) body
+ )
-dsExprsToAtoms :: [PlainCoreExpr]
- -> ([PlainCoreAtom] -> DsM PlainCoreExpr)
- -> DsM PlainCoreExpr
+dsExprsToAtoms :: [CoreExpr]
+ -> ([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@
+Plumb the desugarer's @UniqueSupply@ in/out of the @UniqSupply@ monad
world.
\begin{code}
-mkCoAppDs :: PlainCoreExpr -> PlainCoreExpr -> DsM PlainCoreExpr
-mkCoConDs :: Id -> [UniType] -> [PlainCoreExpr] -> DsM PlainCoreExpr
-mkCoPrimDs :: PrimOp -> [UniType] -> [PlainCoreExpr] -> DsM PlainCoreExpr
+mkAppDs :: CoreExpr -> [Type] -> [CoreExpr] -> DsM CoreExpr
+mkConDs :: Id -> [Type] -> [CoreExpr] -> DsM CoreExpr
+mkPrimDs :: PrimOp -> [Type] -> [CoreExpr] -> DsM CoreExpr
-mkCoAppDs fun arg_expr
- = dsExprToAtom arg_expr (\ arg_atom -> returnDs (CoApp fun arg_atom))
+mkAppDs fun tys arg_exprs
+ = dsExprsToAtoms arg_exprs $ \ vals ->
+ returnDs (mkApp fun [] tys vals)
-mkCoConDs con tys arg_exprs
- = dsExprsToAtoms arg_exprs (\ arg_atoms -> returnDs (CoCon con tys arg_atoms))
+mkConDs con tys arg_exprs
+ = dsExprsToAtoms arg_exprs $ \ vals ->
+ returnDs (mkCon con [] tys vals)
-mkCoPrimDs op tys arg_exprs
- = dsExprsToAtoms arg_exprs (\ arg_atoms -> returnDs (CoPrim op tys arg_atoms))
+mkPrimDs op tys arg_exprs
+ = dsExprsToAtoms arg_exprs $ \ vals ->
+ returnDs (mkPrim op [] tys vals)
\end{code}
%************************************************************************
-> 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) ->
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
+ error_msg = mkErrorApp res_ty str_var error_string
in
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
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]
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
\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:
mkTupleBind tyvars dicts local_global_prs tuple_expr
= newSysLocalDs tuple_var_ty `thenDs` \ tuple_var ->
- zipWithDs (mk_selector (CoVar 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]
no_of_binders = length local_global_prs
tyvar_tys = map mkTyVarTy 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
+ (applyTyCon (mkTupleTyCon no_of_binders)
+ (map idType locals)))) of
(_{-tossed templates-}, ty) -> ty
where
- theta = map (splitDictType . getIdUniType) dicts
+ theta = map (splitDictType . 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 ->
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 (mkApp_XX (mkCoTyApps tuple_var_expr tyvar_tys) dicts)
+ binders selected)
)
-mkCoApp_XX :: PlainCoreExpr -> [Id] -> PlainCoreExpr
-mkCoApp_XX expr [] = expr
-mkCoApp_XX expr (id:ids) = mkCoApp_XX (CoApp expr (CoVarAtom id)) ids
+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.
-
+@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.
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"
= 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}
\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#
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))
+ = newFailLocalDs (mkFunTys [unit_ty] ty) `thenDs` \ fail_fun_var ->
+ newSysLocalDs unit_ty `thenDs` \ fail_fun_arg ->
+ returnDs (\ body ->
+ NonRec fail_fun_var (Lam (ValBinder fail_fun_arg) body),
+ App (Var fail_fun_var) (VarArg unit_id))
| otherwise
= newFailLocalDs ty `thenDs` \ fail_var ->
- returnDs (\ body -> CoNonRec fail_var body, CoVar fail_var)
+ returnDs (\ body -> NonRec fail_var body, Var fail_var)
unit_id :: Id -- out here to avoid CAF (sigh)
unit_id = mkTupleCon 0
-unit_ty :: UniType
-unit_ty = getIdUniType unit_id
+unit_ty :: Type
+unit_ty = idType unit_id
\end{code}
projects / ghc-hetmet.git / blobdiff