compiler/deSugar/DsUtils.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 Utilities for desugaring
   7
   8 This module exports some utility functions of no great interest.
   9
  10 \begin{code}
  11 module DsUtils (
  12         EquationInfo(..),
  13         firstPat, shiftEqns,
  14
  15         mkDsLet, mkDsLets, mkDsApp, mkDsApps,
  16
  17         MatchResult(..), CanItFail(..),
  18         cantFailMatchResult, alwaysFailMatchResult,
  19         extractMatchResult, combineMatchResults,
  20         adjustMatchResult,  adjustMatchResultDs,
  21         mkCoLetMatchResult, mkGuardedMatchResult,
  22         matchCanFail, mkEvalMatchResult,
  23         mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
  24         wrapBind, wrapBinds,
  25
  26         mkErrorAppDs, mkNilExpr, mkConsExpr, mkListExpr,
  27         mkIntExpr, mkCharExpr,
  28         mkStringExpr, mkStringExprFS, mkIntegerExpr,
  29
  30         mkSelectorBinds, mkTupleExpr, mkTupleSelector,
  31         mkTupleType, mkTupleCase, mkBigCoreTup,
  32         mkCoreTup, mkCoreTupTy, seqVar,
  33
  34         dsSyntaxTable, lookupEvidence,
  35
  36         selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
  37         mkTickBox, mkOptTickBox, mkBinaryTickBox
  38     ) where
  39
  40 #include "HsVersions.h"
  41
  42 import {-# SOURCE #-}   Match ( matchSimply )
  43 import {-# SOURCE #-}   DsExpr( dsExpr )
  44
  45 import HsSyn
  46 import TcHsSyn
  47 import CoreSyn
  48 import Constants
  49 import DsMonad
  50
  51 import CoreUtils
  52 import MkId
  53 import Id
  54 import Var
  55 import Name
  56 import Literal
  57 import TyCon
  58 import DataCon
  59 import Type
  60 import Coercion
  61 import TysPrim
  62 import TysWiredIn
  63 import BasicTypes
  64 import UniqSet
  65 import UniqSupply
  66 import PrelNames
  67 import Outputable
  68 import SrcLoc
  69 import Util
  70 import ListSetOps
  71 import FastString
  72 import Data.Char
  73
  74 infixl 4 `mkDsApp`, `mkDsApps`
  75 \end{code}
  76
  77
  78
  79 %************************************************************************
  80 %*                                                                      *
  81                 Rebindable syntax
  82 %*                                                                      *
  83 %************************************************************************
  84
  85 \begin{code}
  86 dsSyntaxTable :: SyntaxTable Id
  87                -> DsM ([CoreBind],      -- Auxiliary bindings
  88                        [(Name,Id)])     -- Maps the standard name to its value
  89
  90 dsSyntaxTable rebound_ids
  91   = mapAndUnzipDs mk_bind rebound_ids   `thenDs` \ (binds_s, prs) ->
  92     return (concat binds_s, prs)
  93   where
  94         -- The cheapo special case can happen when we
  95         -- make an intermediate HsDo when desugaring a RecStmt
  96     mk_bind (std_name, HsVar id) = return ([], (std_name, id))
  97     mk_bind (std_name, expr)
  98          = dsExpr expr                          `thenDs` \ rhs ->
  99            newSysLocalDs (exprType rhs)         `thenDs` \ id ->
 100            return ([NonRec id rhs], (std_name, id))
 101
 102 lookupEvidence :: [(Name, Id)] -> Name -> Id
 103 lookupEvidence prs std_name
 104   = assocDefault (mk_panic std_name) prs std_name
 105   where
 106     mk_panic std_name = pprPanic "dsSyntaxTable" (ptext SLIT("Not found:") <+> ppr std_name)
 107 \end{code}
 108
 109
 110 %************************************************************************
 111 %*                                                                      *
 112 \subsection{Building lets}
 113 %*                                                                      *
 114 %************************************************************************
 115
 116 Use case, not let for unlifted types.  The simplifier will turn some
 117 back again.
 118
 119 \begin{code}
 120 mkDsLet :: CoreBind -> CoreExpr -> CoreExpr
 121 mkDsLet (NonRec bndr rhs) body  -- See Note [CoreSyn let/app invariant]
 122   | isUnLiftedType (idType bndr) && not (exprOkForSpeculation rhs)
 123   = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
 124 mkDsLet bind body
 125   = Let bind body
 126
 127 mkDsLets :: [CoreBind] -> CoreExpr -> CoreExpr
 128 mkDsLets binds body = foldr mkDsLet body binds
 129
 130 -----------
 131 mkDsApp :: CoreExpr -> CoreExpr -> CoreExpr
 132 -- Check the invariant that the arg of an App is ok-for-speculation if unlifted
 133 -- See CoreSyn Note [CoreSyn let/app invariant]
 134 mkDsApp fun (Type ty) = App fun (Type ty)
 135 mkDsApp fun arg       = mk_val_app fun arg arg_ty res_ty
 136                       where
 137                         (arg_ty, res_ty) = splitFunTy (exprType fun)
 138
 139 -----------
 140 mkDsApps :: CoreExpr -> [CoreExpr] -> CoreExpr
 141 -- Slightly more efficient version of (foldl mkDsApp)
 142 mkDsApps fun args
 143   = go fun (exprType fun) args
 144   where
 145     go fun fun_ty []               = fun
 146     go fun fun_ty (Type ty : args) = go (App fun (Type ty)) (applyTy fun_ty ty) args
 147     go fun fun_ty (arg     : args) = go (mk_val_app fun arg arg_ty res_ty) res_ty args
 148                                    where
 149                                      (arg_ty, res_ty) = splitFunTy fun_ty
 150 -----------
 151 mk_val_app fun arg arg_ty res_ty        -- See Note [CoreSyn let/app invariant]
 152   | not (isUnLiftedType arg_ty) || exprOkForSpeculation arg
 153   = App fun arg         -- The vastly common case
 154
 155 mk_val_app (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2 _ res_ty
 156   | f == seqId          -- Note [Desugaring seq]
 157   = Case arg1 (mkWildId ty1) res_ty [(DEFAULT,[],arg2)]
 158
 159 mk_val_app fun arg arg_ty res_ty
 160   = Case arg (mkWildId arg_ty) res_ty [(DEFAULT,[],App fun (Var arg_id))]
 161   where
 162     arg_id = mkWildId arg_ty    -- Lots of shadowing, but it doesn't matter,
 163                                 -- because 'fun ' should not have a free wild-id
 164 \end{code}
 165
 166 Note [Desugaring seq]  cf Trac #1031
 167 ~~~~~~~~~~~~~~~~~~~~~
 168    f x y = x `seq` (y `seq` (# x,y #))
 169
 170 The [CoreSyn let/app invariant] means that, other things being equal, because
 171 the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:
 172
 173    f x y = case (y `seq` (# x,y #)) of v -> x `seq` v
 174
 175 But that is bad for two reasons:
 176   (a) we now evaluate y before x, and
 177   (b) we can't bind v to an unboxed pair
 178
 179 Seq is very, very special!  So we recognise it right here, and desugar to
 180         case x of _ -> case y of _ -> (# x,y #)
 181
 182 The special case would be valid for all calls to 'seq', but it's only *necessary*
 183 for ones whose second argument has an unlifted type. So we only catch the latter
 184 case here, to avoid unnecessary tests.
 185
 186
 187 %************************************************************************
 188 %*                                                                      *
 189 \subsection{ Selecting match variables}
 190 %*                                                                      *
 191 %************************************************************************
 192
 193 We're about to match against some patterns.  We want to make some
 194 @Ids@ to use as match variables.  If a pattern has an @Id@ readily at
 195 hand, which should indeed be bound to the pattern as a whole, then use it;
 196 otherwise, make one up.
 197
 198 \begin{code}
 199 selectSimpleMatchVarL :: LPat Id -> DsM Id
 200 selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)
 201
 202 -- (selectMatchVars ps tys) chooses variables of type tys
 203 -- to use for matching ps against.  If the pattern is a variable,
 204 -- we try to use that, to save inventing lots of fresh variables.
 205 --
 206 -- OLD, but interesting note:
 207 --    But even if it is a variable, its type might not match.  Consider
 208 --      data T a where
 209 --        T1 :: Int -> T Int
 210 --        T2 :: a   -> T a
 211 --
 212 --      f :: T a -> a -> Int
 213 --      f (T1 i) (x::Int) = x
 214 --      f (T2 i) (y::a)   = 0
 215 --    Then we must not choose (x::Int) as the matching variable!
 216 -- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat
 217
 218 selectMatchVars :: [Pat Id] -> DsM [Id]
 219 selectMatchVars ps = mapM selectMatchVar ps
 220
 221 selectMatchVar (BangPat pat)   = selectMatchVar (unLoc pat)
 222 selectMatchVar (LazyPat pat)   = selectMatchVar (unLoc pat)
 223 selectMatchVar (ParPat pat)    = selectMatchVar (unLoc pat)
 224 selectMatchVar (VarPat var)    = return var
 225 selectMatchVar (AsPat var pat) = return (unLoc var)
 226 selectMatchVar other_pat       = newSysLocalDs (hsPatType other_pat)
 227                                   -- OK, better make up one...
 228 \end{code}
 229
 230
 231 %************************************************************************
 232 %*                                                                      *
 233 %* type synonym EquationInfo and access functions for its pieces        *
 234 %*                                                                      *
 235 %************************************************************************
 236 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
 237
 238 The ``equation info'' used by @match@ is relatively complicated and
 239 worthy of a type synonym and a few handy functions.
 240
 241 \begin{code}
 242 firstPat :: EquationInfo -> Pat Id
 243 firstPat eqn = head (eqn_pats eqn)
 244
 245 shiftEqns :: [EquationInfo] -> [EquationInfo]
 246 -- Drop the first pattern in each equation
 247 shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]
 248 \end{code}
 249
 250 Functions on MatchResults
 251
 252 \begin{code}
 253 matchCanFail :: MatchResult -> Bool
 254 matchCanFail (MatchResult CanFail _)  = True
 255 matchCanFail (MatchResult CantFail _) = False
 256
 257 alwaysFailMatchResult :: MatchResult
 258 alwaysFailMatchResult = MatchResult CanFail (\fail -> returnDs fail)
 259
 260 cantFailMatchResult :: CoreExpr -> MatchResult
 261 cantFailMatchResult expr = MatchResult CantFail (\ ignore -> returnDs expr)
 262
 263 extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
 264 extractMatchResult (MatchResult CantFail match_fn) fail_expr
 265   = match_fn (error "It can't fail!")
 266
 267 extractMatchResult (MatchResult CanFail match_fn) fail_expr
 268   = mkFailurePair fail_expr             `thenDs` \ (fail_bind, if_it_fails) ->
 269     match_fn if_it_fails                `thenDs` \ body ->
 270     returnDs (mkDsLet fail_bind body)
 271
 272
 273 combineMatchResults :: MatchResult -> MatchResult -> MatchResult
 274 combineMatchResults (MatchResult CanFail      body_fn1)
 275                     (MatchResult can_it_fail2 body_fn2)
 276   = MatchResult can_it_fail2 body_fn
 277   where
 278     body_fn fail = body_fn2 fail                        `thenDs` \ body2 ->
 279                    mkFailurePair body2                  `thenDs` \ (fail_bind, duplicatable_expr) ->
 280                    body_fn1 duplicatable_expr           `thenDs` \ body1 ->
 281                    returnDs (Let fail_bind body1)
 282
 283 combineMatchResults match_result1@(MatchResult CantFail body_fn1) match_result2
 284   = match_result1
 285
 286 adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult
 287 adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
 288   = MatchResult can_it_fail (\fail -> body_fn fail      `thenDs` \ body ->
 289                                       returnDs (encl_fn body))
 290
 291 adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
 292 adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
 293   = MatchResult can_it_fail (\fail -> body_fn fail      `thenDs` \ body ->
 294                                       encl_fn body)
 295
 296 wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr
 297 wrapBinds [] e = e
 298 wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
 299
 300 wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
 301 wrapBind new old body
 302   | new==old    = body
 303   | isTyVar new = App (Lam new body) (Type (mkTyVarTy old))
 304   | otherwise   = Let (NonRec new (Var old)) body
 305
 306 seqVar :: Var -> CoreExpr -> CoreExpr
 307 seqVar var body = Case (Var var) var (exprType body)
 308                         [(DEFAULT, [], body)]
 309
 310 mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
 311 mkCoLetMatchResult bind = adjustMatchResult (mkDsLet bind)
 312
 313 mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
 314 mkEvalMatchResult var ty
 315   = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)])
 316
 317 mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
 318 mkGuardedMatchResult pred_expr (MatchResult can_it_fail body_fn)
 319   = MatchResult CanFail (\fail -> body_fn fail  `thenDs` \ body ->
 320                                   returnDs (mkIfThenElse pred_expr body fail))
 321
 322 mkCoPrimCaseMatchResult :: Id                           -- Scrutinee
 323                     -> Type                             -- Type of the case
 324                     -> [(Literal, MatchResult)]         -- Alternatives
 325                     -> MatchResult
 326 mkCoPrimCaseMatchResult var ty match_alts
 327   = MatchResult CanFail mk_case
 328   where
 329     mk_case fail
 330       = mappM (mk_alt fail) sorted_alts         `thenDs` \ alts ->
 331         returnDs (Case (Var var) var ty ((DEFAULT, [], fail) : alts))
 332
 333     sorted_alts = sortWith fst match_alts       -- Right order for a Case
 334     mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail     `thenDs` \ body ->
 335                                                returnDs (LitAlt lit, [], body)
 336
 337
 338 mkCoAlgCaseMatchResult :: Id                                    -- Scrutinee
 339                     -> Type                                     -- Type of exp
 340                     -> [(DataCon, [CoreBndr], MatchResult)]     -- Alternatives
 341                     -> MatchResult
 342 mkCoAlgCaseMatchResult var ty match_alts
 343   | isNewTyCon tycon            -- Newtype case; use a let
 344   = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
 345     mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
 346
 347   | isPArrFakeAlts match_alts   -- Sugared parallel array; use a literal case
 348   = MatchResult CanFail mk_parrCase
 349
 350   | otherwise                   -- Datatype case; use a case
 351   = MatchResult fail_flag mk_case
 352   where
 353     tycon = dataConTyCon con1
 354         -- [Interesting: becuase of GADTs, we can't rely on the type of
 355         --  the scrutinised Id to be sufficiently refined to have a TyCon in it]
 356
 357         -- Stuff for newtype
 358     (con1, arg_ids1, match_result1) = head match_alts
 359     arg_id1     = head arg_ids1
 360     var_ty      = idType var
 361     (tc, ty_args) = splitNewTyConApp var_ty
 362     newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
 363
 364         -- Stuff for data types
 365     data_cons      = tyConDataCons tycon
 366     match_results  = [match_result | (_,_,match_result) <- match_alts]
 367
 368     fail_flag | exhaustive_case
 369               = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
 370               | otherwise
 371               = CanFail
 372
 373     wild_var = mkWildId (idType var)
 374     sorted_alts  = sortWith get_tag match_alts
 375     get_tag (con, _, _) = dataConTag con
 376     mk_case fail = mappM (mk_alt fail) sorted_alts      `thenDs` \ alts ->
 377                    returnDs (Case (Var var) wild_var ty (mk_default fail ++ alts))
 378
 379     mk_alt fail (con, args, MatchResult _ body_fn)
 380         = body_fn fail                          `thenDs` \ body ->
 381           newUniqueSupply                       `thenDs` \ us ->
 382           returnDs (mkReboxingAlt (uniqsFromSupply us) con args body)
 383
 384     mk_default fail | exhaustive_case = []
 385                     | otherwise       = [(DEFAULT, [], fail)]
 386
 387     un_mentioned_constructors
 388         = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
 389     exhaustive_case = isEmptyUniqSet un_mentioned_constructors
 390
 391         -- Stuff for parallel arrays
 392         --
 393         --  * the following is to desugar cases over fake constructors for
 394         --   parallel arrays, which are introduced by `tidy1' in the `PArrPat'
 395         --   case
 396         --
 397         -- Concerning `isPArrFakeAlts':
 398         --
 399         --  * it is *not* sufficient to just check the type of the type
 400         --   constructor, as we have to be careful not to confuse the real
 401         --   representation of parallel arrays with the fake constructors;
 402         --   moreover, a list of alternatives must not mix fake and real
 403         --   constructors (this is checked earlier on)
 404         --
 405         -- FIXME: We actually go through the whole list and make sure that
 406         --        either all or none of the constructors are fake parallel
 407         --        array constructors.  This is to spot equations that mix fake
 408         --        constructors with the real representation defined in
 409         --        `PrelPArr'.  It would be nicer to spot this situation
 410         --        earlier and raise a proper error message, but it can really
 411         --        only happen in `PrelPArr' anyway.
 412         --
 413     isPArrFakeAlts [(dcon, _, _)]      = isPArrFakeCon dcon
 414     isPArrFakeAlts ((dcon, _, _):alts) =
 415       case (isPArrFakeCon dcon, isPArrFakeAlts alts) of
 416         (True , True ) -> True
 417         (False, False) -> False
 418         _              ->
 419           panic "DsUtils: You may not mix `[:...:]' with `PArr' patterns"
 420     --
 421     mk_parrCase fail =
 422       dsLookupGlobalId lengthPName                      `thenDs` \lengthP  ->
 423       unboxAlt                                          `thenDs` \alt      ->
 424       returnDs (Case (len lengthP) (mkWildId intTy) ty [alt])
 425       where
 426         elemTy      = case splitTyConApp (idType var) of
 427                         (_, [elemTy]) -> elemTy
 428                         _               -> panic panicMsg
 429         panicMsg    = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"
 430         len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]
 431         --
 432         unboxAlt =
 433           newSysLocalDs intPrimTy                       `thenDs` \l        ->
 434           dsLookupGlobalId indexPName                   `thenDs` \indexP   ->
 435           mappM (mkAlt indexP) sorted_alts              `thenDs` \alts     ->
 436           returnDs (DataAlt intDataCon, [l], (Case (Var l) wild ty (dft : alts)))
 437           where
 438             wild = mkWildId intPrimTy
 439             dft  = (DEFAULT, [], fail)
 440         --
 441         -- each alternative matches one array length (corresponding to one
 442         -- fake array constructor), so the match is on a literal; each
 443         -- alternative's body is extended by a local binding for each
 444         -- constructor argument, which are bound to array elements starting
 445         -- with the first
 446         --
 447         mkAlt indexP (con, args, MatchResult _ bodyFun) =
 448           bodyFun fail                                  `thenDs` \body     ->
 449           returnDs (LitAlt lit, [], mkDsLets binds body)
 450           where
 451             lit   = MachInt $ toInteger (dataConSourceArity con)
 452             binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args]
 453             --
 454             indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr i]
 455 \end{code}
 456
 457
 458 %************************************************************************
 459 %*                                                                      *
 460 \subsection{Desugarer's versions of some Core functions}
 461 %*                                                                      *
 462 %************************************************************************
 463
 464 \begin{code}
 465 mkErrorAppDs :: Id              -- The error function
 466              -> Type            -- Type to which it should be applied
 467              -> String          -- The error message string to pass
 468              -> DsM CoreExpr
 469
 470 mkErrorAppDs err_id ty msg
 471   = getSrcSpanDs                `thenDs` \ src_loc ->
 472     let
 473         full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
 474         core_msg = Lit (mkStringLit full_msg)
 475         -- mkStringLit returns a result of type String#
 476     in
 477     returnDs (mkApps (Var err_id) [Type ty, core_msg])
 478 \end{code}
 479
 480
 481 *************************************************************
 482 %*                                                                      *
 483 \subsection{Making literals}
 484 %*                                                                      *
 485 %************************************************************************
 486
 487 \begin{code}
 488 mkCharExpr     :: Char       -> CoreExpr      -- Returns        C# c :: Int
 489 mkIntExpr      :: Integer    -> CoreExpr      -- Returns        I# i :: Int
 490 mkIntegerExpr  :: Integer    -> DsM CoreExpr  -- Result :: Integer
 491 mkStringExpr   :: String     -> DsM CoreExpr  -- Result :: String
 492 mkStringExprFS :: FastString -> DsM CoreExpr  -- Result :: String
 493
 494 mkIntExpr  i = mkConApp intDataCon  [mkIntLit i]
 495 mkCharExpr c = mkConApp charDataCon [mkLit (MachChar c)]
 496
 497 mkIntegerExpr i
 498   | inIntRange i        -- Small enough, so start from an Int
 499   = dsLookupDataCon  smallIntegerDataConName    `thenDs` \ integer_dc ->
 500     returnDs (mkSmallIntegerLit integer_dc i)
 501
 502 -- Special case for integral literals with a large magnitude:
 503 -- They are transformed into an expression involving only smaller
 504 -- integral literals. This improves constant folding.
 505
 506   | otherwise           -- Big, so start from a string
 507   = dsLookupGlobalId plusIntegerName            `thenDs` \ plus_id ->
 508     dsLookupGlobalId timesIntegerName           `thenDs` \ times_id ->
 509     dsLookupDataCon  smallIntegerDataConName    `thenDs` \ integer_dc ->
 510     let
 511         lit i = mkSmallIntegerLit integer_dc i
 512         plus a b  = Var plus_id  `App` a `App` b
 513         times a b = Var times_id `App` a `App` b
 514
 515         -- Transform i into (x1 + (x2 + (x3 + (...) * b) * b) * b) with abs xi <= b
 516         horner :: Integer -> Integer -> CoreExpr
 517         horner b i | abs q <= 1 = if r == 0 || r == i
 518                                   then lit i
 519                                   else lit r `plus` lit (i-r)
 520                    | r == 0     =               horner b q `times` lit b
 521                    | otherwise  = lit r `plus` (horner b q `times` lit b)
 522                    where
 523                      (q,r) = i `quotRem` b
 524
 525     in
 526     returnDs (horner tARGET_MAX_INT i)
 527
 528 mkSmallIntegerLit small_integer_data_con i = mkConApp small_integer_data_con [mkIntLit i]
 529
 530 mkStringExpr str = mkStringExprFS (mkFastString str)
 531
 532 mkStringExprFS str
 533   | nullFS str
 534   = returnDs (mkNilExpr charTy)
 535
 536   | lengthFS str == 1
 537   = let
 538         the_char = mkCharExpr (headFS str)
 539     in
 540     returnDs (mkConsExpr charTy the_char (mkNilExpr charTy))
 541
 542   | all safeChar chars
 543   = dsLookupGlobalId unpackCStringName  `thenDs` \ unpack_id ->
 544     returnDs (App (Var unpack_id) (Lit (MachStr str)))
 545
 546   | otherwise
 547   = dsLookupGlobalId unpackCStringUtf8Name      `thenDs` \ unpack_id ->
 548     returnDs (App (Var unpack_id) (Lit (MachStr str)))
 549
 550   where
 551     chars = unpackFS str
 552     safeChar c = ord c >= 1 && ord c <= 0x7F
 553 \end{code}
 554
 555
 556 %************************************************************************
 557 %*                                                                      *
 558 \subsection[mkSelectorBind]{Make a selector bind}
 559 %*                                                                      *
 560 %************************************************************************
 561
 562 This is used in various places to do with lazy patterns.
 563 For each binder $b$ in the pattern, we create a binding:
 564 \begin{verbatim}
 565     b = case v of pat' -> b'
 566 \end{verbatim}
 567 where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
 568
 569 ToDo: making these bindings should really depend on whether there's
 570 much work to be done per binding.  If the pattern is complex, it
 571 should be de-mangled once, into a tuple (and then selected from).
 572 Otherwise the demangling can be in-line in the bindings (as here).
 573
 574 Boring!  Boring!  One error message per binder.  The above ToDo is
 575 even more helpful.  Something very similar happens for pattern-bound
 576 expressions.
 577
 578 \begin{code}
 579 mkSelectorBinds :: LPat Id      -- The pattern
 580                 -> CoreExpr     -- Expression to which the pattern is bound
 581                 -> DsM [(Id,CoreExpr)]
 582
 583 mkSelectorBinds (L _ (VarPat v)) val_expr
 584   = returnDs [(v, val_expr)]
 585
 586 mkSelectorBinds pat val_expr
 587   | isSingleton binders || is_simple_lpat pat
 588   =     -- Given   p = e, where p binds x,y
 589         -- we are going to make
 590         --      v = p   (where v is fresh)
 591         --      x = case v of p -> x
 592         --      y = case v of p -> x
 593
 594         -- Make up 'v'
 595         -- NB: give it the type of *pattern* p, not the type of the *rhs* e.
 596         -- This does not matter after desugaring, but there's a subtle
 597         -- issue with implicit parameters. Consider
 598         --      (x,y) = ?i
 599         -- Then, ?i is given type {?i :: Int}, a PredType, which is opaque
 600         -- to the desugarer.  (Why opaque?  Because newtypes have to be.  Why
 601         -- does it get that type?  So that when we abstract over it we get the
 602         -- right top-level type  (?i::Int) => ...)
 603         --
 604         -- So to get the type of 'v', use the pattern not the rhs.  Often more
 605         -- efficient too.
 606     newSysLocalDs (hsLPatType pat)      `thenDs` \ val_var ->
 607
 608         -- For the error message we make one error-app, to avoid duplication.
 609         -- But we need it at different types... so we use coerce for that
 610     mkErrorAppDs iRREFUT_PAT_ERROR_ID
 611                  unitTy (showSDoc (ppr pat))    `thenDs` \ err_expr ->
 612     newSysLocalDs unitTy                        `thenDs` \ err_var ->
 613     mappM (mk_bind val_var err_var) binders     `thenDs` \ binds ->
 614     returnDs ( (val_var, val_expr) :
 615                (err_var, err_expr) :
 616                binds )
 617
 618
 619   | otherwise
 620   = mkErrorAppDs iRREFUT_PAT_ERROR_ID
 621                  tuple_ty (showSDoc (ppr pat))                  `thenDs` \ error_expr ->
 622     matchSimply val_expr PatBindRhs pat local_tuple error_expr  `thenDs` \ tuple_expr ->
 623     newSysLocalDs tuple_ty                                      `thenDs` \ tuple_var ->
 624     let
 625         mk_tup_bind binder
 626           = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
 627     in
 628     returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
 629   where
 630     binders     = collectPatBinders pat
 631     local_tuple = mkTupleExpr binders
 632     tuple_ty    = exprType local_tuple
 633
 634     mk_bind scrut_var err_var bndr_var
 635     -- (mk_bind sv err_var) generates
 636     --          bv = case sv of { pat -> bv; other -> coerce (type-of-bv) err_var }
 637     -- Remember, pat binds bv
 638       = matchSimply (Var scrut_var) PatBindRhs pat
 639                     (Var bndr_var) error_expr                   `thenDs` \ rhs_expr ->
 640         returnDs (bndr_var, rhs_expr)
 641       where
 642         error_expr = mkCoerce co (Var err_var)
 643         co         = mkUnsafeCoercion (exprType (Var err_var)) (idType bndr_var)
 644
 645     is_simple_lpat p = is_simple_pat (unLoc p)
 646
 647     is_simple_pat (TuplePat ps Boxed _)        = all is_triv_lpat ps
 648     is_simple_pat (ConPatOut{ pat_args = ps }) = all is_triv_lpat (hsConArgs ps)
 649     is_simple_pat (VarPat _)                   = True
 650     is_simple_pat (ParPat p)                   = is_simple_lpat p
 651     is_simple_pat other                        = False
 652
 653     is_triv_lpat p = is_triv_pat (unLoc p)
 654
 655     is_triv_pat (VarPat v)  = True
 656     is_triv_pat (WildPat _) = True
 657     is_triv_pat (ParPat p)  = is_triv_lpat p
 658     is_triv_pat other       = False
 659 \end{code}
 660
 661
 662 %************************************************************************
 663 %*                                                                      *
 664                 Tuples
 665 %*                                                                      *
 666 %************************************************************************
 667
 668 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@.
 669
 670 * If it has only one element, it is the identity function.
 671
 672 * If there are more elements than a big tuple can have, it nests
 673   the tuples.
 674
 675 Nesting policy.  Better a 2-tuple of 10-tuples (3 objects) than
 676 a 10-tuple of 2-tuples (11 objects).  So we want the leaves to be big.
 677
 678 \begin{code}
 679 mkTupleExpr :: [Id] -> CoreExpr
 680 mkTupleExpr ids = mkBigCoreTup (map Var ids)
 681
 682 -- corresponding type
 683 mkTupleType :: [Id] -> Type
 684 mkTupleType ids = mkBigTuple mkCoreTupTy (map idType ids)
 685
 686 mkBigCoreTup :: [CoreExpr] -> CoreExpr
 687 mkBigCoreTup = mkBigTuple mkCoreTup
 688
 689 mkBigTuple :: ([a] -> a) -> [a] -> a
 690 mkBigTuple small_tuple as = mk_big_tuple (chunkify as)
 691   where
 692         -- Each sub-list is short enough to fit in a tuple
 693     mk_big_tuple [as] = small_tuple as
 694     mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s))
 695
 696 chunkify :: [a] -> [[a]]
 697 -- The sub-lists of the result all have length <= mAX_TUPLE_SIZE
 698 -- But there may be more than mAX_TUPLE_SIZE sub-lists
 699 chunkify xs
 700   | n_xs <= mAX_TUPLE_SIZE = {- pprTrace "Small" (ppr n_xs) -} [xs]
 701   | otherwise              = {- pprTrace "Big"   (ppr n_xs) -} (split xs)
 702   where
 703     n_xs     = length xs
 704     split [] = []
 705     split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)
 706 \end{code}
 707
 708
 709 @mkTupleSelector@ builds a selector which scrutises the given
 710 expression and extracts the one name from the list given.
 711 If you want the no-shadowing rule to apply, the caller
 712 is responsible for making sure that none of these names
 713 are in scope.
 714
 715 If there is just one id in the ``tuple'', then the selector is
 716 just the identity.
 717
 718 If it's big, it does nesting
 719         mkTupleSelector [a,b,c,d] b v e
 720           = case e of v {
 721                 (p,q) -> case p of p {
 722                            (a,b) -> b }}
 723 We use 'tpl' vars for the p,q, since shadowing does not matter.
 724
 725 In fact, it's more convenient to generate it innermost first, getting
 726
 727         case (case e of v
 728                 (p,q) -> p) of p
 729           (a,b) -> b
 730
 731 \begin{code}
 732 mkTupleSelector :: [Id]         -- The tuple args
 733                 -> Id           -- The selected one
 734                 -> Id           -- A variable of the same type as the scrutinee
 735                 -> CoreExpr     -- Scrutinee
 736                 -> CoreExpr
 737
 738 mkTupleSelector vars the_var scrut_var scrut
 739   = mk_tup_sel (chunkify vars) the_var
 740   where
 741     mk_tup_sel [vars] the_var = mkCoreSel vars the_var scrut_var scrut
 742     mk_tup_sel vars_s the_var = mkCoreSel group the_var tpl_v $
 743                                 mk_tup_sel (chunkify tpl_vs) tpl_v
 744         where
 745           tpl_tys = [mkCoreTupTy (map idType gp) | gp <- vars_s]
 746           tpl_vs  = mkTemplateLocals tpl_tys
 747           [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s,
 748                                          the_var `elem` gp ]
 749 \end{code}
 750
 751 A generalization of @mkTupleSelector@, allowing the body
 752 of the case to be an arbitrary expression.
 753
 754 If the tuple is big, it is nested:
 755
 756         mkTupleCase uniqs [a,b,c,d] body v e
 757           = case e of v { (p,q) ->
 758             case p of p { (a,b) ->
 759             case q of q { (c,d) ->
 760             body }}}
 761
 762 To avoid shadowing, we use uniqs to invent new variables p,q.
 763
 764 ToDo: eliminate cases where none of the variables are needed.
 765
 766 \begin{code}
 767 mkTupleCase
 768         :: UniqSupply   -- for inventing names of intermediate variables
 769         -> [Id]         -- the tuple args
 770         -> CoreExpr     -- body of the case
 771         -> Id           -- a variable of the same type as the scrutinee
 772         -> CoreExpr     -- scrutinee
 773         -> CoreExpr
 774
 775 mkTupleCase uniqs vars body scrut_var scrut
 776   = mk_tuple_case uniqs (chunkify vars) body
 777   where
 778     mk_tuple_case us [vars] body
 779       = mkSmallTupleCase vars body scrut_var scrut
 780     mk_tuple_case us vars_s body
 781       = let
 782             (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s
 783         in
 784         mk_tuple_case us' (chunkify vars') body'
 785     one_tuple_case chunk_vars (us, vs, body)
 786       = let
 787             (us1, us2) = splitUniqSupply us
 788             scrut_var = mkSysLocal FSLIT("ds") (uniqFromSupply us1)
 789                         (mkCoreTupTy (map idType chunk_vars))
 790             body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)
 791         in (us2, scrut_var:vs, body')
 792 \end{code}
 793
 794 The same, but with a tuple small enough not to need nesting.
 795
 796 \begin{code}
 797 mkSmallTupleCase
 798         :: [Id]         -- the tuple args
 799         -> CoreExpr     -- body of the case
 800         -> Id           -- a variable of the same type as the scrutinee
 801         -> CoreExpr     -- scrutinee
 802         -> CoreExpr
 803
 804 mkSmallTupleCase [var] body _scrut_var scrut
 805   = bindNonRec var scrut body
 806 mkSmallTupleCase vars body scrut_var scrut
 807 -- One branch no refinement?
 808   = Case scrut scrut_var (exprType body) [(DataAlt (tupleCon Boxed (length vars)), vars, body)]
 809 \end{code}
 810
 811 %************************************************************************
 812 %*                                                                      *
 813 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
 814 %*                                                                      *
 815 %************************************************************************
 816
 817 Call the constructor Ids when building explicit lists, so that they
 818 interact well with rules.
 819
 820 \begin{code}
 821 mkNilExpr :: Type -> CoreExpr
 822 mkNilExpr ty = mkConApp nilDataCon [Type ty]
 823
 824 mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
 825 mkConsExpr ty hd tl = mkConApp consDataCon [Type ty, hd, tl]
 826
 827 mkListExpr :: Type -> [CoreExpr] -> CoreExpr
 828 mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs
 829
 830
 831 -- The next three functions make tuple types, constructors and selectors,
 832 -- with the rule that a 1-tuple is represented by the thing itselg
 833 mkCoreTupTy :: [Type] -> Type
 834 mkCoreTupTy [ty] = ty
 835 mkCoreTupTy tys  = mkTupleTy Boxed (length tys) tys
 836
 837 mkCoreTup :: [CoreExpr] -> CoreExpr
 838 -- Builds exactly the specified tuple.
 839 -- No fancy business for big tuples
 840 mkCoreTup []  = Var unitDataConId
 841 mkCoreTup [c] = c
 842 mkCoreTup cs  = mkConApp (tupleCon Boxed (length cs))
 843                          (map (Type . exprType) cs ++ cs)
 844
 845 mkCoreSel :: [Id]       -- The tuple args
 846           -> Id         -- The selected one
 847           -> Id         -- A variable of the same type as the scrutinee
 848           -> CoreExpr   -- Scrutinee
 849           -> CoreExpr
 850 -- mkCoreSel [x,y,z] x v e
 851 -- ===>  case e of v { (x,y,z) -> x
 852 mkCoreSel [var] should_be_the_same_var scrut_var scrut
 853   = ASSERT(var == should_be_the_same_var)
 854     scrut
 855
 856 mkCoreSel vars the_var scrut_var scrut
 857   = ASSERT( notNull vars )
 858     Case scrut scrut_var (idType the_var)
 859          [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]
 860 \end{code}
 861
 862 %************************************************************************
 863 %*                                                                      *
 864 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
 865 %*                                                                      *
 866 %************************************************************************
 867
 868 Generally, we handle pattern matching failure like this: let-bind a
 869 fail-variable, and use that variable if the thing fails:
 870 \begin{verbatim}
 871         let fail.33 = error "Help"
 872         in
 873         case x of
 874                 p1 -> ...
 875                 p2 -> fail.33
 876                 p3 -> fail.33
 877                 p4 -> ...
 878 \end{verbatim}
 879 Then
 880 \begin{itemize}
 881 \item
 882 If the case can't fail, then there'll be no mention of @fail.33@, and the
 883 simplifier will later discard it.
 884
 885 \item
 886 If it can fail in only one way, then the simplifier will inline it.
 887
 888 \item
 889 Only if it is used more than once will the let-binding remain.
 890 \end{itemize}
 891
 892 There's a problem when the result of the case expression is of
 893 unboxed type.  Then the type of @fail.33@ is unboxed too, and
 894 there is every chance that someone will change the let into a case:
 895 \begin{verbatim}
 896         case error "Help" of
 897           fail.33 -> case ....
 898 \end{verbatim}
 899
 900 which is of course utterly wrong.  Rather than drop the condition that
 901 only boxed types can be let-bound, we just turn the fail into a function
 902 for the primitive case:
 903 \begin{verbatim}
 904         let fail.33 :: Void -> Int#
 905             fail.33 = \_ -> error "Help"
 906         in
 907         case x of
 908                 p1 -> ...
 909                 p2 -> fail.33 void
 910                 p3 -> fail.33 void
 911                 p4 -> ...
 912 \end{verbatim}
 913
 914 Now @fail.33@ is a function, so it can be let-bound.
 915
 916 \begin{code}
 917 mkFailurePair :: CoreExpr       -- Result type of the whole case expression
 918               -> DsM (CoreBind, -- Binds the newly-created fail variable
 919                                 -- to either the expression or \ _ -> expression
 920                       CoreExpr) -- Either the fail variable, or fail variable
 921                                 -- applied to unit tuple
 922 mkFailurePair expr
 923   | isUnLiftedType ty
 924   = newFailLocalDs (unitTy `mkFunTy` ty)        `thenDs` \ fail_fun_var ->
 925     newSysLocalDs unitTy                        `thenDs` \ fail_fun_arg ->
 926     returnDs (NonRec fail_fun_var (Lam fail_fun_arg expr),
 927               App (Var fail_fun_var) (Var unitDataConId))
 928
 929   | otherwise
 930   = newFailLocalDs ty           `thenDs` \ fail_var ->
 931     returnDs (NonRec fail_var expr, Var fail_var)
 932   where
 933     ty = exprType expr
 934 \end{code}
 935
 936 \begin{code}
 937 mkOptTickBox :: Maybe Int -> CoreExpr -> DsM CoreExpr
 938 mkOptTickBox Nothing e   = return e
 939 mkOptTickBox (Just ix) e = mkTickBox ix e
 940
 941 mkTickBox :: Int -> CoreExpr -> DsM CoreExpr
 942 mkTickBox ix e = do
 943        uq <- newUnique
 944        mod <- getModuleDs
 945        let tick = mkTickBoxOpId uq mod ix
 946        uq2 <- newUnique
 947        let occName = mkVarOcc "tick"
 948        let name = mkInternalName uq2 occName noSrcLoc   -- use mkSysLocal?
 949        let var  = Id.mkLocalId name realWorldStatePrimTy
 950        return $ Case (Var tick)
 951                      var
 952                      ty
 953                      [(DEFAULT,[],e)]
 954   where
 955      ty = exprType e
 956
 957 mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
 958 mkBinaryTickBox ixT ixF e = do
 959        mod <- getModuleDs
 960        uq <- newUnique
 961        mod <- getModuleDs
 962        let bndr1 = mkSysLocal FSLIT("t1") uq boolTy
 963        falseBox <- mkTickBox ixF $ Var falseDataConId
 964        trueBox  <- mkTickBox ixT $ Var trueDataConId
 965        return $ Case e bndr1 boolTy
 966                        [ (DataAlt falseDataCon, [], falseBox)
 967                        , (DataAlt trueDataCon,  [], trueBox)
 968                        ]
 969 \end{code}