Forked from
Glasgow Haskell Compiler / GHC
67350 commits behind the upstream repository.
Code owners
Assign users and groups as approvers for specific file changes. Learn more.
DsUtils.lhs 16.87 KiB
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[DsUtils]{Utilities for desugaring}
This module exports some utility functions of no great interest.
\begin{code}
#include "HsVersions.h"
module DsUtils (
CanItFail(..), EquationInfo(..), MatchResult(..),
combineGRHSMatchResults,
combineMatchResults,
dsExprToAtom, SYN_IE(DsCoreArg),
mkCoAlgCaseMatchResult,
mkAppDs, mkConDs, mkPrimDs, mkErrorAppDs,
mkCoLetsMatchResult,
mkCoPrimCaseMatchResult,
mkFailurePair,
mkGuardedMatchResult,
mkSelectorBinds,
mkTupleBind,
mkTupleExpr,
mkTupleSelector,
selectMatchVars,
showForErr
) where
IMP_Ubiq()
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
IMPORT_DELOOPER(DsLoop) ( match, matchSimply )
#else
import {-# SOURCE #-} Match (match, matchSimply )
#endif
import HsSyn ( HsExpr(..), OutPat(..), HsLit(..), Fixity,
Match, HsBinds, Stmt, DoOrListComp, HsType, ArithSeqInfo )
import TcHsSyn ( SYN_IE(TypecheckedPat) )
import DsHsSyn ( outPatType, collectTypedPatBinders )
import CmdLineOpts ( opt_PprUserLength )
import CoreSyn
import DsMonad
import CoreUtils ( coreExprType, mkCoreIfThenElse )
import PrelVals ( iRREFUT_PAT_ERROR_ID, voidId )
import Pretty ( Doc, hcat, text )
import Id ( idType, dataConArgTys,
-- pprId{-ToDo:rm-},
SYN_IE(DataCon), SYN_IE(DictVar), SYN_IE(Id), GenId )
import Literal ( Literal(..) )
import PprType ( GenType, GenTyVar )
import PrimOp ( PrimOp )
import TyCon ( isNewTyCon, tyConDataCons )
import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTy,
mkTheta, isUnboxedType, applyTyCon, getAppTyCon,
GenType {- instances -}, SYN_IE(Type)
)
import TyVar ( GenTyVar {- instances -}, SYN_IE(TyVar) )
import TysPrim ( voidTy )
import TysWiredIn ( tupleTyCon, unitDataCon, tupleCon )
import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, SYN_IE(UniqSet) )
import Util ( panic, assertPanic{-, pprTrace ToDo:rm-} )
import Unique ( Unique )
import Usage ( SYN_IE(UVar) )
import SrcLoc ( SrcLoc {- instance Outputable -} )
import Outputable
\end{code}
%************************************************************************
%* *
%* Selecting match variables
%* *
%************************************************************************
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;
otherwise, make one up.
\begin{code}
selectMatchVars :: [TypecheckedPat] -> DsM [Id]
selectMatchVars pats
= mapDs var_from_pat_maybe pats
where
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 other_pat
= newSysLocalDs (outPatType other_pat) -- OK, better make up one...
\end{code}
%************************************************************************
%* *
%* type synonym EquationInfo and access functions for its pieces *
%* *
%************************************************************************
\subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
The ``equation info'' used by @match@ is relatively complicated and
worthy of a type synonym and a few handy functions.
\begin{code}
data EquationInfo
= EqnInfo
[TypecheckedPat] -- the patterns for an eqn
MatchResult -- Encapsulates the guards and bindings
\end{code}
\begin{code}
data MatchResult
= MatchResult
CanItFail
Type -- Type of argument expression
(CoreExpr -> CoreExpr)
-- Takes a expression to plug in at the
-- failure point(s). The expression should
-- be duplicatable!
DsMatchContext -- The context info is used when producing warnings
-- about shadowed patterns. It's the context
-- of the *first* thing matched in this group.
-- Should perhaps be a list of them all!
data CanItFail = CanFail | CantFail
orFail CantFail CantFail = CantFail
orFail _ _ = CanFail
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 :: CoreExpr -> MatchResult -> DsM MatchResult
mkGuardedMatchResult pred_expr (MatchResult can_it_fail ty body_fn cxt)
= returnDs (MatchResult CanFail
ty
(\fail -> mkCoreIfThenElse pred_expr (body_fn fail) fail)
cxt
)
mkCoPrimCaseMatchResult :: Id -- Scrutinee
-> [(Literal, MatchResult)] -- Alternatives
-> DsM MatchResult
mkCoPrimCaseMatchResult var alts
= newSysLocalDs (idType var) `thenDs` \ wild ->
returnDs (MatchResult CanFail
ty1
(mk_case alts wild)
cxt1)
where
((_,MatchResult _ ty1 _ cxt1) : _) = alts
mk_case alts wild fail_expr
= Case (Var var) (PrimAlts final_alts (BindDefault wild fail_expr))
where
final_alts = [ (lit, body_fn fail_expr)
| (lit, MatchResult _ _ body_fn _) <- 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
[] -> -- All constructors mentioned, so no default needed
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,
-- and figuring out their types is somewhat tiresome.
let
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 -> 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 -> BindDefault wild fail_expr))
cxt1)
where
-- 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] )
match_results = [match_result | (_,_,match_result) <- alts]
(MatchResult _ ty1 _ cxt1 : _) = match_results
can_any_alt_fail = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ _ _ <- match_results]
mk_case alts deflt_fn fail_expr
= Case (Var var) (AlgAlts final_alts (deflt_fn fail_expr))
where
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)
= mkFailurePair ty1 `thenDs` \ (bind_fn, duplicatable_expr) ->
let
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)
match_result2
= returnDs match_result1
-- The difference in combineGRHSMatchResults is that there is no
-- 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)
= returnDs (MatchResult can_it_fail ty1 (\ body -> body_fn1 (body_fn2 body)) cxt1)
combineGRHSMatchResults match_result1 match_result2
= -- Delegate to avoid duplication of code
combineMatchResults match_result1 match_result2
\end{code}
%************************************************************************
%* *
\subsection[dsExprToAtom]{Take an expression and produce an atom}
%* *
%************************************************************************
\begin{code}
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 (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 (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 ->
continue_with (arg_atom:arg_atoms)
\end{code}
%************************************************************************
%* *
\subsection{Desugarer's versions of some Core functions}
%* *
%************************************************************************
\begin{code}
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)
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 = show (ppr PprQuote 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` \ src_loc ->
let
full_msg = show (hcat [ppr (PprForUser opt_PprUserLength) src_loc, text "|", text msg])
msg_lit = NoRepStr (_PK_ full_msg)
in
returnDs (mkApp (Var err_id) [] [ty] [LitArg msg_lit])
\end{code}
%************************************************************************
%* *
\subsection[mkSelectorBind]{Make a selector bind}
%* *
%************************************************************************
This is used in various places to do with lazy patterns.
For each binder $b$ in the pattern, we create a binding:
b = case v of pat' -> b'
where pat' is pat with each binder b cloned into b'.
ToDo: making these bindings should really depend on whether there's
much work to be done per binding. If the pattern is complex, it
should be de-mangled once, into a tuple (and then selected from).
Otherwise the demangling can be in-line in the bindings (as here).
Boring! Boring! One error message per binder. The above ToDo is
even more helpful. Something very similar happens for pattern-bound
expressions.
\begin{code}
mkSelectorBinds :: TypecheckedPat -- The pattern
-> CoreExpr -- Expression to which the pattern is bound
-> DsM [(Id,CoreExpr)]
mkSelectorBinds (VarPat v) val_expr
= returnDs [(v, val_expr)]
mkSelectorBinds pat val_expr
| is_simple_tuple_pat pat
= mkTupleBind binders val_expr
| otherwise
= mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty pat_string `thenDs` \ error_msg ->
matchSimply val_expr pat res_ty local_tuple error_msg `thenDs` \ tuple_expr ->
mkTupleBind binders tuple_expr
where
binders = collectTypedPatBinders pat
local_tuple = mkTupleExpr binders
res_ty = coreExprType local_tuple
is_simple_tuple_pat (TuplePat ps) = all is_var_pat ps
is_simple_tuple_pat other = False
is_var_pat (VarPat v) = True
is_var_pat other = False -- Even wild-card patterns aren't acceptable
pat_string = show (ppr (PprForUser opt_PprUserLength) pat)
\end{code}
\begin{code}
mkTupleBind :: [Id] -- Names of tuple components
-> CoreExpr -- Expr whose value is a tuple of correct type
-> DsM [(Id, CoreExpr)] -- Bindings for the globals
mkTupleBind [local] tuple_expr
= returnDs [(local, tuple_expr)]
mkTupleBind locals tuple_expr
= newSysLocalDs (coreExprType tuple_expr) `thenDs` \ tuple_var ->
let
mk_bind local = (local, mkTupleSelector locals local (Var tuple_var))
in
returnDs ( (tuple_var, tuple_expr) :
map mk_bind locals )
\end{code}
@mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it
has only one element, it is the identity function.
\begin{code}
mkTupleExpr :: [Id] -> CoreExpr
mkTupleExpr [] = Con unitDataCon []
mkTupleExpr [id] = Var id
mkTupleExpr ids = mkCon (tupleCon (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
is responsible for making sure that none of these names
are in scope.
If there is just one id in the ``tuple'', then the selector is
just the identity.
\begin{code}
mkTupleSelector :: [Id] -- The tuple args
-> Id -- The selected one
-> CoreExpr -- Scrutinee
-> CoreExpr
mkTupleSelector [] the_var scrut = panic "mkTupleSelector"
mkTupleSelector [var] should_be_the_same_var scrut
= ASSERT(var == should_be_the_same_var)
scrut
mkTupleSelector vars the_var scrut
= Case scrut (AlgAlts [(tupleCon arity, vars, Var the_var)]
NoDefault)
where
arity = length vars
\end{code}
%************************************************************************
%* *
\subsection[mkFailurePair]{Code for pattern-matching and other failures}
%* *
%************************************************************************
Generally, we handle pattern matching failure like this: let-bind a
fail-variable, and use that variable if the thing fails:
\begin{verbatim}
let fail.33 = error "Help"
in
case x of
p1 -> ...
p2 -> fail.33
p3 -> fail.33
p4 -> ...
\end{verbatim}
Then
\begin{itemize}
\item
If the case can't fail, then there'll be no mention of fail.33, and the
simplifier will later discard it.
\item
If it can fail in only one way, then the simplifier will inline it.
\item
Only if it is used more than once will the let-binding remain.
\end{itemize}
There's a problem when the result of the case expression is of
unboxed type. Then the type of fail.33 is unboxed too, and
there is every chance that someone will change the let into a case:
\begin{verbatim}
case error "Help" of
fail.33 -> 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
for the primitive case:
\begin{verbatim}
let fail.33 :: Void -> Int#
fail.33 = \_ -> error "Help"
in
case x of
p1 -> ...
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 :: 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
| 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 -> NonRec fail_var body, Var fail_var)
\end{code}