X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsUtils.lhs;h=6bc70e2b8f56932cbe3ab2d2d3e83277ce65e896;hp=29e7773bb8c49bdc0838970314fd51999aa00ed4;hb=8100cd4395e46ae747be4298c181a4730d6206bc;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 29e7773..6bc70e2 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -1,7 +1,9 @@ % +% (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. @@ -17,7 +19,7 @@ module DsUtils ( extractMatchResult, combineMatchResults, adjustMatchResult, adjustMatchResultDs, mkCoLetMatchResult, mkGuardedMatchResult, - matchCanFail, + matchCanFail, mkEvalMatchResult, mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, wrapBind, wrapBinds, @@ -31,7 +33,8 @@ module DsUtils ( dsSyntaxTable, lookupEvidence, - selectSimpleMatchVarL, selectMatchVars, selectMatchVar + selectSimpleMatchVarL, selectMatchVars, selectMatchVar, + mkTickBox, mkOptTickBox, mkBinaryTickBox ) where #include "HsVersions.h" @@ -40,43 +43,37 @@ import {-# SOURCE #-} Match ( matchSimply ) 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 +import DynFlags #ifdef DEBUG -import Util ( notNull ) -- Used in an assertion +import Util #endif \end{code} @@ -148,12 +145,14 @@ otherwise, make one up. \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 @@ -161,23 +160,19 @@ selectSimpleMatchVarL pat = selectMatchVar (unLoc pat) (hsPatType pat) -- 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} @@ -236,7 +231,7 @@ combineMatchResults (MatchResult CanFail body_fn1) 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)) @@ -261,8 +256,11 @@ seqVar var body = Case (Var var) var (exprType 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) @@ -307,7 +305,9 @@ mkCoAlgCaseMatchResult var ty match_alts -- 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 @@ -551,7 +551,7 @@ mkSelectorBinds pat val_expr -- -- 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 @@ -587,15 +587,16 @@ mkSelectorBinds pat val_expr (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) @@ -881,4 +882,34 @@ mkFailurePair expr ty = exprType expr \end{code} - +\begin{code} +mkOptTickBox :: Maybe Int -> CoreExpr -> DsM CoreExpr +mkOptTickBox Nothing e = return e +mkOptTickBox (Just ix) e = mkTickBox ix e + +mkTickBox :: Int -> CoreExpr -> DsM CoreExpr +mkTickBox ix e = do + dflags <- getDOptsDs + uq <- newUnique + mod <- getModuleDs + let tick = mkTickBoxOpId uq mod ix + uq2 <- newUnique + let occName = mkVarOcc "tick" + let name = mkInternalName uq2 occName noSrcLoc -- use mkSysLocal? + let var = Id.mkLocalId name realWorldStatePrimTy + return $ Case (Var tick) + var + ty + [(DEFAULT,[],e)] + where + ty = exprType e + +mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr +mkBinaryTickBox ixT ixF e = do + mod <- getModuleDs + dflags <- getDOptsDs + uq <- newUnique + mod <- getModuleDs + let tick = mkBinaryTickBoxOpId uq mod ixT ixF + return $ App (Var tick) e +\end{code} \ No newline at end of file