2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[DsExpr]{Matching expressions (Exprs)}
7 #include "HsVersions.h"
9 module DsExpr ( dsExpr ) where
11 IMPORT_Trace -- ToDo: rm (debugging)
15 import AbsSyn -- the stuff being desugared
16 import PlainCore -- the output of desugaring;
17 -- importing this module also gets all the
18 -- CoreSyn utility functions
19 import DsMonad -- the monadery used in the desugarer
21 import AbsPrel ( mkTupleTy, unitTy, nilDataCon, consDataCon,
23 mkFunTy, mkBuild -- LATER: , foldrId
25 ,fromDomainId, toDomainId
26 #endif {- Data Parallel Haskell -}
28 import PrimKind ( PrimKind(..) ) -- rather ugly import *** ToDo???
29 import AbsUniType ( alpha, alpha_tv, beta, beta_tv, splitType,
30 splitTyArgs, mkTupleTyCon, mkTyVarTy, mkForallTy,
31 kindFromType, maybeBoxedPrimType,
32 TyVarTemplate, TyCon, Arity(..), Class,
35 import BasicLit ( mkMachInt, BasicLit(..) )
36 import CmdLineOpts ( GlobalSwitch(..), SwitchResult, switchIsOn )
37 import CostCentre ( mkUserCC )
38 import DsBinds ( dsBinds )
39 import DsCCall ( dsCCall )
40 import DsListComp ( dsListComp )
41 import DsUtils ( mkCoAppDs, mkCoConDs, mkCoPrimDs, dsExprToAtom )
45 import Match ( matchWrapper )
46 import Maybes ( Maybe(..) )
47 import TaggedCore ( TaggedBinder(..), unTagBinders )
52 import DsParZF ( dsParallelZF )
53 #endif {- Data Parallel Haskell -}
56 The funny business to do with variables is that we look them up in the
57 Id-to-Id and Id-to-Id maps that the monadery is carrying
58 around; if we get hits, we use the value accordingly.
60 %************************************************************************
62 \subsection[DsExpr-vars-and-cons]{Variables and constructors}
64 %************************************************************************
67 dsExpr :: TypecheckedExpr -> DsM PlainCoreExpr
69 dsExpr (Var var) = dsApp (Var var) []
72 %************************************************************************
74 \subsection[DsExpr-literals]{Literals}
76 %************************************************************************
78 We give int/float literals type Integer and Rational, respectively.
79 The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
82 ToDo: put in range checks for when converting "i"
83 (or should that be in the typechecker?)
85 For numeric literals, we try to detect there use at a standard type
86 (Int, Float, etc.) are directly put in the right constructor.
87 [NB: down with the @App@ conversion.]
88 Otherwise, we punt, putting in a "NoRep" Core literal (where the
89 representation decisions are delayed)...
91 See also below where we look for @DictApps@ for \tr{plusInt}, etc.
94 dsExpr (Lit (StringLit s))
96 = returnDs ( CoCon nilDataCon [charTy] [] )
100 the_char = CoCon charDataCon [] [CoLitAtom (MachChar (_HEAD_ s))]
101 the_nil = CoCon nilDataCon [charTy] []
103 mkCoConDs consDataCon [charTy] [the_char, the_nil]
105 -- "_" => build (\ c n -> c 'c' n) -- LATER
107 -- "str" ==> build (\ c n -> foldr charTy T c n "str")
110 dsExpr (Lit (StringLit str)) =
111 newTyVarsDs [alpha_tv] `thenDs` \ [new_tyvar] ->
113 new_ty = mkTyVarTy new_tyvar
116 charTy `mkFunTy` (new_ty `mkFunTy` new_ty),
118 mkForallTy [alpha_tv]
119 ((charTy `mkFunTy` (alpha `mkFunTy` alpha))
120 `mkFunTy` (alpha `mkFunTy` alpha))
121 ] `thenDs` \ [c,n,g] ->
122 returnDs (mkBuild charTy new_tyvar c n g (
124 (CoTyApp (CoTyApp (CoVar foldrId) charTy) new_ty) *** ensure non-prim type ***
125 [CoVarAtom c,CoVarAtom n,CoLitAtom (NoRepStr str)]))
128 -- otherwise, leave it as a NoRepStr;
129 -- the Core-to-STG pass will wrap it in an application of "unpackCStringId".
131 dsExpr (Lit (StringLit str))
132 = returnDs (CoLit (NoRepStr str))
134 dsExpr (Lit (LitLitLit s ty))
135 = returnDs ( CoCon data_con [] [CoLitAtom (MachLitLit s kind)] )
138 = case (maybeBoxedPrimType ty) of
140 -> error ("ERROR: ``literal-literal'' not a single-constructor type: "++ _UNPK_ s ++"; type: "++(ppShow 80 (ppr PprDebug ty)))
141 Just (boxing_data_con, prim_ty)
142 -> (boxing_data_con, kindFromType prim_ty)
144 dsExpr (Lit (IntLit i))
145 = returnDs (CoLit (NoRepInteger i))
147 dsExpr (Lit (FracLit r))
148 = returnDs (CoLit (NoRepRational r))
150 -- others where we know what to do:
152 dsExpr (Lit (IntPrimLit i))
153 = if (i >= toInteger minInt && i <= toInteger maxInt) then
154 returnDs (CoLit (mkMachInt i))
156 error ("ERROR: Int constant " ++ show i ++ out_of_range_msg)
158 dsExpr (Lit (FloatPrimLit f))
159 = returnDs (CoLit (MachFloat f))
160 -- ToDo: range checking needed!
162 dsExpr (Lit (DoublePrimLit d))
163 = returnDs (CoLit (MachDouble d))
164 -- ToDo: range checking needed!
166 dsExpr (Lit (CharLit c))
167 = returnDs ( CoCon charDataCon [] [CoLitAtom (MachChar c)] )
169 dsExpr (Lit (CharPrimLit c))
170 = returnDs (CoLit (MachChar c))
172 dsExpr (Lit (StringPrimLit s))
173 = returnDs (CoLit (MachStr s))
175 -- end of literals magic. --
177 dsExpr expr@(Lam a_Match)
179 error_msg = "%L" --> "pattern-matching failed in lambda"
181 matchWrapper LambdaMatch [a_Match] error_msg `thenDs` \ (binders, matching_code) ->
182 returnDs ( mkCoLam binders matching_code )
184 dsExpr expr@(App e1 e2) = dsApp expr []
186 dsExpr expr@(OpApp e1 op e2) = dsApp expr []
189 Operator sections. At first it looks as if we can convert
198 But no! expr might be a redex, and we can lose laziness badly this
203 for example. So we convert instead to
205 let y = expr in \x -> op y x
207 If \tr{expr} is actually just a variable, say, then the simplifier
211 dsExpr (SectionL expr op)
212 = dsExpr op `thenDs` \ core_op ->
213 dsExpr expr `thenDs` \ core_expr ->
214 dsExprToAtom core_expr ( \ y_atom ->
216 -- for the type of x, we need the type of op's 2nd argument
218 x_ty = case (splitType (typeOfCoreExpr core_op)) of { (_, _, tau_ty) ->
219 case (splitTyArgs tau_ty) of {
220 ((_:arg2_ty:_), _) -> arg2_ty;
221 _ -> panic "dsExpr:SectionL:arg 2 ty"--++(ppShow 80 (ppAboves [ppr PprDebug (typeOfCoreExpr core_op), ppr PprDebug tau_ty]))
224 newSysLocalDs x_ty `thenDs` \ x_id ->
225 returnDs ( mkCoLam [x_id] (CoApp (CoApp core_op y_atom) (CoVarAtom x_id)) ))
227 -- dsExpr (SectionR op expr) -- \ x -> op x expr
228 dsExpr (SectionR op expr)
229 = dsExpr op `thenDs` \ core_op ->
230 dsExpr expr `thenDs` \ core_expr ->
231 dsExprToAtom core_expr (\ y_atom ->
233 -- for the type of x, we need the type of op's 1st argument
235 x_ty = case (splitType (typeOfCoreExpr core_op)) of { (_, _, tau_ty) ->
236 case (splitTyArgs tau_ty) of {
237 ((arg1_ty:_), _) -> arg1_ty;
238 _ -> panic "dsExpr:SectionR:arg 1 ty"--++(ppShow 80 (ppAboves [ppr PprDebug (typeOfCoreExpr core_op), ppr PprDebug tau_ty]))
241 newSysLocalDs x_ty `thenDs` \ x_id ->
242 returnDs ( mkCoLam [x_id] (CoApp (CoApp core_op (CoVarAtom x_id)) y_atom) ))
244 dsExpr (CCall label args may_gc is_asm result_ty)
245 = mapDs dsExpr args `thenDs` \ core_args ->
246 dsCCall label core_args may_gc is_asm result_ty
247 -- dsCCall does all the unboxification, etc.
250 = dsExpr expr `thenDs` \ core_expr ->
251 getModuleAndGroupDs `thenDs` \ (mod_name, group_name) ->
252 returnDs ( CoSCC (mkUserCC cc mod_name group_name) core_expr)
254 dsExpr expr@(Case discrim matches)
255 = dsExpr discrim `thenDs` \ core_discrim ->
257 error_msg = "%C" --> "pattern-matching failed in case"
259 matchWrapper CaseMatch matches error_msg `thenDs` \ ([discrim_var], matching_code) ->
260 returnDs ( mkCoLetAny (CoNonRec discrim_var core_discrim) matching_code )
262 dsExpr (ListComp expr quals)
263 = dsExpr expr `thenDs` \ core_expr ->
264 dsListComp core_expr quals
266 dsExpr (Let binds expr)
267 = dsBinds binds `thenDs` \ core_binds ->
268 dsExpr expr `thenDs` \ core_expr ->
269 returnDs ( mkCoLetsAny core_binds core_expr )
271 dsExpr (ExplicitList _) = panic "dsExpr:ExplicitList -- not translated"
273 dsExpr (ExplicitListOut ty xs)
275 [] -> returnDs ( CoCon nilDataCon [ty] [] )
277 dsExpr y `thenDs` \ core_hd ->
278 dsExpr (ExplicitListOut ty ys) `thenDs` \ core_tl ->
279 mkCoConDs consDataCon [ty] [core_hd, core_tl]
281 dsExpr (ExplicitTuple expr_list)
282 = mapDs dsExpr expr_list `thenDs` \ core_exprs ->
283 mkCoConDs (mkTupleCon (length expr_list))
284 (map typeOfCoreExpr core_exprs)
287 dsExpr (ExprWithTySig expr sig) = panic "dsExpr: ExprWithTySig"
289 dsExpr (If guard_expr then_expr else_expr)
290 = dsExpr guard_expr `thenDs` \ core_guard ->
291 dsExpr then_expr `thenDs` \ core_then ->
292 dsExpr else_expr `thenDs` \ core_else ->
293 returnDs (mkCoreIfThenElse core_guard core_then core_else)
295 dsExpr (ArithSeqIn info) = panic "dsExpr.ArithSeqIn"
297 dsExpr (ArithSeqOut expr (From from))
298 = dsExpr expr `thenDs` \ expr2 ->
299 dsExpr from `thenDs` \ from2 ->
300 mkCoAppDs expr2 from2
302 dsExpr (ArithSeqOut expr (FromTo from two))
303 = dsExpr expr `thenDs` \ expr2 ->
304 dsExpr from `thenDs` \ from2 ->
305 dsExpr two `thenDs` \ two2 ->
306 mkCoAppDs expr2 from2 `thenDs` \ app1 ->
309 dsExpr (ArithSeqOut expr (FromThen from thn))
310 = dsExpr expr `thenDs` \ expr2 ->
311 dsExpr from `thenDs` \ from2 ->
312 dsExpr thn `thenDs` \ thn2 ->
313 mkCoAppDs expr2 from2 `thenDs` \ app1 ->
316 dsExpr (ArithSeqOut expr (FromThenTo from thn two))
317 = dsExpr expr `thenDs` \ expr2 ->
318 dsExpr from `thenDs` \ from2 ->
319 dsExpr thn `thenDs` \ thn2 ->
320 dsExpr two `thenDs` \ two2 ->
321 mkCoAppDs expr2 from2 `thenDs` \ app1 ->
322 mkCoAppDs app1 thn2 `thenDs` \ app2 ->
326 dsExpr (ParallelZF expr quals)
327 = dsParallelZF expr quals
329 dsExpr (ExplicitPodIn _)
330 = panic "dsExpr:ExplicitPodIn -- not translated"
332 dsExpr (ExplicitPodOut _ _)
333 = panic "dsExpr:ExplicitPodOut should remove this."
335 dsExpr (ExplicitProcessor exprs expr)
336 = mapDs dsExpr exprs `thenDs` \ core_exprs ->
337 dsExpr expr `thenDs` \ core_expr ->
338 mkCoConDs (mkProcessorCon (length exprs))
339 ((map typeOfCoreExpr core_exprs)++[typeOfCoreExpr core_expr])
340 (core_exprs++[core_expr])
341 #endif {- Data Parallel Haskell -}
345 dsExpr (TyLam tyvars expr)
346 = dsExpr expr `thenDs` \ core_expr ->
347 returnDs( foldr CoTyLam core_expr tyvars)
349 dsExpr expr@(TyApp e tys) = dsApp expr []
352 @DictLam@ and @DictApp@ turn into the regular old things.
353 (OLD:) @DictFunApp@ also becomes a curried application, albeit slightly more
354 complicated; reminiscent of fully-applied constructors.
356 dsExpr (DictLam dictvars expr)
357 = dsExpr expr `thenDs` \ core_expr ->
358 returnDs( mkCoLam dictvars core_expr )
362 dsExpr expr@(DictApp e dicts) -- becomes a curried application
366 @SingleDicts@ become @Locals@; @Dicts@ turn into tuples, unless
368 @ClassDictLam dictvars methods expr@ is ``the opposite'':
370 \ x -> case x of ( dictvars-and-methods-tuple ) -> expr
373 dsExpr (SingleDict dict) -- just a local
374 = lookupEnvWithDefaultDs dict (CoVar dict)
376 dsExpr (Dictionary dicts methods)
377 = -- hey, these things may have been substituted away...
378 zipWithDs lookupEnvWithDefaultDs
379 dicts_and_methods dicts_and_methods_exprs
380 `thenDs` \ core_d_and_ms ->
382 (case num_of_d_and_ms of
383 0 -> returnDs cocon_unit -- unit
385 1 -> returnDs (head core_d_and_ms) -- just a single Id
388 mkCoConDs (mkTupleCon num_of_d_and_ms)
389 (map typeOfCoreExpr core_d_and_ms)
393 dicts_and_methods = dicts ++ methods
394 dicts_and_methods_exprs = map CoVar dicts_and_methods
395 num_of_d_and_ms = length dicts_and_methods
397 dsExpr (ClassDictLam dicts methods expr)
398 = dsExpr expr `thenDs` \ core_expr ->
399 case num_of_d_and_ms of
400 0 -> newSysLocalDs unitTy `thenDs` \ new_x ->
401 returnDs (CoLam [new_x] core_expr)
404 returnDs (CoLam dicts_and_methods core_expr)
407 newSysLocalDs tuple_ty `thenDs` \ new_x ->
410 (CoCase (CoVar new_x)
412 [(tuple_con, dicts_and_methods, core_expr)]
415 dicts_and_methods = dicts ++ methods
416 num_of_d_and_ms = length dicts_and_methods
417 tuple_ty = mkTupleTy num_of_d_and_ms (map getIdUniType dicts_and_methods)
418 tuple_tycon = mkTupleTyCon num_of_d_and_ms
419 tuple_con = mkTupleCon num_of_d_and_ms
421 cocon_unit = CoCon (mkTupleCon 0) [] [] -- out here to avoid CAF (sigh)
422 out_of_range_msg -- ditto
423 = " out of range: [" ++ show minInt ++ ", " ++ show maxInt ++ "]\n"
426 %--------------------------------------------------------------------
428 @(dsApp e [t_1,..,t_n, e_1,..,e_n])@ returns something with the same
431 e t_1 ... t_n e_1 .. e_n
434 We're doing all this so we can saturate constructors (as painlessly as
440 | DsValArg PlainCoreExpr
442 dsApp :: TypecheckedExpr -- expr to desugar
443 -> [DsCoreArg] -- accumulated ty/val args: NB:
444 -> DsM PlainCoreExpr -- final result
446 dsApp (App e1 e2) args
447 = dsExpr e2 `thenDs` \ core_e2 ->
448 dsApp e1 (DsValArg core_e2 : args)
450 dsApp (OpApp e1 op e2) args
451 = dsExpr e1 `thenDs` \ core_e1 ->
452 dsExpr e2 `thenDs` \ core_e2 ->
453 dsApp op (DsValArg core_e1 : DsValArg core_e2 : args)
455 dsApp (DictApp expr dicts) args
456 = -- now, those dicts may have been substituted away...
457 zipWithDs lookupEnvWithDefaultDs dicts (map CoVar dicts)
458 `thenDs` \ core_dicts ->
459 dsApp expr (map DsValArg core_dicts ++ args)
461 dsApp (TyApp expr tys) args
462 = dsApp expr (map DsTypeArg tys ++ args)
464 -- we might should look out for SectionLs, etc., here, but we don't
467 = lookupEnvDs v `thenDs` \ maybe_expr ->
469 Just expr -> apply_to_args expr args
471 Nothing -> -- we're only saturating constructors and PrimOps
472 case getIdUnfolding v of
473 GeneralForm _ _ the_unfolding EssentialUnfolding
474 -> do_unfold nullTyVarEnv nullIdEnv (unTagBinders the_unfolding) args
476 _ -> apply_to_args (CoVar v) args
479 dsApp anything_else args
480 = dsExpr anything_else `thenDs` \ core_expr ->
481 apply_to_args core_expr args
483 -- a DsM version of applyToArgs:
484 apply_to_args :: PlainCoreExpr -> [DsCoreArg] -> DsM PlainCoreExpr
486 apply_to_args fun [] = returnDs fun
488 apply_to_args fun (DsValArg expr : args)
489 = mkCoAppDs fun expr `thenDs` \ fun2 ->
490 apply_to_args fun2 args
492 apply_to_args fun (DsTypeArg ty : args)
493 = apply_to_args (mkCoTyApp fun ty) args
497 do_unfold ty_env val_env (CoTyLam tyvar body) (DsTypeArg ty : args)
498 = do_unfold (addOneToTyVarEnv ty_env tyvar ty) val_env body args
500 do_unfold ty_env val_env (CoLam [] body) args
501 = do_unfold ty_env val_env body args
503 do_unfold ty_env val_env (CoLam (binder:binders) body) (DsValArg expr : args)
504 = dsExprToAtom expr (\ arg_atom ->
505 do_unfold ty_env (addOneToIdEnv val_env binder (atomToExpr arg_atom)) (CoLam binders body) args
508 do_unfold ty_env val_env body args
509 = -- Clone the remaining part of the template
510 uniqSMtoDsM (substCoreExprUS val_env ty_env body) `thenDs` \ body' ->
512 -- Apply result to remaining arguments
513 apply_to_args body' args