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