compiler/deSugar/DsExpr.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 Desugaring exporessions.
   7
   8 \begin{code}
   9 {-# OPTIONS -fno-warn-incomplete-patterns #-}
  10 -- The above warning supression flag is a temporary kludge.
  11 -- While working on this module you are encouraged to remove it and fix
  12 -- any warnings in the module. See
  13 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  14 -- for details
  15
  16 module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where
  17
  18 #include "HsVersions.h"
  19
  20 import Match
  21 import MatchLit
  22 import DsBinds
  23 import DsGRHSs
  24 import DsListComp
  25 import DsUtils
  26 import DsArrows
  27 import DsMonad
  28 import Name
  29
  30 #ifdef GHCI
  31 import PrelNames
  32         -- Template Haskell stuff iff bootstrapped
  33 import DsMeta
  34 #endif
  35
  36 import HsSyn
  37 import TcHsSyn
  38
  39 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
  40 --     needs to see source types
  41 import TcType
  42 import Type
  43 import CoreSyn
  44 import CoreUtils
  45 import MkCore
  46
  47 import DynFlags
  48 import CostCentre
  49 import Id
  50 import PrelInfo
  51 import DataCon
  52 import TysWiredIn
  53 import BasicTypes
  54 import PrelNames
  55 import SrcLoc
  56 import Util
  57 import Bag
  58 import Outputable
  59 import FastString
  60 \end{code}
  61
  62
  63 %************************************************************************
  64 %*                                                                      *
  65                 dsLocalBinds, dsValBinds
  66 %*                                                                      *
  67 %************************************************************************
  68
  69 \begin{code}
  70 dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
  71 dsLocalBinds EmptyLocalBinds    body = return body
  72 dsLocalBinds (HsValBinds binds) body = dsValBinds binds body
  73 dsLocalBinds (HsIPBinds binds)  body = dsIPBinds  binds body
  74
  75 -------------------------
  76 dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
  77 dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
  78
  79 -------------------------
  80 dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
  81 dsIPBinds (IPBinds ip_binds dict_binds) body
  82   = do  { prs <- dsLHsBinds dict_binds
  83         ; let inner = Let (Rec prs) body
  84                 -- The dict bindings may not be in
  85                 -- dependency order; hence Rec
  86         ; foldrM ds_ip_bind inner ip_binds }
  87   where
  88     ds_ip_bind (L _ (IPBind n e)) body
  89       = do e' <- dsLExpr e
  90            return (Let (NonRec (ipNameName n) e') body)
  91
  92 -------------------------
  93 ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
  94 -- Special case for bindings which bind unlifted variables
  95 -- We need to do a case right away, rather than building
  96 -- a tuple and doing selections.
  97 -- Silently ignore INLINE and SPECIALISE pragmas...
  98 ds_val_bind (NonRecursive, hsbinds) body
  99   | [L _ (AbsBinds [] [] exports binds)] <- bagToList hsbinds,
 100     (L loc bind : null_binds) <- bagToList binds,
 101     isBangHsBind bind
 102     || isUnboxedTupleBind bind
 103     || or [isUnLiftedType (idType g) | (_, g, _, _) <- exports]
 104   = let
 105       body_w_exports                  = foldr bind_export body exports
 106       bind_export (tvs, g, l, _) body = ASSERT( null tvs )
 107                                         bindNonRec g (Var l) body
 108     in
 109     ASSERT (null null_binds)
 110         -- Non-recursive, non-overloaded bindings only come in ones
 111         -- ToDo: in some bizarre case it's conceivable that there
 112         --       could be dict binds in the 'binds'.  (See the notes
 113         --       below.  Then pattern-match would fail.  Urk.)
 114     putSrcSpanDs loc    $
 115     case bind of
 116       FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn,
 117                 fun_tick = tick, fun_infix = inf }
 118         -> do (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches
 119               MASSERT( null args ) -- Functions aren't lifted
 120               MASSERT( isIdHsWrapper co_fn )
 121               rhs' <- mkOptTickBox tick rhs
 122               return (bindNonRec fun rhs' body_w_exports)
 123
 124       PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }
 125         ->      -- let C x# y# = rhs in body
 126                 -- ==> case rhs of C x# y# -> body
 127            putSrcSpanDs loc                     $
 128            do { rhs <- dsGuarded grhss ty
 129               ; let upat = unLoc pat
 130                     eqn = EqnInfo { eqn_pats = [upat],
 131                                     eqn_rhs = cantFailMatchResult body_w_exports }
 132               ; var    <- selectMatchVar upat
 133               ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
 134               ; return (scrungleMatch var rhs result) }
 135
 136       _ -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body)
 137
 138
 139 -- Ordinary case for bindings; none should be unlifted
 140 ds_val_bind (_is_rec, binds) body
 141   = do  { prs <- dsLHsBinds binds
 142         ; ASSERT( not (any (isUnLiftedType . idType . fst) prs) )
 143           case prs of
 144             [] -> return body
 145             _  -> return (Let (Rec prs) body) }
 146         -- Use a Rec regardless of is_rec.
 147         -- Why? Because it allows the binds to be all
 148         -- mixed up, which is what happens in one rare case
 149         -- Namely, for an AbsBind with no tyvars and no dicts,
 150         --         but which does have dictionary bindings.
 151         -- See notes with TcSimplify.inferLoop [NO TYVARS]
 152         -- It turned out that wrapping a Rec here was the easiest solution
 153         --
 154         -- NB The previous case dealt with unlifted bindings, so we
 155         --    only have to deal with lifted ones now; so Rec is ok
 156
 157 isUnboxedTupleBind :: HsBind Id -> Bool
 158 isUnboxedTupleBind (PatBind { pat_rhs_ty = ty }) = isUnboxedTupleType ty
 159 isUnboxedTupleBind _                             = False
 160
 161 scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr
 162 -- Returns something like (let var = scrut in body)
 163 -- but if var is an unboxed-tuple type, it inlines it in a fragile way
 164 -- Special case to handle unboxed tuple patterns; they can't appear nested
 165 -- The idea is that
 166 --      case e of (# p1, p2 #) -> rhs
 167 -- should desugar to
 168 --      case e of (# x1, x2 #) -> ... match p1, p2 ...
 169 -- NOT
 170 --      let x = e in case x of ....
 171 --
 172 -- But there may be a big
 173 --      let fail = ... in case e of ...
 174 -- wrapping the whole case, which complicates matters slightly
 175 -- It all seems a bit fragile.  Test is dsrun013.
 176
 177 scrungleMatch var scrut body
 178   | isUnboxedTupleType (idType var) = scrungle body
 179   | otherwise                       = bindNonRec var scrut body
 180   where
 181     scrungle (Case (Var x) bndr ty alts)
 182                     | x == var = Case scrut bndr ty alts
 183     scrungle (Let binds body)  = Let binds (scrungle body)
 184     scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other))
 185
 186 \end{code}
 187
 188 %************************************************************************
 189 %*                                                                      *
 190 \subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
 191 %*                                                                      *
 192 %************************************************************************
 193
 194 \begin{code}
 195 dsLExpr :: LHsExpr Id -> DsM CoreExpr
 196
 197 dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
 198
 199 dsExpr :: HsExpr Id -> DsM CoreExpr
 200 dsExpr (HsPar e)              = dsLExpr e
 201 dsExpr (ExprWithTySigOut e _) = dsLExpr e
 202 dsExpr (HsVar var)            = return (Var var)
 203 dsExpr (HsIPVar ip)           = return (Var (ipNameName ip))
 204 dsExpr (HsLit lit)            = dsLit lit
 205 dsExpr (HsOverLit lit)        = dsOverLit lit
 206 dsExpr (HsWrap co_fn e)       = dsCoercion co_fn (dsExpr e)
 207
 208 dsExpr (NegApp expr neg_expr)
 209   = App <$> dsExpr neg_expr <*> dsLExpr expr
 210
 211 dsExpr (HsLam a_Match)
 212   = uncurry mkLams <$> matchWrapper LambdaExpr a_Match
 213
 214 dsExpr (HsApp fun arg)
 215   = mkCoreApp <$> dsLExpr fun <*>  dsLExpr arg
 216 \end{code}
 217
 218 Operator sections.  At first it looks as if we can convert
 219 \begin{verbatim}
 220         (expr op)
 221 \end{verbatim}
 222 to
 223 \begin{verbatim}
 224         \x -> op expr x
 225 \end{verbatim}
 226
 227 But no!  expr might be a redex, and we can lose laziness badly this
 228 way.  Consider
 229 \begin{verbatim}
 230         map (expr op) xs
 231 \end{verbatim}
 232 for example.  So we convert instead to
 233 \begin{verbatim}
 234         let y = expr in \x -> op y x
 235 \end{verbatim}
 236 If \tr{expr} is actually just a variable, say, then the simplifier
 237 will sort it out.
 238
 239 \begin{code}
 240 dsExpr (OpApp e1 op _ e2)
 241   = -- for the type of y, we need the type of op's 2nd argument
 242     mkCoreApps <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
 243
 244 dsExpr (SectionL expr op)       -- Desugar (e !) to ((!) e)
 245   = mkCoreApp <$> dsLExpr op <*> dsLExpr expr
 246
 247 -- dsLExpr (SectionR op expr)   -- \ x -> op x expr
 248 dsExpr (SectionR op expr) = do
 249     core_op <- dsLExpr op
 250     -- for the type of x, we need the type of op's 2nd argument
 251     let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
 252         -- See comment with SectionL
 253     y_core <- dsLExpr expr
 254     x_id <- newSysLocalDs x_ty
 255     y_id <- newSysLocalDs y_ty
 256     return (bindNonRec y_id y_core $
 257             Lam x_id (mkCoreApps core_op [Var x_id, Var y_id]))
 258
 259 dsExpr (HsSCC cc expr) = do
 260     mod_name <- getModuleDs
 261     Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr
 262
 263
 264 -- hdaume: core annotation
 265
 266 dsExpr (HsCoreAnn fs expr)
 267   = Note (CoreNote $ unpackFS fs) <$> dsLExpr expr
 268
 269 dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty))
 270   | isEmptyMatchGroup matches   -- A Core 'case' is always non-empty
 271   =                             -- So desugar empty HsCase to error call
 272     mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) "case"
 273
 274   | otherwise
 275   = do { core_discrim <- dsLExpr discrim
 276        ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
 277        ; return (scrungleMatch discrim_var core_discrim matching_code) }
 278
 279 -- Pepe: The binds are in scope in the body but NOT in the binding group
 280 --       This is to avoid silliness in breakpoints
 281 dsExpr (HsLet binds body) = do
 282     body' <- dsLExpr body
 283     dsLocalBinds binds body'
 284
 285 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
 286 -- because the interpretation of `stmts' depends on what sort of thing it is.
 287 --
 288 dsExpr (HsDo ListComp stmts body result_ty)
 289   =     -- Special case for list comprehensions
 290     dsListComp stmts body elt_ty
 291   where
 292     [elt_ty] = tcTyConAppArgs result_ty
 293
 294 dsExpr (HsDo DoExpr stmts body result_ty)
 295   = dsDo stmts body result_ty
 296
 297 dsExpr (HsDo (MDoExpr tbl) stmts body result_ty)
 298   = dsMDo tbl stmts body result_ty
 299
 300 dsExpr (HsDo PArrComp stmts body result_ty)
 301   =     -- Special case for array comprehensions
 302     dsPArrComp (map unLoc stmts) body elt_ty
 303   where
 304     [elt_ty] = tcTyConAppArgs result_ty
 305
 306 dsExpr (HsIf guard_expr then_expr else_expr)
 307   = mkIfThenElse <$> dsLExpr guard_expr <*> dsLExpr then_expr <*> dsLExpr else_expr
 308 \end{code}
 309
 310
 311 \noindent
 312 \underline{\bf Various data construction things}
 313 %              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 314 \begin{code}
 315 dsExpr (ExplicitList elt_ty xs)
 316   = dsExplicitList elt_ty xs
 317
 318 -- we create a list from the array elements and convert them into a list using
 319 -- `PrelPArr.toP'
 320 --
 321 --  * the main disadvantage to this scheme is that `toP' traverses the list
 322 --   twice: once to determine the length and a second time to put to elements
 323 --   into the array; this inefficiency could be avoided by exposing some of
 324 --   the innards of `PrelPArr' to the compiler (ie, have a `PrelPArrBase') so
 325 --   that we can exploit the fact that we already know the length of the array
 326 --   here at compile time
 327 --
 328 dsExpr (ExplicitPArr ty xs) = do
 329     toP <- dsLookupGlobalId toPName
 330     coreList <- dsExpr (ExplicitList ty xs)
 331     return (mkApps (Var toP) [Type ty, coreList])
 332
 333 dsExpr (ExplicitTuple expr_list boxity) = do
 334     core_exprs <- mapM dsLExpr expr_list
 335     return (mkConApp (tupleCon boxity (length expr_list))
 336                   (map (Type .  exprType) core_exprs ++ core_exprs))
 337
 338 dsExpr (ArithSeq expr (From from))
 339   = App <$> dsExpr expr <*> dsLExpr from
 340
 341 dsExpr (ArithSeq expr (FromTo from to))
 342   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
 343
 344 dsExpr (ArithSeq expr (FromThen from thn))
 345   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]
 346
 347 dsExpr (ArithSeq expr (FromThenTo from thn to))
 348   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
 349
 350 dsExpr (PArrSeq expr (FromTo from to))
 351   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
 352
 353 dsExpr (PArrSeq expr (FromThenTo from thn to))
 354   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
 355
 356 dsExpr (PArrSeq _ _)
 357   = panic "DsExpr.dsExpr: Infinite parallel array!"
 358     -- the parser shouldn't have generated it and the renamer and typechecker
 359     -- shouldn't have let it through
 360 \end{code}
 361
 362 \noindent
 363 \underline{\bf Record construction and update}
 364 %              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 365 For record construction we do this (assuming T has three arguments)
 366 \begin{verbatim}
 367         T { op2 = e }
 368 ==>
 369         let err = /\a -> recConErr a
 370         T (recConErr t1 "M.lhs/230/op1")
 371           e
 372           (recConErr t1 "M.lhs/230/op3")
 373 \end{verbatim}
 374 @recConErr@ then converts its arugment string into a proper message
 375 before printing it as
 376 \begin{verbatim}
 377         M.lhs, line 230: missing field op1 was evaluated
 378 \end{verbatim}
 379
 380 We also handle @C{}@ as valid construction syntax for an unlabelled
 381 constructor @C@, setting all of @C@'s fields to bottom.
 382
 383 \begin{code}
 384 dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do
 385     con_expr' <- dsExpr con_expr
 386     let
 387         (arg_tys, _) = tcSplitFunTys (exprType con_expr')
 388         -- A newtype in the corner should be opaque;
 389         -- hence TcType.tcSplitFunTys
 390
 391         mk_arg (arg_ty, lbl)    -- Selector id has the field label as its name
 392           = case findField (rec_flds rbinds) lbl of
 393               (rhs:rhss) -> ASSERT( null rhss )
 394                             dsLExpr rhs
 395               []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showSDoc (ppr lbl))
 396         unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty ""
 397
 398         labels = dataConFieldLabels (idDataCon data_con_id)
 399         -- The data_con_id is guaranteed to be the wrapper id of the constructor
 400
 401     con_args <- if null labels
 402                 then mapM unlabelled_bottom arg_tys
 403                 else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
 404
 405     return (mkApps con_expr' con_args)
 406 \end{code}
 407
 408 Record update is a little harder. Suppose we have the decl:
 409 \begin{verbatim}
 410         data T = T1 {op1, op2, op3 :: Int}
 411                | T2 {op4, op2 :: Int}
 412                | T3
 413 \end{verbatim}
 414 Then we translate as follows:
 415 \begin{verbatim}
 416         r { op2 = e }
 417 ===>
 418         let op2 = e in
 419         case r of
 420           T1 op1 _ op3 -> T1 op1 op2 op3
 421           T2 op4 _     -> T2 op4 op2
 422           other        -> recUpdError "M.lhs/230"
 423 \end{verbatim}
 424 It's important that we use the constructor Ids for @T1@, @T2@ etc on the
 425 RHSs, and do not generate a Core constructor application directly, because the constructor
 426 might do some argument-evaluation first; and may have to throw away some
 427 dictionaries.
 428
 429 \begin{code}
 430 dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
 431                        cons_to_upd in_inst_tys out_inst_tys)
 432   | null fields
 433   = dsLExpr record_expr
 434   | otherwise
 435   =     -- Record stuff doesn't work for existentials
 436         -- The type checker checks for this, but we need
 437         -- worry only about the constructors that are to be updated
 438     ASSERT2( notNull cons_to_upd && all isVanillaDataCon cons_to_upd, ppr expr )
 439
 440     do  { record_expr' <- dsLExpr record_expr
 441         ; let   -- Awkwardly, for families, the match goes
 442                 -- from instance type to family type
 443                 tycon     = dataConTyCon (head cons_to_upd)
 444                 in_ty     = mkTyConApp tycon in_inst_tys
 445                 in_out_ty = mkFunTy in_ty
 446                                     (mkFamilyTyConApp tycon out_inst_tys)
 447
 448                 mk_val_arg field old_arg_id
 449                   = case findField fields field  of
 450                       (rhs:rest) -> ASSERT(null rest) rhs
 451                       []         -> nlHsVar old_arg_id
 452
 453                 mk_alt con
 454                   = ASSERT( isVanillaDataCon con )
 455                     do  { arg_ids <- newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys)
 456                         -- This call to dataConInstOrigArgTys won't work for existentials
 457                         -- but existentials don't have record types anyway
 458                         ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
 459                                                 (dataConFieldLabels con) arg_ids
 460                               rhs = foldl (\a b -> nlHsApp a b)
 461                                           (nlHsTyApp (dataConWrapId con) out_inst_tys)
 462                                           val_args
 463                               pat = mkPrefixConPat con (map nlVarPat arg_ids) in_ty
 464
 465                         ; return (mkSimpleMatch [pat] rhs) }
 466
 467         -- It's important to generate the match with matchWrapper,
 468         -- and the right hand sides with applications of the wrapper Id
 469         -- so that everything works when we are doing fancy unboxing on the
 470         -- constructor aguments.
 471         ; alts <- mapM mk_alt cons_to_upd
 472         ; ([discrim_var], matching_code) <- matchWrapper RecUpd (MatchGroup alts in_out_ty)
 473
 474         ; return (bindNonRec discrim_var record_expr' matching_code) }
 475 \end{code}
 476
 477 Here is where we desugar the Template Haskell brackets and escapes
 478
 479 \begin{code}
 480 -- Template Haskell stuff
 481
 482 #ifdef GHCI     /* Only if bootstrapping */
 483 dsExpr (HsBracketOut x ps) = dsBracket x ps
 484 dsExpr (HsSpliceE s)       = pprPanic "dsExpr:splice" (ppr s)
 485 #endif
 486
 487 -- Arrow notation extension
 488 dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
 489 \end{code}
 490
 491 Hpc Support
 492
 493 \begin{code}
 494 dsExpr (HsTick ix vars e) = do
 495   e' <- dsLExpr e
 496   mkTickBox ix vars e'
 497
 498 -- There is a problem here. The then and else branches
 499 -- have no free variables, so they are open to lifting.
 500 -- We need someway of stopping this.
 501 -- This will make no difference to binary coverage
 502 -- (did you go here: YES or NO), but will effect accurate
 503 -- tick counting.
 504
 505 dsExpr (HsBinTick ixT ixF e) = do
 506   e2 <- dsLExpr e
 507   do { ASSERT(exprType e2 `coreEqType` boolTy)
 508        mkBinaryTickBox ixT ixF e2
 509      }
 510 \end{code}
 511
 512 \begin{code}
 513
 514 -- HsSyn constructs that just shouldn't be here:
 515 dsExpr (ExprWithTySig _ _)  = panic "dsExpr:ExprWithTySig"
 516
 517
 518 findField :: [HsRecField Id arg] -> Name -> [arg]
 519 findField rbinds lbl
 520   = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds
 521          , lbl == idName (unLoc id) ]
 522 \end{code}
 523
 524 %--------------------------------------------------------------------
 525
 526 Note [Desugaring explicit lists]
 527 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 528 Explicit lists are desugared in a cleverer way to prevent some
 529 fruitless allocations.  Essentially, whenever we see a list literal
 530 [x_1, ..., x_n] we:
 531
 532 1. Find the tail of the list that can be allocated statically (say
 533    [x_k, ..., x_n]) by later stages and ensure we desugar that
 534    normally: this makes sure that we don't cause a code size increase
 535    by having the cons in that expression fused (see later) and hence
 536    being unable to statically allocate any more
 537
 538 2. For the prefix of the list which cannot be allocated statically,
 539    say [x_1, ..., x_(k-1)], we turn it into an expression involving
 540    build so that if we find any foldrs over it it will fuse away
 541    entirely!
 542
 543    So in this example we will desugar to:
 544    build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n]
 545
 546    If fusion fails to occur then build will get inlined and (since we
 547    defined a RULE for foldr (:) []) we will get back exactly the
 548    normal desugaring for an explicit list.
 549
 550 This optimisation can be worth a lot: up to 25% of the total
 551 allocation in some nofib programs. Specifically
 552
 553         Program           Size    Allocs   Runtime  CompTime
 554         rewrite          +0.0%    -26.3%      0.02     -1.8%
 555            ansi          -0.3%    -13.8%      0.00     +0.0%
 556            lift          +0.0%     -8.7%      0.00     -2.3%
 557
 558 Of course, if rules aren't turned on then there is pretty much no
 559 point doing this fancy stuff, and it may even be harmful.
 560 \begin{code}
 561
 562 dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
 563 -- See Note [Desugaring explicit lists]
 564 dsExplicitList elt_ty xs = do
 565     dflags <- getDOptsDs
 566     xs' <- mapM dsLExpr xs
 567     if not (dopt Opt_EnableRewriteRules dflags)
 568         then return $ mkListExpr elt_ty xs'
 569         else mkBuildExpr elt_ty (mkSplitExplicitList (thisPackage dflags) xs')
 570   where
 571     mkSplitExplicitList this_package xs' (c, _) (n, n_ty) = do
 572         let (dynamic_prefix, static_suffix) = spanTail (rhsIsStatic this_package) xs'
 573             static_suffix' = mkListExpr elt_ty static_suffix
 574
 575         folded_static_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) static_suffix'
 576         let build_body = foldr (App . App (Var c)) folded_static_suffix dynamic_prefix
 577         return build_body
 578
 579 spanTail :: (a -> Bool) -> [a] -> ([a], [a])
 580 spanTail f xs = (reverse rejected, reverse satisfying)
 581     where (satisfying, rejected) = span f $ reverse xs
 582 \end{code}
 583
 584 Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
 585 handled in DsListComp).  Basically does the translation given in the
 586 Haskell 98 report:
 587
 588 \begin{code}
 589 dsDo    :: [LStmt Id]
 590         -> LHsExpr Id
 591         -> Type                 -- Type of the whole expression
 592         -> DsM CoreExpr
 593
 594 dsDo stmts body _result_ty
 595   = go (map unLoc stmts)
 596   where
 597     go [] = dsLExpr body
 598
 599     go (ExprStmt rhs then_expr _ : stmts)
 600       = do { rhs2 <- dsLExpr rhs
 601            ; then_expr2 <- dsExpr then_expr
 602            ; rest <- go stmts
 603            ; return (mkApps then_expr2 [rhs2, rest]) }
 604
 605     go (LetStmt binds : stmts)
 606       = do { rest <- go stmts
 607            ; dsLocalBinds binds rest }
 608
 609     go (BindStmt pat rhs bind_op fail_op : stmts)
 610       =
 611        do  { body     <- go stmts
 612            ; rhs'     <- dsLExpr rhs
 613            ; bind_op' <- dsExpr bind_op
 614            ; var   <- selectSimpleMatchVarL pat
 615            ; let bind_ty = exprType bind_op'    -- rhs -> (pat -> res1) -> res2
 616                  res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
 617            ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
 618                                      res1_ty (cantFailMatchResult body)
 619            ; match_code <- handle_failure pat match fail_op
 620            ; return (mkApps bind_op' [rhs', Lam var match_code]) }
 621
 622     -- In a do expression, pattern-match failure just calls
 623     -- the monadic 'fail' rather than throwing an exception
 624     handle_failure pat match fail_op
 625       | matchCanFail match
 626       = do { fail_op' <- dsExpr fail_op
 627            ; fail_msg <- mkStringExpr (mk_fail_msg pat)
 628            ; extractMatchResult match (App fail_op' fail_msg) }
 629       | otherwise
 630       = extractMatchResult match (error "It can't fail")
 631
 632 mk_fail_msg :: Located e -> String
 633 mk_fail_msg pat = "Pattern match failure in do expression at " ++
 634                   showSDoc (ppr (getLoc pat))
 635 \end{code}
 636
 637 Translation for RecStmt's:
 638 -----------------------------
 639 We turn (RecStmt [v1,..vn] stmts) into:
 640
 641   (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
 642                                       return (v1,..vn))
 643
 644 \begin{code}
 645 dsMDo   :: PostTcTable
 646         -> [LStmt Id]
 647         -> LHsExpr Id
 648         -> Type                 -- Type of the whole expression
 649         -> DsM CoreExpr
 650
 651 dsMDo tbl stmts body result_ty
 652   = go (map unLoc stmts)
 653   where
 654     (m_ty, b_ty) = tcSplitAppTy result_ty       -- result_ty must be of the form (m b)
 655     mfix_id   = lookupEvidence tbl mfixName
 656     return_id = lookupEvidence tbl returnMName
 657     bind_id   = lookupEvidence tbl bindMName
 658     then_id   = lookupEvidence tbl thenMName
 659     fail_id   = lookupEvidence tbl failMName
 660     ctxt      = MDoExpr tbl
 661
 662     go [] = dsLExpr body
 663
 664     go (LetStmt binds : stmts)
 665       = do { rest <- go stmts
 666            ; dsLocalBinds binds rest }
 667
 668     go (ExprStmt rhs _ rhs_ty : stmts)
 669       = do { rhs2 <- dsLExpr rhs
 670            ; rest <- go stmts
 671            ; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
 672
 673     go (BindStmt pat rhs _ _ : stmts)
 674       = do { body  <- go stmts
 675            ; var   <- selectSimpleMatchVarL pat
 676            ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
 677                                   result_ty (cantFailMatchResult body)
 678            ; fail_msg   <- mkStringExpr (mk_fail_msg pat)
 679            ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
 680            ; match_code <- extractMatchResult match fail_expr
 681
 682            ; rhs'       <- dsLExpr rhs
 683            ; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
 684                                              rhs', Lam var match_code]) }
 685
 686     go (RecStmt rec_stmts later_ids rec_ids rec_rets binds : stmts)
 687       = ASSERT( length rec_ids > 0 )
 688         ASSERT( length rec_ids == length rec_rets )
 689         go (new_bind_stmt : let_stmt : stmts)
 690       where
 691         new_bind_stmt = mkBindStmt (mk_tup_pat later_pats) mfix_app
 692         let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
 693
 694
 695                 -- Remove the later_ids that appear (without fancy coercions)
 696                 -- in rec_rets, because there's no need to knot-tie them separately
 697                 -- See Note [RecStmt] in HsExpr
 698         later_ids'   = filter (`notElem` mono_rec_ids) later_ids
 699         mono_rec_ids = [ id | HsVar id <- rec_rets ]
 700
 701         mfix_app = nlHsApp (nlHsTyApp mfix_id [tup_ty]) mfix_arg
 702         mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
 703                                              (mkFunTy tup_ty body_ty))
 704
 705         -- The rec_tup_pat must bind the rec_ids only; remember that the
 706         --      trimmed_laters may share the same Names
 707         -- Meanwhile, the later_pats must bind the later_vars
 708         rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids
 709         later_pats   = map nlVarPat    later_ids' ++ map mk_later_pat rec_ids
 710         rets         = map nlHsVar     later_ids' ++ map noLoc rec_rets
 711
 712         mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
 713         body     = noLoc $ HsDo ctxt rec_stmts return_app body_ty
 714         body_ty = mkAppTy m_ty tup_ty
 715         tup_ty  = mkCoreTupTy (map idType (later_ids' ++ rec_ids))
 716                   -- mkCoreTupTy deals with singleton case
 717
 718         return_app  = nlHsApp (nlHsTyApp return_id [tup_ty])
 719                               (mk_ret_tup rets)
 720
 721         mk_wild_pat :: Id -> LPat Id
 722         mk_wild_pat v = noLoc $ WildPat $ idType v
 723
 724         mk_later_pat :: Id -> LPat Id
 725         mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
 726                        | otherwise           = nlVarPat v
 727
 728         mk_tup_pat :: [LPat Id] -> LPat Id
 729         mk_tup_pat [p] = p
 730         mk_tup_pat ps  = noLoc $ mkVanillaTuplePat ps Boxed
 731
 732         mk_ret_tup :: [LHsExpr Id] -> LHsExpr Id
 733         mk_ret_tup [r] = r
 734         mk_ret_tup rs  = noLoc $ ExplicitTuple rs Boxed
 735 \end{code}