%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-\section[DsUtils]{Utilities for desugaring}
+
+Utilities for desugaring
This module exports some utility functions of no great interest.
extractMatchResult, combineMatchResults,
adjustMatchResult, adjustMatchResultDs,
mkCoLetMatchResult, mkGuardedMatchResult,
- matchCanFail,
+ matchCanFail, mkEvalMatchResult,
mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
wrapBind, wrapBinds,
import {-# SOURCE #-} DsExpr( dsExpr )
import HsSyn
-import TcHsSyn ( hsPatType )
+import TcHsSyn
import CoreSyn
-import Constants ( mAX_TUPLE_SIZE )
+import Constants
import DsMonad
-import CoreUtils ( exprType, mkIfThenElse, mkCoerce, bindNonRec )
-import MkId ( iRREFUT_PAT_ERROR_ID, mkReboxingAlt, mkNewTypeBody )
-import Id ( idType, Id, mkWildId, mkTemplateLocals, mkSysLocal )
-import Var ( Var )
-import Name ( Name )
-import Literal ( Literal(..), mkStringLit, inIntRange, tARGET_MAX_INT )
-import TyCon ( isNewTyCon, tyConDataCons )
-import DataCon ( DataCon, dataConSourceArity, dataConTyCon, dataConTag )
-import Type ( mkFunTy, isUnLiftedType, Type, splitTyConApp, mkTyVarTy )
-import TcType ( tcEqType )
-import TysPrim ( intPrimTy )
-import TysWiredIn ( nilDataCon, consDataCon,
- tupleCon, mkTupleTy,
- unitDataConId, unitTy,
- charTy, charDataCon,
- intTy, intDataCon,
- isPArrFakeCon )
-import BasicTypes ( Boxity(..) )
-import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet )
-import UniqSupply ( splitUniqSupply, uniqFromSupply, uniqsFromSupply )
-import PrelNames ( unpackCStringName, unpackCStringUtf8Name,
- plusIntegerName, timesIntegerName, smallIntegerDataConName,
- lengthPName, indexPName )
+import CoreUtils
+import MkId
+import Id
+import Var
+import Name
+import Literal
+import TyCon
+import DataCon
+import Type
+import Coercion
+import TysPrim
+import TysWiredIn
+import BasicTypes
+import UniqSet
+import UniqSupply
+import PrelNames
import Outputable
-import SrcLoc ( Located(..), unLoc )
-import Util ( isSingleton, zipEqual, sortWith )
-import ListSetOps ( assocDefault )
+import SrcLoc
+import Util
+import ListSetOps
import FastString
-import Data.Char ( ord )
+import Data.Char
#ifdef DEBUG
-import Util ( notNull ) -- Used in an assertion
+import Util
#endif
\end{code}
\begin{code}
selectSimpleMatchVarL :: LPat Id -> DsM Id
-selectSimpleMatchVarL pat = selectMatchVar (unLoc pat) (hsPatType pat)
+selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)
-- (selectMatchVars ps tys) chooses variables of type tys
-- to use for matching ps against. If the pattern is a variable,
-- we try to use that, to save inventing lots of fresh variables.
--- But even if it is a variable, its type might not match. Consider
+--
+-- OLD, but interesting note:
+-- But even if it is a variable, its type might not match. Consider
-- data T a where
-- T1 :: Int -> T Int
-- T2 :: a -> T a
-- f :: T a -> a -> Int
-- f (T1 i) (x::Int) = x
-- f (T2 i) (y::a) = 0
--- Then we must not choose (x::Int) as the matching variable!
-
-selectMatchVars :: [Pat Id] -> [Type] -> DsM [Id]
-selectMatchVars [] [] = return []
-selectMatchVars (p:ps) (ty:tys) = do { v <- selectMatchVar p ty
- ; vs <- selectMatchVars ps tys
- ; return (v:vs) }
-
-selectMatchVar (BangPat pat) pat_ty = selectMatchVar (unLoc pat) pat_ty
-selectMatchVar (LazyPat pat) pat_ty = selectMatchVar (unLoc pat) pat_ty
-selectMatchVar (VarPat var) pat_ty = try_for var pat_ty
-selectMatchVar (AsPat var pat) pat_ty = try_for (unLoc var) pat_ty
-selectMatchVar other_pat pat_ty = newSysLocalDs pat_ty -- OK, better make up one...
-
-try_for var pat_ty
- | idType var `tcEqType` pat_ty = returnDs var
- | otherwise = newSysLocalDs pat_ty
+-- Then we must not choose (x::Int) as the matching variable!
+-- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat
+
+selectMatchVars :: [Pat Id] -> DsM [Id]
+selectMatchVars ps = mapM selectMatchVar ps
+
+selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat)
+selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)
+selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat)
+selectMatchVar (VarPat var) = return var
+selectMatchVar (AsPat var pat) = return (unLoc var)
+selectMatchVar other_pat = newSysLocalDs (hsPatType other_pat)
+ -- OK, better make up one...
\end{code}
combineMatchResults match_result1@(MatchResult CantFail body_fn1) match_result2
= match_result1
-adjustMatchResult :: (CoreExpr -> CoreExpr) -> MatchResult -> MatchResult
+adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult
adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
= MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body ->
returnDs (encl_fn body))
[(DEFAULT, [], body)]
mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
-mkCoLetMatchResult bind match_result
- = adjustMatchResult (mkDsLet bind) match_result
+mkCoLetMatchResult bind = adjustMatchResult (mkDsLet bind)
+
+mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
+mkEvalMatchResult var ty
+ = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)])
mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
mkGuardedMatchResult pred_expr (MatchResult can_it_fail body_fn)
-- Stuff for newtype
(con1, arg_ids1, match_result1) = head match_alts
arg_id1 = head arg_ids1
- newtype_rhs = mkNewTypeBody tycon (idType arg_id1) (Var var)
+ var_ty = idType var
+ (tc, ty_args) = splitNewTyConApp var_ty
+ newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
-- Stuff for data types
data_cons = tyConDataCons tycon
--
-- So to get the type of 'v', use the pattern not the rhs. Often more
-- efficient too.
- newSysLocalDs (hsPatType pat) `thenDs` \ val_var ->
+ newSysLocalDs (hsLPatType pat) `thenDs` \ val_var ->
-- For the error message we make one error-app, to avoid duplication.
-- But we need it at different types... so we use coerce for that
(Var bndr_var) error_expr `thenDs` \ rhs_expr ->
returnDs (bndr_var, rhs_expr)
where
- error_expr = mkCoerce (idType bndr_var) (Var err_var)
+ error_expr = mkCoerce co (Var err_var)
+ co = mkUnsafeCoercion (exprType (Var err_var)) (idType bndr_var)
is_simple_lpat p = is_simple_pat (unLoc p)
- is_simple_pat (TuplePat ps Boxed _) = all is_triv_lpat ps
- is_simple_pat (ConPatOut _ _ _ _ ps _) = all is_triv_lpat (hsConArgs ps)
- is_simple_pat (VarPat _) = True
- is_simple_pat (ParPat p) = is_simple_lpat p
- is_simple_pat other = False
+ is_simple_pat (TuplePat ps Boxed _) = all is_triv_lpat ps
+ is_simple_pat (ConPatOut{ pat_args = ps }) = all is_triv_lpat (hsConArgs ps)
+ is_simple_pat (VarPat _) = True
+ is_simple_pat (ParPat p) = is_simple_lpat p
+ is_simple_pat other = False
is_triv_lpat p = is_triv_pat (unLoc p)