DsExpr.lhs 30.3 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
%
Simon Marlow's avatar
Simon Marlow committed
5 6

Desugaring exporessions.
7 8

\begin{code}
9
{-# OPTIONS -fno-warn-incomplete-patterns #-}
10 11 12
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
13
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
14 15
-- for details

16
module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where
17

18
#include "HsVersions.h"
mnislaih's avatar
mnislaih committed
19

Simon Marlow's avatar
Simon Marlow committed
20 21 22 23 24 25 26
import Match
import MatchLit
import DsBinds
import DsGRHSs
import DsListComp
import DsUtils
import DsArrows
27
import DsMonad
28
import Name
29
import NameEnv
30 31 32

#ifdef GHCI
	-- Template Haskell stuff iff bootstrapped
Simon Marlow's avatar
Simon Marlow committed
33
import DsMeta
34 35
#endif

36
import HsSyn
37 38

-- NB: The desugarer, which straddles the source and Core worlds, sometimes
Simon Marlow's avatar
Simon Marlow committed
39 40 41
--     needs to see source types
import TcType
import Type
42
import Coercion
43
import CoreSyn
Simon Marlow's avatar
Simon Marlow committed
44
import CoreUtils
45
import CoreFVs
46
import MkCore
Simon Marlow's avatar
Simon Marlow committed
47

48
import DynFlags
49
import StaticFlags
Simon Marlow's avatar
Simon Marlow committed
50 51
import CostCentre
import Id
52
import Var
53
import VarSet
Simon Marlow's avatar
Simon Marlow committed
54 55 56 57
import DataCon
import TysWiredIn
import BasicTypes
import PrelNames
58
import Maybes
Simon Marlow's avatar
Simon Marlow committed
59 60 61
import SrcLoc
import Util
import Bag
62
import Outputable
63
import FastString
64 65

import Control.Monad
66 67
\end{code}

68 69 70

%************************************************************************
%*									*
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
71
		dsLocalBinds, dsValBinds
72 73 74 75
%*									*
%************************************************************************

\begin{code}
76 77 78 79 80 81 82
dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
dsLocalBinds EmptyLocalBinds	body = return body
dsLocalBinds (HsValBinds binds) body = dsValBinds binds body
dsLocalBinds (HsIPBinds binds)  body = dsIPBinds  binds body

-------------------------
dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
83
dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
84 85

-------------------------
86
dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
87 88 89
dsIPBinds (IPBinds ip_binds ev_binds) body
  = do	{ ds_ev_binds <- dsTcEvBinds ev_binds
	; let inner = wrapDsEvBinds ds_ev_binds body
90 91
		-- The dict bindings may not be in 
		-- dependency order; hence Rec
92
	; foldrM ds_ip_bind inner ip_binds }
93
  where
94
    ds_ip_bind (L _ (IPBind n e)) body
95 96
      = do e' <- dsLExpr e
           return (Let (NonRec (ipNameName n) e') body)
97

98 99
-------------------------
ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
100
-- Special case for bindings which bind unlifted variables
101 102
-- We need to do a case right away, rather than building
-- a tuple and doing selections.
103
-- Silently ignore INLINE and SPECIALISE pragmas...
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
104
ds_val_bind (NonRecursive, hsbinds) body
105
  | [L loc bind] <- bagToList hsbinds,
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
106 107 108 109
	-- Non-recursive, non-overloaded bindings only come in ones
	-- ToDo: in some bizarre case it's conceivable that there
	--       could be dict binds in the 'binds'.  (See the notes
	--	 below.  Then pattern-match would fail.  Urk.)
110 111
    strictMatchOnly bind
  = putSrcSpanDs loc (dsStrictBind bind body)
112

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
113
-- Ordinary case for bindings; none should be unlifted
114
ds_val_bind (_is_rec, binds) body
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
115
  = do	{ prs <- dsLHsBinds binds
116
	; ASSERT2( not (any (isUnLiftedType . idType . fst) prs), ppr _is_rec $$ ppr binds )
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
117
	  case prs of
118 119
            [] -> return body
            _  -> return (Let (Rec prs) body) }
120
	-- Use a Rec regardless of is_rec. 
121
	-- Why? Because it allows the binds to be all
122 123 124 125 126
	-- mixed up, which is what happens in one rare case
	-- Namely, for an AbsBind with no tyvars and no dicts,
	-- 	   but which does have dictionary bindings.
	-- See notes with TcSimplify.inferLoop [NO TYVARS]
	-- It turned out that wrapping a Rec here was the easiest solution
127 128 129
	--
	-- NB The previous case dealt with unlifted bindings, so we
	--    only have to deal with lifted ones now; so Rec is ok
130

131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177
------------------
dsStrictBind :: HsBind Id -> CoreExpr -> DsM CoreExpr
dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
               , abs_exports = exports
               , abs_ev_binds = ev_binds
               , abs_binds = binds }) body
  = do { ds_ev_binds <- dsTcEvBinds ev_binds
       ; let body1 = foldr bind_export body exports
             bind_export (_, g, l, _) b = bindNonRec g (Var l) b
       ; body2 <- foldlBagM (\body bind -> dsStrictBind (unLoc bind) body) 
                            body1 binds 
       ; return (wrapDsEvBinds ds_ev_binds body2) }

dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn 
	              , fun_tick = tick, fun_infix = inf }) body
		-- Can't be a bang pattern (that looks like a PatBind)
		-- so must be simply unboxed
  = do { (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches
       ; MASSERT( null args ) -- Functions aren't lifted
       ; MASSERT( isIdHsWrapper co_fn )
       ; rhs' <- mkOptTickBox tick rhs
       ; return (bindNonRec fun rhs' body) }

dsStrictBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
  = 	-- let C x# y# = rhs in body
	-- ==> case rhs of C x# y# -> body
    do { rhs <- dsGuarded grhss ty
       ; let upat = unLoc pat
             eqn = EqnInfo { eqn_pats = [upat], 
                             eqn_rhs = cantFailMatchResult body }
       ; var    <- selectMatchVar upat
       ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
       ; return (scrungleMatch var rhs result) }

dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)

----------------------
strictMatchOnly :: HsBind Id -> Bool
strictMatchOnly (AbsBinds { abs_binds = binds })
  = anyBag (strictMatchOnly . unLoc) binds
strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = ty })
  =  isUnboxedTupleType ty 
  || isBangLPat lpat   
  || any (isUnLiftedType . idType) (collectPatBinders lpat)
strictMatchOnly (FunBind { fun_id = L _ id })
  = isUnLiftedType (idType id)
strictMatchOnly _ = False -- I hope!  Checked immediately by caller in fact
178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202

scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr
-- Returns something like (let var = scrut in body)
-- but if var is an unboxed-tuple type, it inlines it in a fragile way
-- Special case to handle unboxed tuple patterns; they can't appear nested
-- The idea is that 
--	case e of (# p1, p2 #) -> rhs
-- should desugar to
--	case e of (# x1, x2 #) -> ... match p1, p2 ...
-- NOT
--	let x = e in case x of ....
--
-- But there may be a big 
--	let fail = ... in case e of ...
-- wrapping the whole case, which complicates matters slightly
-- It all seems a bit fragile.  Test is dsrun013.

scrungleMatch var scrut body
  | isUnboxedTupleType (idType var) = scrungle body
  | otherwise			    = bindNonRec var scrut body
  where
    scrungle (Case (Var x) bndr ty alts)
		    | x == var = Case scrut bndr ty alts
    scrungle (Let binds body)  = Let binds (scrungle body)
    scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other))
mnislaih's avatar
mnislaih committed
203

204
\end{code}
205 206 207

%************************************************************************
%*									*
208
\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
209 210 211 212
%*									*
%************************************************************************

\begin{code}
213
dsLExpr :: LHsExpr Id -> DsM CoreExpr
mnislaih's avatar
mnislaih committed
214

215 216 217
dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e

dsExpr :: HsExpr Id -> DsM CoreExpr
218 219
dsExpr (HsPar e) 	      = dsLExpr e
dsExpr (ExprWithTySigOut e _) = dsLExpr e
220 221
dsExpr (HsVar var)     	      = return (Var var)
dsExpr (HsIPVar ip)    	      = return (Var (ipNameName ip))
222 223
dsExpr (HsLit lit)     	      = dsLit lit
dsExpr (HsOverLit lit) 	      = dsOverLit lit
224 225 226 227 228 229 230

dsExpr (HsWrap co_fn e)
  = do { co_fn' <- dsHsWrapper co_fn
       ; e' <- dsExpr e
       ; warn_id <- doptDs Opt_WarnIdentities
       ; when warn_id $ warnAboutIdentities e' co_fn'
       ; return (co_fn' e') }
231 232

dsExpr (NegApp expr neg_expr) 
233
  = App <$> dsExpr neg_expr <*> dsLExpr expr
234

235
dsExpr (HsLam a_Match)
236
  = uncurry mkLams <$> matchWrapper LambdaExpr a_Match
237

238
dsExpr (HsApp fun arg)
239
  = mkCoreAppDs <$> dsLExpr fun <*>  dsLExpr arg
240 241 242 243 244 245
\end{code}

Operator sections.  At first it looks as if we can convert
\begin{verbatim}
	(expr op)
\end{verbatim}
246
to
247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263
\begin{verbatim}
	\x -> op expr x
\end{verbatim}

But no!  expr might be a redex, and we can lose laziness badly this
way.  Consider
\begin{verbatim}
	map (expr op) xs
\end{verbatim}
for example.  So we convert instead to
\begin{verbatim}
	let y = expr in \x -> op y x
\end{verbatim}
If \tr{expr} is actually just a variable, say, then the simplifier
will sort it out.

\begin{code}
sof's avatar
sof committed
264
dsExpr (OpApp e1 op _ e2)
265
  = -- for the type of y, we need the type of op's 2nd argument
266
    mkCoreAppsDs <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
sof's avatar
sof committed
267
    
268
dsExpr (SectionL expr op)	-- Desugar (e !) to ((!) e)
269
  = mkCoreAppDs <$> dsLExpr op <*> dsLExpr expr
270

271
-- dsLExpr (SectionR op expr)	-- \ x -> op x expr
272 273
dsExpr (SectionR op expr) = do
    core_op <- dsLExpr op
sof's avatar
sof committed
274
    -- for the type of x, we need the type of op's 2nd argument
275 276 277 278 279 280
    let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
        -- See comment with SectionL
    y_core <- dsLExpr expr
    x_id <- newSysLocalDs x_ty
    y_id <- newSysLocalDs y_ty
    return (bindNonRec y_id y_core $
281
            Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
282

283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301
dsExpr (ExplicitTuple tup_args boxity)
  = do { let go (lam_vars, args) (Missing ty)
                    -- For every missing expression, we need
		    -- another lambda in the desugaring.
               = do { lam_var <- newSysLocalDs ty
                    ; return (lam_var : lam_vars, Var lam_var : args) }
	     go (lam_vars, args) (Present expr)
     	            -- Expressions that are present don't generate
                    -- lambdas, just arguments.
               = do { core_expr <- dsLExpr expr
                    ; return (lam_vars, core_expr : args) }

       ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)
		-- The reverse is because foldM goes left-to-right

       ; return $ mkCoreLams lam_vars $ 
                  mkConApp (tupleCon boxity (length tup_args))
                           (map (Type . exprType) args ++ args) }

302 303 304
dsExpr (HsSCC cc expr) = do
    mod_name <- getModuleDs
    Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr
305

306
dsExpr (HsCoreAnn fs expr)
307
  = Note (CoreNote $ unpackFS fs) <$> dsLExpr expr
308

309 310 311
dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty)) 
  | isEmptyMatchGroup matches	-- A Core 'case' is always non-empty
  = 		      		-- So desugar empty HsCase to error call
312
    mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) (ptext (sLit "case"))
313 314 315 316 317

  | otherwise
  = do { core_discrim <- dsLExpr discrim
       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
       ; return (scrungleMatch discrim_var core_discrim matching_code) }
318

319 320
-- Pepe: The binds are in scope in the body but NOT in the binding group
--       This is to avoid silliness in breakpoints
321 322
dsExpr (HsLet binds body) = do
    body' <- dsLExpr body
323
    dsLocalBinds binds body'
324

chak's avatar
chak committed
325 326 327
-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
-- because the interpretation of `stmts' depends on what sort of thing it is.
--
328 329
dsExpr (HsDo ListComp  stmts res_ty) = dsListComp stmts res_ty
dsExpr (HsDo PArrComp  stmts _)      = dsPArrComp (map unLoc stmts)
330 331 332 333
dsExpr (HsDo DoExpr    stmts _)      = dsDo stmts 
dsExpr (HsDo GhciStmt  stmts _)      = dsDo stmts 
dsExpr (HsDo MDoExpr   stmts _)      = dsDo stmts 
dsExpr (HsDo MonadComp stmts _)      = dsMonadComp stmts
334

335 336 337 338 339 340 341 342
dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
  = do { pred <- dsLExpr guard_expr
       ; b1 <- dsLExpr then_expr
       ; b2 <- dsLExpr else_expr
       ; case mb_fun of
           Just fun -> do { core_fun <- dsExpr fun
                          ; return (mkCoreApps core_fun [pred,b1,b2]) }
           Nothing  -> return $ mkIfThenElse pred b1 b2 }
343 344 345
\end{code}


346 347 348
\noindent
\underline{\bf Various data construction things}
%              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
349
\begin{code}
350 351
dsExpr (ExplicitList elt_ty xs) 
  = dsExplicitList elt_ty xs
352

353 354
-- We desugar [:x1, ..., xn:] as
--   singletonP x1 +:+ ... +:+ singletonP xn
chak's avatar
chak committed
355
--
356
dsExpr (ExplicitPArr ty []) = do
357
    emptyP <- dsLookupDPHId emptyPName
358
    return (Var emptyP `App` Type ty)
359
dsExpr (ExplicitPArr ty xs) = do
360 361
    singletonP <- dsLookupDPHId singletonPName
    appP       <- dsLookupDPHId appPName
362 363 364 365 366
    xs'        <- mapM dsLExpr xs
    return . foldr1 (binary appP) $ map (unary singletonP) xs'
  where
    unary  fn x   = mkApps (Var fn) [Type ty, x]
    binary fn x y = mkApps (Var fn) [Type ty, x, y]
chak's avatar
chak committed
367

368
dsExpr (ArithSeq expr (From from))
369
  = App <$> dsExpr expr <*> dsLExpr from
370

371 372
dsExpr (ArithSeq expr (FromTo from to))
  = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
373

374
dsExpr (ArithSeq expr (FromThen from thn))
375 376 377 378 379 380 381 382 383 384
  = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]

dsExpr (ArithSeq expr (FromThenTo from thn to))
  = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]

dsExpr (PArrSeq expr (FromTo from to))
  = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]

dsExpr (PArrSeq expr (FromThenTo from thn to))
  = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
chak's avatar
chak committed
385

386
dsExpr (PArrSeq _ _)
chak's avatar
chak committed
387 388 389
  = panic "DsExpr.dsExpr: Infinite parallel array!"
    -- the parser shouldn't have generated it and the renamer and typechecker
    -- shouldn't have let it through
390 391
\end{code}

392 393 394
\noindent
\underline{\bf Record construction and update}
%              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
395
For record construction we do this (assuming T has three arguments)
396
\begin{verbatim}
397 398 399 400 401 402
	T { op2 = e }
==>
	let err = /\a -> recConErr a 
	T (recConErr t1 "M.lhs/230/op1") 
	  e 
	  (recConErr t1 "M.lhs/230/op3")
403 404
\end{verbatim}
@recConErr@ then converts its arugment string into a proper message
405
before printing it as
406 407 408
\begin{verbatim}
	M.lhs, line 230: missing field op1 was evaluated
\end{verbatim}
409

410 411
We also handle @C{}@ as valid construction syntax for an unlabelled
constructor @C@, setting all of @C@'s fields to bottom.
412

413
\begin{code}
414 415
dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do
    con_expr' <- dsExpr con_expr
416
    let
417 418 419 420 421 422 423 424
        (arg_tys, _) = tcSplitFunTys (exprType con_expr')
        -- A newtype in the corner should be opaque; 
        -- hence TcType.tcSplitFunTys

        mk_arg (arg_ty, lbl)    -- Selector id has the field label as its name
          = case findField (rec_flds rbinds) lbl of
              (rhs:rhss) -> ASSERT( null rhss )
                            dsLExpr rhs
425 426
              []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl)
        unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty empty
427 428 429 430 431 432 433 434 435

        labels = dataConFieldLabels (idDataCon data_con_id)
        -- The data_con_id is guaranteed to be the wrapper id of the constructor
    
    con_args <- if null labels
                then mapM unlabelled_bottom arg_tys
                else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
    
    return (mkApps con_expr' con_args)
436 437 438
\end{code}

Record update is a little harder. Suppose we have the decl:
439
\begin{verbatim}
440
	data T = T1 {op1, op2, op3 :: Int}
441
	       | T2 {op4, op2 :: Int}
442
	       | T3
443
\end{verbatim}
444
Then we translate as follows:
445
\begin{verbatim}
446 447 448 449 450 451 452
	r { op2 = e }
===>
	let op2 = e in
	case r of
	  T1 op1 _ op3 -> T1 op1 op2 op3
	  T2 op4 _     -> T2 op4 op2
	  other	       -> recUpdError "M.lhs/230"
453 454
\end{verbatim}
It's important that we use the constructor Ids for @T1@, @T2@ etc on the
455
RHSs, and do not generate a Core constructor application directly, because the constructor
456 457 458
might do some argument-evaluation first; and may have to throw away some
dictionaries.

459 460 461 462 463 464 465 466 467 468 469 470
Note [Update for GADTs]
~~~~~~~~~~~~~~~~~~~~~~~
Consider 
   data T a b where
     T1 { f1 :: a } :: T a Int

Then the wrapper function for T1 has type 
   $WT1 :: a -> T a Int
But if x::T a b, then
   x { f1 = v } :: T a b   (not T a Int!)
So we need to cast (T a Int) to (T a b).  Sigh.

471
\begin{code}
472 473 474
dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
		       cons_to_upd in_inst_tys out_inst_tys)
  | null fields
475
  = dsLExpr record_expr
476
  | otherwise
477
  = ASSERT2( notNull cons_to_upd, ppr expr )
478 479

    do	{ record_expr' <- dsLExpr record_expr
480
	; field_binds' <- mapM ds_field fields
481 482
	; let upd_fld_env :: NameEnv Id	-- Maps field name to the LocalId of the field binding
	      upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']
483

484 485 486 487
	-- It's important to generate the match with matchWrapper,
	-- and the right hand sides with applications of the wrapper Id
	-- so that everything works when we are doing fancy unboxing on the
	-- constructor aguments.
488
	; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
489 490
	; ([discrim_var], matching_code) 
		<- matchWrapper RecUpd (MatchGroup alts in_out_ty)
491

492 493 494
	; return (add_field_binds field_binds' $
		  bindNonRec discrim_var record_expr' matching_code) }
  where
495 496 497 498 499
    ds_field :: HsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr)
      -- Clone the Id in the HsRecField, because its Name is that
      -- of the record selector, and we must not make that a lcoal binder
      -- else we shadow other uses of the record selector
      -- Hence 'lcl_id'.  Cf Trac #2735
500
    ds_field rec_field = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
501 502 503
    	     	       	    ; let fld_id = unLoc (hsRecFieldId rec_field)
    	     	       	    ; lcl_id <- newSysLocalDs (idType fld_id)
			    ; return (idName fld_id, lcl_id, rhs) }
504 505

    add_field_binds [] expr = expr
506
    add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
507 508 509 510 511 512 513

	-- Awkwardly, for families, the match goes 
	-- from instance type to family type
    tycon     = dataConTyCon (head cons_to_upd)
    in_ty     = mkTyConApp tycon in_inst_tys
    in_out_ty = mkFunTy in_ty (mkFamilyTyConApp tycon out_inst_tys)

514
    mk_alt upd_fld_env con
515 516 517 518 519 520 521 522 523 524
      = do { let (univ_tvs, ex_tvs, eq_spec, 
		  eq_theta, dict_theta, arg_tys, _) = dataConFullSig con
		 subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys)

		-- I'm not bothering to clone the ex_tvs
	   ; eqs_vars   <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
	   ; theta_vars <- mapM newPredVarDs (substTheta subst (eq_theta ++ dict_theta))
	   ; arg_ids    <- newSysLocalsDs (substTys subst arg_tys)
	   ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
    					 (dataConFieldLabels con) arg_ids
525 526
                 mk_val_arg field_name pat_arg_id 
                     = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)
527 528
		 inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))
			-- Reconstruct with the WrapId so that unpacking happens
529 530
		 wrap = mkWpEvVarApps theta_vars          `WpCompose` 
			mkWpTyApps    (mkTyVarTys ex_tvs) `WpCompose`
531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548
			mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys
				       , isNothing (lookupTyVar wrap_subst tv) ]
    	         rhs = foldl (\a b -> nlHsApp a b) inst_con val_args

			-- Tediously wrap the application in a cast
			-- Note [Update for GADTs]
		 wrapped_rhs | null eq_spec = rhs
			     | otherwise    = mkLHsWrap (WpCast wrap_co) rhs
		 wrap_co = mkTyConApp tycon [ lookup tv ty 
					    | (tv,ty) <- univ_tvs `zip` out_inst_tys]
		 lookup univ_tv ty = case lookupTyVar wrap_subst univ_tv of
					Just ty' -> ty'
					Nothing  -> ty
		 wrap_subst = mkTopTvSubst [ (tv,mkSymCoercion (mkTyVarTy co_var))
					   | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ]
		 
    	         pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs
					 , pat_dicts = eqs_vars ++ theta_vars
549
					 , pat_binds = emptyTcEvBinds
550 551 552 553
					 , pat_args = PrefixCon $ map nlVarPat arg_ids
					 , pat_ty = in_ty }
	   ; return (mkSimpleMatch [pat] wrapped_rhs) }

554 555
\end{code}

556 557 558 559 560 561 562
Here is where we desugar the Template Haskell brackets and escapes

\begin{code}
-- Template Haskell stuff

#ifdef GHCI	/* Only if bootstrapping */
dsExpr (HsBracketOut x ps) = dsBracket x ps
563
dsExpr (HsSpliceE s)       = pprPanic "dsExpr:splice" (ppr s)
564 565
#endif

566
-- Arrow notation extension
567
dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
568 569
\end{code}

andy@galois.com's avatar
andy@galois.com committed
570 571 572
Hpc Support 

\begin{code}
573
dsExpr (HsTick ix vars e) = do
andy@galois.com's avatar
andy@galois.com committed
574
  e' <- dsLExpr e
575
  mkTickBox ix vars e'
andy@galois.com's avatar
andy@galois.com committed
576 577 578 579 580 581 582 583 584 585 586 587 588 589

-- There is a problem here. The then and else branches
-- have no free variables, so they are open to lifting.
-- We need someway of stopping this.
-- This will make no difference to binary coverage
-- (did you go here: YES or NO), but will effect accurate
-- tick counting.

dsExpr (HsBinTick ixT ixF e) = do
  e2 <- dsLExpr e
  do { ASSERT(exprType e2 `coreEqType` boolTy)
       mkBinaryTickBox ixT ixF e2
     }
\end{code}
590

591 592
\begin{code}

593 594 595
-- HsSyn constructs that just shouldn't be here:
dsExpr (ExprWithTySig _ _)  = panic "dsExpr:ExprWithTySig"

596 597 598 599 600

findField :: [HsRecField Id arg] -> Name -> [arg]
findField rbinds lbl 
  = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds 
	 , lbl == idName (unLoc id) ]
601 602
\end{code}

sof's avatar
sof committed
603
%--------------------------------------------------------------------
604

605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626
Note [Desugaring explicit lists]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Explicit lists are desugared in a cleverer way to prevent some
fruitless allocations.  Essentially, whenever we see a list literal
[x_1, ..., x_n] we:

1. Find the tail of the list that can be allocated statically (say
   [x_k, ..., x_n]) by later stages and ensure we desugar that
   normally: this makes sure that we don't cause a code size increase
   by having the cons in that expression fused (see later) and hence
   being unable to statically allocate any more

2. For the prefix of the list which cannot be allocated statically,
   say [x_1, ..., x_(k-1)], we turn it into an expression involving
   build so that if we find any foldrs over it it will fuse away
   entirely!
   
   So in this example we will desugar to:
   build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n]
   
   If fusion fails to occur then build will get inlined and (since we
   defined a RULE for foldr (:) []) we will get back exactly the
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
627 628 629 630 631 632 633 634 635
   normal desugaring for an explicit list.

This optimisation can be worth a lot: up to 25% of the total
allocation in some nofib programs. Specifically

        Program           Size    Allocs   Runtime  CompTime
        rewrite          +0.0%    -26.3%      0.02     -1.8%
           ansi          -0.3%    -13.8%      0.00     +0.0%
           lift          +0.0%     -8.7%      0.00     -2.3%
636 637 638

Of course, if rules aren't turned on then there is pretty much no
point doing this fancy stuff, and it may even be harmful.
639 640 641 642 643 644 645 646 647 648 649 650 651

=======>  Note by SLPJ Dec 08.

I'm unconvinced that we should *ever* generate a build for an explicit
list.  See the comments in GHC.Base about the foldr/cons rule, which 
points out that (foldr k z [a,b,c]) may generate *much* less code than
(a `k` b `k` c `k` z).

Furthermore generating builds messes up the LHS of RULES. 
Example: the foldr/single rule in GHC.Base
   foldr k z [x] = ...
We do not want to generate a build invocation on the LHS of this RULE!

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
652 653 654
We fix this by disabling rules in rule LHSs, and testing that
flag here; see Note [Desugaring RULE left hand sides] in Desugar

655 656 657 658
To test this I've added a (static) flag -fsimple-list-literals, which
makes all list literals be generated via the simple route.  


659 660 661
\begin{code}
dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
-- See Note [Desugaring explicit lists]
662 663 664 665 666 667
dsExplicitList elt_ty xs
  = do { dflags <- getDOptsDs
       ; xs' <- mapM dsLExpr xs
       ; let (dynamic_prefix, static_suffix) = spanTail is_static xs'
       ; if opt_SimpleListLiterals 	       		-- -fsimple-list-literals
         || not (dopt Opt_EnableRewriteRules dflags)	-- Rewrite rules off
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
668
	    	-- Don't generate a build if there are no rules to eliminate it!
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
669
		-- See Note [Desugaring RULE left hand sides] in Desugar
670 671 672
         || null dynamic_prefix   -- Avoid build (\c n. foldr c n xs)!
         then return $ mkListExpr elt_ty xs'
         else mkBuildExpr elt_ty (mkSplitExplicitList dynamic_prefix static_suffix) }
673
  where
674 675 676 677 678 679 680 681 682 683 684 685
    is_static :: CoreExpr -> Bool
    is_static e = all is_static_var (varSetElems (exprFreeVars e))

    is_static_var :: Var -> Bool
    is_static_var v 
      | isId v = isExternalName (idName v)  -- Top-level things are given external names
      | otherwise = False                   -- Type variables

    mkSplitExplicitList prefix suffix (c, _) (n, n_ty)
      = do { let suffix' = mkListExpr elt_ty suffix
           ; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix'
           ; return (foldr (App . App (Var c)) folded_suffix prefix) }
686 687 688 689 690 691

spanTail :: (a -> Bool) -> [a] -> ([a], [a])
spanTail f xs = (reverse rejected, reverse satisfying)
    where (satisfying, rejected) = span f $ reverse xs
\end{code}

692 693 694
Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
handled in DsListComp).  Basically does the translation given in the
Haskell 98 report:
695

696
\begin{code}
697 698
dsDo :: [LStmt Id] -> DsM CoreExpr
dsDo stmts
699
  = goL stmts
700
  where
701 702
    goL [] = panic "dsDo"
    goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
703
  
704 705 706
    go _ (LastStmt body _) stmts
      = ASSERT( null stmts ) dsLExpr body
        -- The 'return' op isn't used for 'do' expressions
707

708
    go _ (ExprStmt rhs then_expr _ _) stmts
709
      = do { rhs2 <- dsLExpr rhs
710
           ; warnDiscardedDoBindings rhs (exprType rhs2) 
711 712
           ; then_expr2 <- dsExpr then_expr
	   ; rest <- goL stmts
713
	   ; return (mkApps then_expr2 [rhs2, rest]) }
714
    
715
    go _ (LetStmt binds) stmts
716
      = do { rest <- goL stmts
717
	   ; dsLocalBinds binds rest }
718

719 720 721 722 723 724 725 726 727 728 729
    go _ (BindStmt pat rhs bind_op fail_op) stmts
      = do  { body     <- goL stmts
            ; rhs'     <- dsLExpr rhs
	    ; bind_op' <- dsExpr bind_op
	    ; var   <- selectSimpleMatchVarL pat
	    ; let bind_ty = exprType bind_op' 	-- rhs -> (pat -> res1) -> res2
	    	  res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
	    ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
    	    			      res1_ty (cantFailMatchResult body)
	    ; match_code <- handle_failure pat match fail_op
	    ; return (mkApps bind_op' [rhs', Lam var match_code]) }
730
    
731 732 733
    go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
                    , recS_rec_ids = rec_ids, recS_ret_fn = return_op
                    , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
734
                    , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts
735
      = ASSERT( length rec_ids > 0 )
736
        goL (new_bind_stmt : stmts)
737
      where
738 739
        new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats)
                                         mfix_app bind_op 
740
                                         noSyntaxExpr  -- Tuple cannot fail
741 742 743 744 745

        tup_ids      = rec_ids ++ filterOut (`elem` rec_ids) later_ids
        rec_tup_pats = map nlVarPat tup_ids
        later_pats   = rec_tup_pats
        rets         = map noLoc rec_rets
746 747 748 749 750
        mfix_app     = nlHsApp (noLoc mfix_op) mfix_arg
        mfix_arg     = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
                                                 (mkFunTy tup_ty body_ty))
        mfix_pat     = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats
        body         = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty
751
        ret_stmt     = noLoc $ LastStmt (mkLHsTupleExpr rets) return_op
752
        tup_ty       = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
753

754
handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr
755 756
    -- In a do expression, pattern-match failure just calls
    -- the monadic 'fail' rather than throwing an exception
757 758 759 760 761 762 763
handle_failure pat match fail_op
  | matchCanFail match
  = do { fail_op' <- dsExpr fail_op
       ; fail_msg <- mkStringExpr (mk_fail_msg pat)
       ; extractMatchResult match (App fail_op' fail_msg) }
  | otherwise
  = extractMatchResult match (error "It can't fail")
764

765
mk_fail_msg :: Located e -> String
766 767
mk_fail_msg pat = "Pattern match failure in do expression at " ++ 
		  showSDoc (ppr (getLoc pat))
768
\end{code}
769

770

771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800
%************************************************************************
%*									*
                 Warning about identities
%*									*
%************************************************************************

Warn about functions that convert between one type and another
when the to- and from- types are the same.  Then it's probably
(albeit not definitely) the identity
\begin{code}
warnAboutIdentities :: CoreExpr -> (CoreExpr -> CoreExpr) -> DsM ()
warnAboutIdentities (Var v) co_fn
  | idName v `elem` conversionNames
  , let fun_ty = exprType (co_fn (Var v))
  , Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty
  , arg_ty `tcEqType` res_ty  -- So we are converting  ty -> ty
  = warnDs (vcat [ ptext (sLit "Call of") <+> ppr v <+> dcolon <+> ppr fun_ty
                 , nest 2 $ ptext (sLit "can probably be omitted")
                 , parens (ptext (sLit "Use -fno-warn-identities to suppress this messsage)"))
           ])
warnAboutIdentities _ _ = return ()

conversionNames :: [Name]
conversionNames
  = [ toIntegerName, toRationalName
    , fromIntegralName, realToFracName ]
 -- We can't easily add fromIntegerName, fromRationalName,
 -- becuase they are generated by literals
\end{code}

801 802 803 804 805 806 807 808
%************************************************************************
%*									*
\subsection{Errors and contexts}
%*									*
%************************************************************************

\begin{code}
-- Warn about certain types of values discarded in monadic bindings (#3263)
809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826
warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM ()
warnDiscardedDoBindings rhs rhs_ty
  | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
  = do {  -- Warn about discarding non-() things in 'monadic' binding
       ; warn_unused <- doptDs Opt_WarnUnusedDoBind
       ; if warn_unused && not (isUnitTy elt_ty)
         then warnDs (unusedMonadBind rhs elt_ty)
         else 
         -- Warn about discarding m a things in 'monadic' binding of the same type,
         -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
    do { warn_wrong <- doptDs Opt_WarnWrongDoBind
       ; case tcSplitAppTy_maybe elt_ty of
           Just (elt_m_ty, _) | warn_wrong, m_ty `tcEqType` elt_m_ty
                              -> warnDs (wrongMonadBind rhs elt_ty)
           _ -> return () } }

  | otherwise	-- RHS does have type of form (m ty), which is wierd
  = return ()   -- but at lesat this warning is irrelevant
827 828

unusedMonadBind :: LHsExpr Id -> Type -> SDoc
829 830
unusedMonadBind rhs elt_ty
  = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$
831 832 833 834
    ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
    ptext (sLit "or by using the flag -fno-warn-unused-do-bind")

wrongMonadBind :: LHsExpr Id -> Type -> SDoc
835 836
wrongMonadBind rhs elt_ty
  = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$
837 838
    ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
    ptext (sLit "or by using the flag -fno-warn-wrong-do-bind")
839
\end{code}