DsExpr.lhs 29.9 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
Simon Marlow's avatar
Simon Marlow committed
37
import TcHsSyn
38 39

-- NB: The desugarer, which straddles the source and Core worlds, sometimes
Simon Marlow's avatar
Simon Marlow committed
40 41 42
--     needs to see source types
import TcType
import Type
43
import Coercion
44
import CoreSyn
Simon Marlow's avatar
Simon Marlow committed
45
import CoreUtils
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 52 53 54 55 56
import CostCentre
import Id
import PrelInfo
import DataCon
import TysWiredIn
import BasicTypes
import PrelNames
57
import Maybes
Simon Marlow's avatar
Simon Marlow committed
58 59 60
import SrcLoc
import Util
import Bag
61
import Outputable
62
import FastString
63 64

import Control.Monad
65 66
\end{code}

67 68 69

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

\begin{code}
75 76 77 78 79 80 81
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
82
dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
83 84

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

97 98
-------------------------
ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
99
-- Special case for bindings which bind unlifted variables
100 101
-- We need to do a case right away, rather than building
-- a tuple and doing selections.
102
-- Silently ignore INLINE and SPECIALISE pragmas...
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
103
ds_val_bind (NonRecursive, hsbinds) body
104
  | [L _ (AbsBinds [] [] exports binds)] <- bagToList hsbinds,
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
105
    (L loc bind : null_binds) <- bagToList binds,
106 107 108
    isBangHsBind bind
    || isUnboxedTupleBind bind
    || or [isUnLiftedType (idType g) | (_, g, _, _) <- exports]
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
109
  = let
110 111 112
      body_w_exports		      = foldr bind_export body exports
      bind_export (tvs, g, l, _) body = ASSERT( null tvs )
				        bindNonRec g (Var l) body
113
    in
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
114 115 116 117 118 119 120
    ASSERT (null null_binds)
	-- 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.)
    putSrcSpanDs loc	$
    case bind of
121 122
      FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn, 
		fun_tick = tick, fun_infix = inf }
123 124 125 126 127
        -> 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_w_exports)
128

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
129
      PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }
130 131 132
	-> 	-- let C x# y# = rhs in body
		-- ==> case rhs of C x# y# -> body
	   putSrcSpanDs loc			$
133 134 135 136 137 138 139
           do { rhs <- dsGuarded grhss ty
              ; let upat = unLoc pat
                    eqn = EqnInfo { eqn_pats = [upat], 
                                    eqn_rhs = cantFailMatchResult body_w_exports }
              ; var    <- selectMatchVar upat
              ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
              ; return (scrungleMatch var rhs result) }
140

141
      _ -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body)
142

143

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
144
-- Ordinary case for bindings; none should be unlifted
145
ds_val_bind (_is_rec, binds) body
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
146 147 148
  = do	{ prs <- dsLHsBinds binds
	; ASSERT( not (any (isUnLiftedType . idType . fst) prs) )
	  case prs of
149 150
            [] -> return body
            _  -> return (Let (Rec prs) body) }
151
	-- Use a Rec regardless of is_rec. 
152
	-- Why? Because it allows the binds to be all
153 154 155 156 157
	-- 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
158 159 160
	--
	-- NB The previous case dealt with unlifted bindings, so we
	--    only have to deal with lifted ones now; so Rec is ok
161 162 163

isUnboxedTupleBind :: HsBind Id -> Bool
isUnboxedTupleBind (PatBind { pat_rhs_ty = ty }) = isUnboxedTupleType ty
164
isUnboxedTupleBind _                             = False
165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189

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
190

191
\end{code}
192 193 194

%************************************************************************
%*									*
195
\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
196 197 198 199
%*									*
%************************************************************************

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

202 203 204
dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e

dsExpr :: HsExpr Id -> DsM CoreExpr
205 206
dsExpr (HsPar e) 	      = dsLExpr e
dsExpr (ExprWithTySigOut e _) = dsLExpr e
207 208
dsExpr (HsVar var)     	      = return (Var var)
dsExpr (HsIPVar ip)    	      = return (Var (ipNameName ip))
209 210
dsExpr (HsLit lit)     	      = dsLit lit
dsExpr (HsOverLit lit) 	      = dsOverLit lit
211
dsExpr (HsWrap co_fn e)       = dsCoercion co_fn (dsExpr e)
212 213

dsExpr (NegApp expr neg_expr) 
214
  = App <$> dsExpr neg_expr <*> dsLExpr expr
215

216
dsExpr (HsLam a_Match)
217
  = uncurry mkLams <$> matchWrapper LambdaExpr a_Match
218

219
dsExpr (HsApp fun arg)
220
  = mkCoreAppDs <$> dsLExpr fun <*>  dsLExpr arg
221 222 223 224 225 226
\end{code}

Operator sections.  At first it looks as if we can convert
\begin{verbatim}
	(expr op)
\end{verbatim}
227
to
228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244
\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
245
dsExpr (OpApp e1 op _ e2)
246
  = -- for the type of y, we need the type of op's 2nd argument
247
    mkCoreAppsDs <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
sof's avatar
sof committed
248
    
249
dsExpr (SectionL expr op)	-- Desugar (e !) to ((!) e)
250
  = mkCoreAppDs <$> dsLExpr op <*> dsLExpr expr
251

252
-- dsLExpr (SectionR op expr)	-- \ x -> op x expr
253 254
dsExpr (SectionR op expr) = do
    core_op <- dsLExpr op
sof's avatar
sof committed
255
    -- for the type of x, we need the type of op's 2nd argument
256 257 258 259 260 261
    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 $
262
            Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
263

264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282
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) }

283 284 285
dsExpr (HsSCC cc expr) = do
    mod_name <- getModuleDs
    Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr
286

287 288 289 290

-- hdaume: core annotation

dsExpr (HsCoreAnn fs expr)
291
  = Note (CoreNote $ unpackFS fs) <$> dsLExpr expr
292

293 294 295
dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty)) 
  | isEmptyMatchGroup matches	-- A Core 'case' is always non-empty
  = 		      		-- So desugar empty HsCase to error call
296
    mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) (ptext (sLit "case"))
297 298 299 300 301

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

303 304
-- Pepe: The binds are in scope in the body but NOT in the binding group
--       This is to avoid silliness in breakpoints
305 306
dsExpr (HsLet binds body) = do
    body' <- dsLExpr body
307
    dsLocalBinds binds body'
308

chak's avatar
chak committed
309 310 311
-- 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.
--
312
dsExpr (HsDo ListComp stmts body result_ty)
sof's avatar
sof committed
313
  =	-- Special case for list comprehensions
314
    dsListComp stmts body elt_ty
chak's avatar
chak committed
315
  where
316
    [elt_ty] = tcTyConAppArgs result_ty
317

318 319 320 321 322
dsExpr (HsDo DoExpr stmts body result_ty)
  = dsDo stmts body result_ty

dsExpr (HsDo (MDoExpr tbl) stmts body result_ty)
  = dsMDo tbl stmts body result_ty
chak's avatar
chak committed
323

324
dsExpr (HsDo PArrComp stmts body result_ty)
chak's avatar
chak committed
325
  =	-- Special case for array comprehensions
326
    dsPArrComp (map unLoc stmts) body elt_ty
327
  where
328
    [elt_ty] = tcTyConAppArgs result_ty
329

330
dsExpr (HsIf guard_expr then_expr else_expr)
331
  = mkIfThenElse <$> dsLExpr guard_expr <*> dsLExpr then_expr <*> dsLExpr else_expr
332 333 334
\end{code}


335 336 337
\noindent
\underline{\bf Various data construction things}
%              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
338
\begin{code}
339 340
dsExpr (ExplicitList elt_ty xs) 
  = dsExplicitList elt_ty xs
341

342 343
-- We desugar [:x1, ..., xn:] as
--   singletonP x1 +:+ ... +:+ singletonP xn
chak's avatar
chak committed
344
--
345 346 347
dsExpr (ExplicitPArr ty []) = do
    emptyP <- dsLookupGlobalId emptyPName
    return (Var emptyP `App` Type ty)
348
dsExpr (ExplicitPArr ty xs) = do
349 350 351 352 353 354 355
    singletonP <- dsLookupGlobalId singletonPName
    appP       <- dsLookupGlobalId appPName
    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
356

357
dsExpr (ArithSeq expr (From from))
358
  = App <$> dsExpr expr <*> dsLExpr from
359

360 361
dsExpr (ArithSeq expr (FromTo from to))
  = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
362

363
dsExpr (ArithSeq expr (FromThen from thn))
364 365 366 367 368 369 370 371 372 373
  = 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
374

375
dsExpr (PArrSeq _ _)
chak's avatar
chak committed
376 377 378
  = panic "DsExpr.dsExpr: Infinite parallel array!"
    -- the parser shouldn't have generated it and the renamer and typechecker
    -- shouldn't have let it through
379 380
\end{code}

381 382 383
\noindent
\underline{\bf Record construction and update}
%              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
384
For record construction we do this (assuming T has three arguments)
385
\begin{verbatim}
386 387 388 389 390 391
	T { op2 = e }
==>
	let err = /\a -> recConErr a 
	T (recConErr t1 "M.lhs/230/op1") 
	  e 
	  (recConErr t1 "M.lhs/230/op3")
392 393
\end{verbatim}
@recConErr@ then converts its arugment string into a proper message
394
before printing it as
395 396 397
\begin{verbatim}
	M.lhs, line 230: missing field op1 was evaluated
\end{verbatim}
398

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

402
\begin{code}
403 404
dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do
    con_expr' <- dsExpr con_expr
405
    let
406 407 408 409 410 411 412 413
        (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
414 415
              []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl)
        unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty empty
416 417 418 419 420 421 422 423 424

        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)
425 426 427
\end{code}

Record update is a little harder. Suppose we have the decl:
428
\begin{verbatim}
429
	data T = T1 {op1, op2, op3 :: Int}
430
	       | T2 {op4, op2 :: Int}
431
	       | T3
432
\end{verbatim}
433
Then we translate as follows:
434
\begin{verbatim}
435 436 437 438 439 440 441
	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"
442 443
\end{verbatim}
It's important that we use the constructor Ids for @T1@, @T2@ etc on the
444
RHSs, and do not generate a Core constructor application directly, because the constructor
445 446 447
might do some argument-evaluation first; and may have to throw away some
dictionaries.

448 449 450 451 452 453 454 455 456 457 458 459
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.

460
\begin{code}
461 462 463
dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
		       cons_to_upd in_inst_tys out_inst_tys)
  | null fields
464
  = dsLExpr record_expr
465
  | otherwise
466
  = ASSERT2( notNull cons_to_upd, ppr expr )
467 468

    do	{ record_expr' <- dsLExpr record_expr
469
	; field_binds' <- mapM ds_field fields
470 471
	; 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']
472

473 474 475 476
	-- 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.
477
	; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
478 479
	; ([discrim_var], matching_code) 
		<- matchWrapper RecUpd (MatchGroup alts in_out_ty)
480

481 482 483
	; return (add_field_binds field_binds' $
		  bindNonRec discrim_var record_expr' matching_code) }
  where
484 485 486 487 488
    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
489
    ds_field rec_field = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
490 491 492
    	     	       	    ; let fld_id = unLoc (hsRecFieldId rec_field)
    	     	       	    ; lcl_id <- newSysLocalDs (idType fld_id)
			    ; return (idName fld_id, lcl_id, rhs) }
493 494

    add_field_binds [] expr = expr
495
    add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
496 497 498 499 500 501 502

	-- 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)

503
    mk_alt upd_fld_env con
504 505 506 507 508 509 510 511 512 513
      = 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
514 515
                 mk_val_arg field_name pat_arg_id 
                     = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)
516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542
		 inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))
			-- Reconstruct with the WrapId so that unpacking happens
		 wrap = mkWpApps theta_vars `WpCompose` 
			mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose`
			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
					 , pat_binds = emptyLHsBinds 
					 , pat_args = PrefixCon $ map nlVarPat arg_ids
					 , pat_ty = in_ty }
	   ; return (mkSimpleMatch [pat] wrapped_rhs) }

543 544
\end{code}

545 546 547 548 549 550 551
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
552
dsExpr (HsSpliceE s)       = pprPanic "dsExpr:splice" (ppr s)
553 554
#endif

555
-- Arrow notation extension
556
dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
557 558
\end{code}

andy@galois.com's avatar
andy@galois.com committed
559 560 561
Hpc Support 

\begin{code}
562
dsExpr (HsTick ix vars e) = do
andy@galois.com's avatar
andy@galois.com committed
563
  e' <- dsLExpr e
564
  mkTickBox ix vars e'
andy@galois.com's avatar
andy@galois.com committed
565 566 567 568 569 570 571 572 573 574 575 576 577 578

-- 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}
579

580 581
\begin{code}

582 583 584
-- HsSyn constructs that just shouldn't be here:
dsExpr (ExprWithTySig _ _)  = panic "dsExpr:ExprWithTySig"

585 586 587 588 589

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

sof's avatar
sof committed
592
%--------------------------------------------------------------------
593

594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615
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
616 617 618 619 620 621 622 623 624
   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%
625 626 627

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.
628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644

=======>  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!

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


645 646 647 648 649 650 651
\begin{code}

dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
-- See Note [Desugaring explicit lists]
dsExplicitList elt_ty xs = do
    dflags <- getDOptsDs
    xs' <- mapM dsLExpr xs
652
    if  opt_SimpleListLiterals || not (dopt Opt_EnableRewriteRules dflags)
653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668
        then return $ mkListExpr elt_ty xs'
        else mkBuildExpr elt_ty (mkSplitExplicitList (thisPackage dflags) xs')
  where
    mkSplitExplicitList this_package xs' (c, _) (n, n_ty) = do
        let (dynamic_prefix, static_suffix) = spanTail (rhsIsStatic this_package) xs'
            static_suffix' = mkListExpr elt_ty static_suffix
        
        folded_static_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) static_suffix'
        let build_body = foldr (App . App (Var c)) folded_static_suffix dynamic_prefix
        return build_body

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

669 670 671
Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
handled in DsListComp).  Basically does the translation given in the
Haskell 98 report:
672

673
\begin{code}
674 675 676
dsDo	:: [LStmt Id]
	-> LHsExpr Id
	-> Type			-- Type of the whole expression
677 678
	-> DsM CoreExpr

679
dsDo stmts body _result_ty
680
  = goL stmts
681
  where
682 683 684 685
    goL [] = dsLExpr body
    goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go stmt lstmts)
  
    go (ExprStmt rhs then_expr _) stmts
686
      = do { rhs2 <- dsLExpr rhs
687
           ; case tcSplitAppTy_maybe (exprType rhs2) of
688
                Just (container_ty, returning_ty) -> warnDiscardedDoBindings rhs container_ty returning_ty
689 690 691
                _                                 -> return ()
           ; then_expr2 <- dsExpr then_expr
	   ; rest <- goL stmts
692
	   ; return (mkApps then_expr2 [rhs2, rest]) }
693
    
694 695
    go (LetStmt binds) stmts
      = do { rest <- goL stmts
696
	   ; dsLocalBinds binds rest }
697

698
    go (BindStmt pat rhs bind_op fail_op) stmts
699
      = 
700
       do  { body     <- goL stmts
701 702
           ; rhs'     <- dsLExpr rhs
	   ; bind_op' <- dsExpr bind_op
703
	   ; var   <- selectSimpleMatchVarL pat
704 705
	   ; let bind_ty = exprType bind_op' 	-- rhs -> (pat -> res1) -> res2
		 res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
706
	   ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
707
    				     res1_ty (cantFailMatchResult body)
708
	   ; match_code <- handle_failure pat match fail_op
709
	   ; return (mkApps bind_op' [rhs', Lam var match_code]) }
710 711 712 713 714 715 716 717 718 719 720
    
    -- In a do expression, pattern-match failure just calls
    -- the monadic 'fail' rather than throwing an exception
    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") 

721
mk_fail_msg :: Located e -> String
722 723
mk_fail_msg pat = "Pattern match failure in do expression at " ++ 
		  showSDoc (ppr (getLoc pat))
724
\end{code}
725 726 727 728 729 730 731 732 733

Translation for RecStmt's: 
-----------------------------
We turn (RecStmt [v1,..vn] stmts) into:
  
  (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
				      return (v1,..vn))

\begin{code}
734 735 736 737 738 739 740
dsMDo	:: PostTcTable
	-> [LStmt Id]
	-> LHsExpr Id
	-> Type			-- Type of the whole expression
	-> DsM CoreExpr

dsMDo tbl stmts body result_ty
741
  = goL stmts
742
  where
743 744 745
    goL [] = dsLExpr body
    goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
  
746 747 748 749 750 751 752 753
    (m_ty, b_ty) = tcSplitAppTy result_ty	-- result_ty must be of the form (m b)
    mfix_id   = lookupEvidence tbl mfixName
    return_id = lookupEvidence tbl returnMName
    bind_id   = lookupEvidence tbl bindMName
    then_id   = lookupEvidence tbl thenMName
    fail_id   = lookupEvidence tbl failMName
    ctxt      = MDoExpr tbl

754 755
    go _ (LetStmt binds) stmts
      = do { rest <- goL stmts
756
	   ; dsLocalBinds binds rest }
757

758
    go _ (ExprStmt rhs _ rhs_ty) stmts
759
      = do { rhs2 <- dsLExpr rhs
760
	   ; warnDiscardedDoBindings rhs m_ty rhs_ty
761
           ; rest <- goL stmts
762
	   ; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
763
    
764 765
    go _ (BindStmt pat rhs _ _) stmts
      = do { body  <- goL stmts
766 767 768 769 770 771 772
	   ; var   <- selectSimpleMatchVarL pat
	   ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
    				  result_ty (cantFailMatchResult body)
	   ; fail_msg   <- mkStringExpr (mk_fail_msg pat)
	   ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
	   ; match_code <- extractMatchResult match fail_expr

773
	   ; rhs'       <- dsLExpr rhs
774
	   ; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty, 
775 776
					     rhs', Lam var match_code]) }
    
777
    go loc (RecStmt rec_stmts later_ids rec_ids rec_rets binds) stmts
778 779
      = ASSERT( length rec_ids > 0 )
        ASSERT( length rec_ids == length rec_rets )
780
	goL (new_bind_stmt : let_stmt : stmts)
781
      where
782 783
        new_bind_stmt = L loc $ mkBindStmt (mk_tup_pat later_pats) mfix_app
	let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
784

785 786 787 788 789 790 791
	
		-- Remove the later_ids that appear (without fancy coercions) 
		-- in rec_rets, because there's no need to knot-tie them separately
		-- See Note [RecStmt] in HsExpr
	later_ids'   = filter (`notElem` mono_rec_ids) later_ids
	mono_rec_ids = [ id | HsVar id <- rec_rets ]
    
792
	mfix_app = nlHsApp (nlHsTyApp mfix_id [tup_ty]) mfix_arg
793
	mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
794
					     (mkFunTy tup_ty body_ty))
795

796
	-- The rec_tup_pat must bind the rec_ids only; remember that the 
797 798
	-- 	trimmed_laters may share the same Names
	-- Meanwhile, the later_pats must bind the later_vars
799 800 801
	rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids
	later_pats   = map nlVarPat    later_ids' ++ map mk_later_pat rec_ids
	rets         = map nlHsVar     later_ids' ++ map noLoc rec_rets
802 803

	mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
804
	body     = noLoc $ HsDo ctxt rec_stmts return_app body_ty
805
	body_ty = mkAppTy m_ty tup_ty
806
	tup_ty  = mkCoreTupTy (map idType (later_ids' ++ rec_ids))
807
		  -- mkCoreTupTy deals with singleton case
808

809
	return_app  = nlHsApp (nlHsTyApp return_id [tup_ty]) 
810
			      (mkLHsTupleExpr rets)
811 812 813 814 815

	mk_wild_pat :: Id -> LPat Id 
   	mk_wild_pat v = noLoc $ WildPat $ idType v

	mk_later_pat :: Id -> LPat Id
816 817
	mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
		       | otherwise	     = nlVarPat v
818 819 820

 	mk_tup_pat :: [LPat Id] -> LPat Id
  	mk_tup_pat [p] = p
821
	mk_tup_pat ps  = noLoc $ mkVanillaTuplePat ps Boxed
822
\end{code}
823 824 825 826 827 828 829 830 831 832


%************************************************************************
%*									*
\subsection{Errors and contexts}
%*									*
%************************************************************************

\begin{code}
-- Warn about certain types of values discarded in monadic bindings (#3263)
833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858
warnDiscardedDoBindings :: LHsExpr Id -> Type -> Type -> DsM ()
warnDiscardedDoBindings rhs container_ty returning_ty = do {
          -- Warn about discarding non-() things in 'monadic' binding
        ; warn_unused <- doptDs Opt_WarnUnusedDoBind
        ; if warn_unused && not (returning_ty `tcEqType` unitTy)
           then warnDs (unusedMonadBind rhs returning_ty)
           else do {
          -- 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
        ; warn_wrong <- doptDs Opt_WarnWrongDoBind
        ; case tcSplitAppTy_maybe returning_ty of
                  Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $
                                                            warnDs (wrongMonadBind rhs returning_ty)
                  _ -> return () } }

unusedMonadBind :: LHsExpr Id -> Type -> SDoc
unusedMonadBind rhs returning_ty
  = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
    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
wrongMonadBind rhs returning_ty
  = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
    ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
    ptext (sLit "or by using the flag -fno-warn-wrong-do-bind")
859
\end{code}