2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[DsExpr]{Matching expressions (Exprs)}
7 #include "HsVersions.h"
9 module DsExpr ( dsExpr ) where
12 import DsLoop -- partly to get dsBinds, partly to chk dsExpr
14 import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
15 Match, Qual, HsBinds, Stmt, PolyType )
16 import TcHsSyn ( TypecheckedHsExpr(..), TypecheckedHsBinds(..) )
20 import DsCCall ( dsCCall )
21 import DsListComp ( dsListComp )
22 import DsUtils ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom )
23 import Match ( matchWrapper )
25 import CoreUnfold ( UnfoldingDetails(..), UnfoldingGuidance(..),
27 import CoreUtils ( coreExprType, substCoreExpr, argToExpr,
28 mkCoreIfThenElse, unTagBinders )
29 import CostCentre ( mkUserCC )
30 import Id ( mkTupleCon, idType, nullIdEnv, addOneToIdEnv,
32 import Literal ( mkMachInt, Literal(..) )
33 import MagicUFs ( MagicUnfoldingFun )
34 import PprStyle ( PprStyle(..) )
35 import PprType ( GenType )
36 import PrelInfo ( mkTupleTy, unitTy, nilDataCon, consDataCon,
38 import Pretty ( ppShow, ppBesides, ppPStr, ppStr )
39 import Type ( splitSigmaTy, typePrimRep )
40 import TyVar ( nullTyVarEnv, addOneToTyVarEnv )
41 import Usage ( UVar(..) )
42 import Util ( pprError, panic )
44 maybeBoxedPrimType = panic "DsExpr.maybeBoxedPrimType"
45 splitTyArgs = panic "DsExpr.splitTyArgs"
47 mk_nil_con ty = mkCon nilDataCon [] [ty] [] -- micro utility...
50 The funny business to do with variables is that we look them up in the
51 Id-to-Id and Id-to-Id maps that the monadery is carrying
52 around; if we get hits, we use the value accordingly.
54 %************************************************************************
56 \subsection[DsExpr-vars-and-cons]{Variables and constructors}
58 %************************************************************************
61 dsExpr :: TypecheckedHsExpr -> DsM CoreExpr
63 dsExpr (HsVar var) = dsApp (HsVar var) []
66 %************************************************************************
68 \subsection[DsExpr-literals]{Literals}
70 %************************************************************************
72 We give int/float literals type Integer and Rational, respectively.
73 The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
76 ToDo: put in range checks for when converting "i"
77 (or should that be in the typechecker?)
79 For numeric literals, we try to detect there use at a standard type
80 (Int, Float, etc.) are directly put in the right constructor.
81 [NB: down with the @App@ conversion.]
82 Otherwise, we punt, putting in a "NoRep" Core literal (where the
83 representation decisions are delayed)...
85 See also below where we look for @DictApps@ for \tr{plusInt}, etc.
88 dsExpr (HsLitOut (HsString s) _)
90 = returnDs (mk_nil_con charTy)
94 the_char = mkCon charDataCon [] [] [LitArg (MachChar (_HEAD_ s))]
95 the_nil = mk_nil_con charTy
97 mkConDs consDataCon [charTy] [the_char, the_nil]
99 -- "_" => build (\ c n -> c 'c' n) -- LATER
101 -- "str" ==> build (\ c n -> foldr charTy T c n "str")
104 dsExpr (HsLitOut (HsString str) _)
105 = newTyVarsDs [alphaTyVar] `thenDs` \ [new_tyvar] ->
107 new_ty = mkTyVarTy new_tyvar
110 charTy `mkFunTy` (new_ty `mkFunTy` new_ty),
112 mkForallTy [alphaTyVar]
113 ((charTy `mkFunTy` (alphaTy `mkFunTy` alphaTy))
114 `mkFunTy` (alphaTy `mkFunTy` alphaTy))
115 ] `thenDs` \ [c,n,g] ->
116 returnDs (mkBuild charTy new_tyvar c n g (
118 (CoTyApp (CoTyApp (Var foldrId) charTy) new_ty) *** ensure non-prim type ***
119 [VarArg c,VarArg n,LitArg (NoRepStr str)]))
122 -- otherwise, leave it as a NoRepStr;
123 -- the Core-to-STG pass will wrap it in an application of "unpackCStringId".
125 dsExpr (HsLitOut (HsString str) _)
126 = returnDs (Lit (NoRepStr str))
128 dsExpr (HsLitOut (HsLitLit s) ty)
129 = returnDs ( mkCon data_con [] [] [LitArg (MachLitLit s kind)] )
132 = case (maybeBoxedPrimType ty) of
133 Just (boxing_data_con, prim_ty)
134 -> (boxing_data_con, typePrimRep prim_ty)
136 -> pprError "ERROR: ``literal-literal'' not a single-constructor type: "
137 (ppBesides [ppPStr s, ppStr "; type: ", ppr PprDebug ty])
139 dsExpr (HsLitOut (HsInt i) _)
140 = returnDs (Lit (NoRepInteger i))
142 dsExpr (HsLitOut (HsFrac r) _)
143 = returnDs (Lit (NoRepRational r))
145 -- others where we know what to do:
147 dsExpr (HsLitOut (HsIntPrim i) _)
148 = if (i >= toInteger minInt && i <= toInteger maxInt) then
149 returnDs (Lit (mkMachInt i))
151 error ("ERROR: Int constant " ++ show i ++ out_of_range_msg)
153 dsExpr (HsLitOut (HsFloatPrim f) _)
154 = returnDs (Lit (MachFloat f))
155 -- ToDo: range checking needed!
157 dsExpr (HsLitOut (HsDoublePrim d) _)
158 = returnDs (Lit (MachDouble d))
159 -- ToDo: range checking needed!
161 dsExpr (HsLitOut (HsChar c) _)
162 = returnDs ( mkCon charDataCon [] [] [LitArg (MachChar c)] )
164 dsExpr (HsLitOut (HsCharPrim c) _)
165 = returnDs (Lit (MachChar c))
167 dsExpr (HsLitOut (HsStringPrim s) _)
168 = returnDs (Lit (MachStr s))
170 -- end of literals magic. --
172 dsExpr expr@(HsLam a_Match)
174 error_msg = "%L" --> "pattern-matching failed in lambda"
176 matchWrapper LambdaMatch [a_Match] error_msg `thenDs` \ (binders, matching_code) ->
177 returnDs ( mkValLam binders matching_code )
179 dsExpr expr@(HsApp e1 e2) = dsApp expr []
180 dsExpr expr@(OpApp e1 op e2) = dsApp expr []
183 Operator sections. At first it looks as if we can convert
192 But no! expr might be a redex, and we can lose laziness badly this
197 for example. So we convert instead to
199 let y = expr in \x -> op y x
201 If \tr{expr} is actually just a variable, say, then the simplifier
205 dsExpr (SectionL expr op)
206 = dsExpr op `thenDs` \ core_op ->
207 dsExpr expr `thenDs` \ core_expr ->
208 dsExprToAtom core_expr $ \ y_atom ->
210 -- for the type of x, we need the type of op's 2nd argument
212 x_ty = case (splitSigmaTy (coreExprType core_op)) of { (_, _, tau_ty) ->
213 case (splitTyArgs tau_ty) of {
214 ((_:arg2_ty:_), _) -> arg2_ty;
215 _ -> panic "dsExpr:SectionL:arg 2 ty"
218 newSysLocalDs x_ty `thenDs` \ x_id ->
219 returnDs (mkValLam [x_id] (core_op `App` y_atom `App` VarArg x_id))
221 -- dsExpr (SectionR op expr) -- \ x -> op x expr
222 dsExpr (SectionR op expr)
223 = dsExpr op `thenDs` \ core_op ->
224 dsExpr expr `thenDs` \ core_expr ->
225 dsExprToAtom core_expr $ \ y_atom ->
227 -- for the type of x, we need the type of op's 1st argument
229 x_ty = case (splitSigmaTy (coreExprType core_op)) of { (_, _, tau_ty) ->
230 case (splitTyArgs tau_ty) of {
231 ((arg1_ty:_), _) -> arg1_ty;
232 _ -> panic "dsExpr:SectionR:arg 1 ty"
235 newSysLocalDs x_ty `thenDs` \ x_id ->
236 returnDs (mkValLam [x_id] (core_op `App` VarArg x_id `App` y_atom))
238 dsExpr (CCall label args may_gc is_asm result_ty)
239 = mapDs dsExpr args `thenDs` \ core_args ->
240 dsCCall label core_args may_gc is_asm result_ty
241 -- dsCCall does all the unboxification, etc.
243 dsExpr (HsSCC cc expr)
244 = dsExpr expr `thenDs` \ core_expr ->
245 getModuleAndGroupDs `thenDs` \ (mod_name, group_name) ->
246 returnDs ( SCC (mkUserCC cc mod_name group_name) core_expr)
248 dsExpr expr@(HsCase discrim matches src_loc)
249 = putSrcLocDs src_loc $
250 dsExpr discrim `thenDs` \ core_discrim ->
252 error_msg = "%C" --> "pattern-matching failed in case"
254 matchWrapper CaseMatch matches error_msg `thenDs` \ ([discrim_var], matching_code) ->
255 returnDs ( mkCoLetAny (NonRec discrim_var core_discrim) matching_code )
257 dsExpr (ListComp expr quals)
258 = dsExpr expr `thenDs` \ core_expr ->
259 dsListComp core_expr quals
261 dsExpr (HsLet binds expr)
262 = dsBinds binds `thenDs` \ core_binds ->
263 dsExpr expr `thenDs` \ core_expr ->
264 returnDs ( mkCoLetsAny core_binds core_expr )
266 dsExpr (HsDoOut stmts m_id mz_id src_loc)
267 = putSrcLocDs src_loc $
268 panic "dsExpr:HsDoOut"
270 dsExpr (ExplicitListOut ty xs)
272 [] -> returnDs (mk_nil_con ty)
274 dsExpr y `thenDs` \ core_hd ->
275 dsExpr (ExplicitListOut ty ys) `thenDs` \ core_tl ->
276 mkConDs consDataCon [ty] [core_hd, core_tl]
278 dsExpr (ExplicitTuple expr_list)
279 = mapDs dsExpr expr_list `thenDs` \ core_exprs ->
280 mkConDs (mkTupleCon (length expr_list))
281 (map coreExprType core_exprs)
284 dsExpr (RecordCon con rbinds) = panic "dsExpr:RecordCon"
285 dsExpr (RecordUpd aexp rbinds) = panic "dsExpr:RecordUpd"
287 dsExpr (HsIf guard_expr then_expr else_expr src_loc)
288 = putSrcLocDs src_loc $
289 dsExpr guard_expr `thenDs` \ core_guard ->
290 dsExpr then_expr `thenDs` \ core_then ->
291 dsExpr else_expr `thenDs` \ core_else ->
292 returnDs (mkCoreIfThenElse core_guard core_then core_else)
294 dsExpr (ArithSeqOut expr (From from))
295 = dsExpr expr `thenDs` \ expr2 ->
296 dsExpr from `thenDs` \ from2 ->
297 mkAppDs expr2 [] [from2]
299 dsExpr (ArithSeqOut expr (FromTo from two))
300 = dsExpr expr `thenDs` \ expr2 ->
301 dsExpr from `thenDs` \ from2 ->
302 dsExpr two `thenDs` \ two2 ->
303 mkAppDs expr2 [] [from2, two2]
305 dsExpr (ArithSeqOut expr (FromThen from thn))
306 = dsExpr expr `thenDs` \ expr2 ->
307 dsExpr from `thenDs` \ from2 ->
308 dsExpr thn `thenDs` \ thn2 ->
309 mkAppDs expr2 [] [from2, thn2]
311 dsExpr (ArithSeqOut expr (FromThenTo from thn two))
312 = dsExpr expr `thenDs` \ expr2 ->
313 dsExpr from `thenDs` \ from2 ->
314 dsExpr thn `thenDs` \ thn2 ->
315 dsExpr two `thenDs` \ two2 ->
316 mkAppDs expr2 [] [from2, thn2, two2]
320 Type lambda and application
321 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
323 dsExpr (TyLam tyvars expr)
324 = dsExpr expr `thenDs` \ core_expr ->
325 returnDs (mkTyLam tyvars core_expr)
327 dsExpr expr@(TyApp e tys) = dsApp expr []
331 Record construction and update
332 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
335 dsExpr (RecordCon con_expr rbinds)
336 = dsExpr con_expr `thenDs` \ con_expr' ->
338 con_args = map mk_arg (arg_tys `zip` fieldLabelTags)
339 (arg_tys, data_ty) = splitFunTy (coreExprType con_expr')
341 mk_arg (arg_ty, tag) = case [ | (sel_id,rhs) <- rbinds,
342 fieldLabelTag (recordSelectorFieldLabel sel_id) == tag
344 (rhs:rhss) -> ASSERT( null rhss )
347 [] -> returnDs ......GONE HOME!>>>>>
349 mkAppDs con_expr [] con_args
353 Dictionary lambda and application
354 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
355 @DictLam@ and @DictApp@ turn into the regular old things.
356 (OLD:) @DictFunApp@ also becomes a curried application, albeit slightly more
357 complicated; reminiscent of fully-applied constructors.
359 dsExpr (DictLam dictvars expr)
360 = dsExpr expr `thenDs` \ core_expr ->
361 returnDs( mkValLam dictvars core_expr )
365 dsExpr expr@(DictApp e dicts) -- becomes a curried application
369 @SingleDicts@ become @Locals@; @Dicts@ turn into tuples, unless
371 @ClassDictLam dictvars methods expr@ is ``the opposite'':
373 \ x -> case x of ( dictvars-and-methods-tuple ) -> expr
376 dsExpr (SingleDict dict) -- just a local
377 = lookupEnvWithDefaultDs dict (Var dict)
379 dsExpr (Dictionary dicts methods)
380 = -- hey, these things may have been substituted away...
381 zipWithDs lookupEnvWithDefaultDs
382 dicts_and_methods dicts_and_methods_exprs
383 `thenDs` \ core_d_and_ms ->
385 (case num_of_d_and_ms of
386 0 -> returnDs cocon_unit -- unit
388 1 -> returnDs (head core_d_and_ms) -- just a single Id
391 mkConDs (mkTupleCon num_of_d_and_ms)
392 (map coreExprType core_d_and_ms)
396 dicts_and_methods = dicts ++ methods
397 dicts_and_methods_exprs = map Var dicts_and_methods
398 num_of_d_and_ms = length dicts_and_methods
400 dsExpr (ClassDictLam dicts methods expr)
401 = dsExpr expr `thenDs` \ core_expr ->
402 case num_of_d_and_ms of
403 0 -> newSysLocalDs unitTy `thenDs` \ new_x ->
404 returnDs (mkValLam [new_x] core_expr)
407 returnDs (mkValLam dicts_and_methods core_expr)
410 newSysLocalDs tuple_ty `thenDs` \ new_x ->
412 Lam (ValBinder new_x)
415 [(tuple_con, dicts_and_methods, core_expr)]
418 num_of_d_and_ms = length dicts + length methods
419 dicts_and_methods = dicts ++ methods
420 tuple_ty = mkTupleTy num_of_d_and_ms (map idType dicts_and_methods)
421 tuple_con = mkTupleCon num_of_d_and_ms
424 -- HsSyn constructs that just shouldn't be here:
425 dsExpr (HsDo _ _) = panic "dsExpr:HsDo"
426 dsExpr (ExplicitList _) = panic "dsExpr:ExplicitList"
427 dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig"
428 dsExpr (ArithSeqIn _) = panic "dsExpr:ArithSeqIn"
431 cocon_unit = mkCon (mkTupleCon 0) [] [] [] -- out here to avoid CAF (sigh)
432 out_of_range_msg -- ditto
433 = " out of range: [" ++ show minInt ++ ", " ++ show maxInt ++ "]\n"
436 %--------------------------------------------------------------------
438 @(dsApp e [t_1,..,t_n, e_1,..,e_n])@ returns something with the same
441 e t_1 ... t_n e_1 .. e_n
444 We're doing all this so we can saturate constructors (as painlessly as
448 type DsCoreArg = GenCoreArg CoreExpr{-NB!-} TyVar UVar
450 dsApp :: TypecheckedHsExpr -- expr to desugar
451 -> [DsCoreArg] -- accumulated ty/val args: NB:
452 -> DsM CoreExpr -- final result
454 dsApp (HsApp e1 e2) args
455 = dsExpr e2 `thenDs` \ core_e2 ->
456 dsApp e1 (VarArg core_e2 : args)
458 dsApp (OpApp e1 op e2) args
459 = dsExpr e1 `thenDs` \ core_e1 ->
460 dsExpr e2 `thenDs` \ core_e2 ->
461 dsApp op (VarArg core_e1 : VarArg core_e2 : args)
463 dsApp (DictApp expr dicts) args
464 = -- now, those dicts may have been substituted away...
465 zipWithDs lookupEnvWithDefaultDs dicts (map Var dicts)
466 `thenDs` \ core_dicts ->
467 dsApp expr (map VarArg core_dicts ++ args)
469 dsApp (TyApp expr tys) args
470 = dsApp expr (map TyArg tys ++ args)
472 -- we might should look out for SectionLs, etc., here, but we don't
475 = lookupEnvDs v `thenDs` \ maybe_expr ->
477 Just expr -> apply_to_args expr args
479 Nothing -> -- we're only saturating constructors and PrimOps
480 case getIdUnfolding v of
481 GenForm _ _ the_unfolding EssentialUnfolding
482 -> do_unfold nullTyVarEnv nullIdEnv (unTagBinders the_unfolding) args
484 _ -> apply_to_args (Var v) args
487 dsApp anything_else args
488 = dsExpr anything_else `thenDs` \ core_expr ->
489 apply_to_args core_expr args
491 -- a DsM version of mkGenApp:
492 apply_to_args :: CoreExpr -> [DsCoreArg] -> DsM CoreExpr
494 apply_to_args fun args
496 (ty_args, val_args) = foldr sep ([],[]) args
498 mkAppDs fun ty_args val_args
500 sep a@(LitArg l) (tys,vals) = (tys, (Lit l):vals)
501 sep a@(VarArg e) (tys,vals) = (tys, e:vals)
502 sep a@(TyArg ty) (tys,vals) = (ty:tys, vals)
503 sep a@(UsageArg _) _ = panic "DsExpr:apply_to_args:UsageArg"
507 do_unfold ty_env val_env (Lam (TyBinder tyvar) body) (TyArg ty : args)
508 = do_unfold (addOneToTyVarEnv ty_env tyvar ty) val_env body args
510 do_unfold ty_env val_env (Lam (ValBinder binder) body) (VarArg expr : args)
511 = dsExprToAtom expr $ \ arg_atom ->
513 (addOneToIdEnv val_env binder (argToExpr arg_atom))
516 do_unfold ty_env val_env body args
517 = -- Clone the remaining part of the template
518 uniqSMtoDsM (substCoreExpr val_env ty_env body) `thenDs` \ body' ->
520 -- Apply result to remaining arguments
521 apply_to_args body' args