2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[CoreUtils]{Utility functions}
6 These functions are re-exported by the various parameterisations of
10 #include "HsVersions.h"
13 typeOfCoreExpr, typeOfCoreAlts,
15 instCoreExpr, substCoreExpr, -- UNUSED: cloneCoreExpr,
16 substCoreExprUS, -- UNUSED: instCoreExprUS, cloneCoreExprUS,
22 mkCoLetAny, mkCoLetNoUnboxed, mkCoLetUnboxedToCase,
23 mkCoLetsAny, mkCoLetsNoUnboxed, mkCoLetsUnboxedToCase,
24 mkCoLetrecAny, mkCoLetrecNoUnboxed,
25 mkCoLam, mkCoreIfThenElse,
26 -- mkCoApp, mkCoCon, mkCoPrim, -- no need to export
28 mkCoTyLam, mkCoTyApps,
29 mkErrorCoApp, escErrorMsg,
31 mkFunction, atomToExpr,
34 manifestlyWHNF, manifestlyBottom, --UNUSED: manifestWHNFArgs,
38 --UNUSED: boilsDownToConApp,
40 squashableDictishCcExpr,
42 unTagBinders, unTagBindersAlts,
46 isParCoreCaseAlternative,
47 #endif {- Data Parallel Haskell -}
49 -- to make the interface self-sufficient...
50 CoreAtom, CoreExpr, Id, UniType, UniqueSupply, UniqSM(..),
51 IdEnv(..), UniqFM, Unique, TyVarEnv(..), Maybe
54 --IMPORT_Trace -- ToDo: debugging only
57 import AbsPrel ( mkFunTy, trueDataCon, falseDataCon,
58 eRROR_ID, pAT_ERROR_ID, aBSENT_ERROR_ID,
60 boolTyCon, fragilePrimOp,
61 PrimOp(..), typeOfPrimOp,
63 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
64 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
66 , mkPodTy, mkPodizedPodNTy
67 #endif {- Data Parallel Haskell -}
70 import BasicLit ( isNoRepLit, typeOfBasicLit, BasicLit(..)
71 IF_ATTACK_PRAGMAS(COMMA isLitLitLit)
73 import CostCentre ( isDictCC, CostCentre )
77 import Maybes ( catMaybes, maybeToBool, Maybe(..) )
80 import PlainCore -- the main stuff we're defining functions for
81 import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
83 import TyCon ( getPodizedPodDimension )
84 #endif {- Data Parallel Haskell -}
87 import Unique -- UniqueSupply monadery used here
91 %************************************************************************
93 \subsection[bindersOf]{Small but useful}
95 %************************************************************************
99 bindersOf :: CoreBinding bder bdee -> [bder]
100 bindersOf (CoNonRec binder _) = [binder]
101 bindersOf (CoRec pairs) = [binder | (binder,_) <- pairs]
105 %************************************************************************
107 \subsection[typeOfCore]{Find the type of a Core atom/expression}
109 %************************************************************************
112 typeOfCoreExpr :: PlainCoreExpr -> UniType
113 typeOfCoreExpr (CoVar var) = getIdUniType var
114 typeOfCoreExpr (CoLit lit) = typeOfBasicLit lit
115 typeOfCoreExpr (CoLet binds body) = typeOfCoreExpr body
116 typeOfCoreExpr (CoSCC label expr) = typeOfCoreExpr expr
118 -- a CoCon is a fully-saturated application of a data constructor
119 typeOfCoreExpr (CoCon con tys _)
120 = applyTyCon (getDataConTyCon con) tys
122 -- and, analogously, ...
123 typeOfCoreExpr expr@(CoPrim op tys args)
124 -- Note: CoPrims may be polymorphic, so we do de-forall'ing.
126 op_ty = typeOfPrimOp op
127 op_tau_ty = foldl applyTy op_ty tys
129 funResultTy op_tau_ty (length args)
131 typeOfCoreExpr (CoCase _ alts) = typeOfCoreAlts alts
132 -- Q: What if the one you happen to grab is an "error"?
133 -- A: NO problem. The type application of error to its type will give you
136 typeOfCoreExpr (CoLam binders expr)
137 = foldr (mkFunTy . getIdUniType) (typeOfCoreExpr expr) binders
139 typeOfCoreExpr (CoTyLam tyvar expr)
140 = case (quantifyTy [tyvar] (typeOfCoreExpr expr)) of
141 (_, ty) -> ty -- not worried about the TyVarTemplates that come back
143 typeOfCoreExpr expr@(CoApp _ _) = typeOfCoreApp expr
144 typeOfCoreExpr expr@(CoTyApp _ _) = typeOfCoreApp expr
147 typeOfCoreExpr (CoParCon con ctxt tys args)
148 = mkPodizedPodNTy ctxt (applyTyCon (getDataConTyCon con) tys)
150 typeOfCoreExpr (CoZfExpr expr quals)
151 = mkPodTy (typeOfCoreExpr expr)
153 typeOfCoreExpr (CoParComm _ expr _)
154 = typeOfCoreExpr expr
155 #endif {- Data Parallel Haskell -}
159 typeOfCoreApp application
160 = case (collectArgs application) of { (fun, args) ->
161 apply_args (typeOfCoreExpr fun) args
164 apply_args expr_ty [] = expr_ty
166 apply_args fun_ty (TypeArg ty_arg : args)
167 = apply_args (applyTy fun_ty ty_arg) args
169 apply_args fun_ty (ValArg val_arg : args)
170 = case (maybeUnpackFunTy fun_ty) of
171 Just (_, result_ty) -> apply_args result_ty args
173 Nothing -> pprPanic "typeOfCoreApp:\n"
175 [ppr PprDebug val_arg,
177 ppr PprShowAll application])
181 typeOfCoreAlts :: PlainCoreCaseAlternatives -> UniType
182 typeOfCoreAlts (CoAlgAlts [] deflt) = typeOfDefault deflt
183 typeOfCoreAlts (CoAlgAlts ((_,_,rhs1):_) _) = typeOfCoreExpr rhs1
185 typeOfCoreAlts (CoPrimAlts [] deflt) = typeOfDefault deflt
186 typeOfCoreAlts (CoPrimAlts ((_,rhs1):_) _) = typeOfCoreExpr rhs1
188 typeOfCoreAlts (CoParAlgAlts _ _ _ [] deflt) = typeOfDefault deflt
189 typeOfCoreAlts (CoParAlgAlts _ _ _ ((_,rhs1):_) _) = typeOfCoreExpr rhs1
191 typeOfCoreAlts (CoParPrimAlts _ _ [] deflt) = typeOfDefault deflt
192 typeOfCoreAlts (CoParPrimAlts _ _ ((_,rhs1):_) _) = typeOfCoreExpr rhs1
193 #endif {- Data Parallel Haskell -}
195 typeOfDefault CoNoDefault = panic "typeOfCoreExpr:CoCase:typeOfDefault"
196 typeOfDefault (CoBindDefault _ rhs) = typeOfCoreExpr rhs
199 %************************************************************************
201 \subsection[CoreFuns-instantiate]{Instantiating core expressions: interfaces}
203 %************************************************************************
205 These subst/inst functions {\em must not} use splittable
206 UniqueSupplies! (yet)
208 All of the desired functions are done by one piece of code, which
209 carries around a little (monadised) state (a @UniqueSupply@).
210 Meanwhile, here is what the outside world sees (NB: @UniqueSupply@
214 cloneCoreExpr :: UniqueSupply
215 -> PlainCoreExpr -- template
216 -> (UniqueSupply, PlainCoreExpr)
218 cloneCoreExpr us expr = instCoreExpr us expr
223 instCoreExpr :: UniqueSupply
225 -> (UniqueSupply, PlainCoreExpr)
228 = initUs us (do_CoreExpr nullIdEnv nullTyVarEnv expr)
230 instCoreBindings :: UniqueSupply
231 -> [PlainCoreBinding]
232 -> (UniqueSupply, [PlainCoreBinding])
234 instCoreBindings us binds
235 = initUs us (do_CoreBindings nullIdEnv nullTyVarEnv binds)
239 substCoreExpr :: UniqueSupply
241 -> TypeEnv -- TyVar=>UniType
243 -> (UniqueSupply, PlainCoreExpr)
245 substCoreExpr us venv tenv expr
246 = initUs us (substCoreExprUS venv tenv expr)
248 -- we are often already in a UniqSM world, so here are the interfaces
251 cloneCoreExprUS :: PlainCoreExpr{-template-} -> UniqSM PlainCoreExpr
253 cloneCoreExprUS = instCoreExprUS
255 instCoreExprUS :: PlainCoreExpr -> UniqSM PlainCoreExpr
257 instCoreExprUS expr = do_CoreExpr nullIdEnv nullTyVarEnv expr
262 substCoreExprUS :: ValEnv
263 -> TypeEnv -- TyVar=>UniType
265 -> UniqSM PlainCoreExpr
267 substCoreExprUS venv tenv expr
268 -- if the envs are empty, then avoid doing anything
269 = if (isNullIdEnv venv && isNullTyVarEnv tenv) then
272 do_CoreExpr venv tenv expr
275 %************************************************************************
277 \subsection[CoreFuns-inst-exprs]{Actual expression-instantiating code}
279 %************************************************************************
281 The equiv code for @UniTypes@ is in @UniTyFuns@.
283 Because binders aren't necessarily unique: we don't do @plusEnvs@
284 (which check for duplicates); rather, we use the shadowing version,
285 @growIdEnv@ (and shorthand @addOneToIdEnv@).
288 type ValEnv = IdEnv PlainCoreExpr
290 do_CoreBinding :: ValEnv
293 -> UniqSM (PlainCoreBinding, ValEnv)
295 do_CoreBinding venv tenv (CoNonRec binder rhs)
296 = do_CoreExpr venv tenv rhs `thenUs` \ new_rhs ->
298 dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) ->
299 -- now plug new bindings into envs
300 let new_venv = addOneToIdEnv venv old new in
302 returnUs (CoNonRec new_binder new_rhs, new_venv)
304 do_CoreBinding venv tenv (CoRec binds)
305 = -- for letrec, we plug in new bindings BEFORE cloning rhss
306 mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) ->
307 let new_venv = growIdEnvList venv new_maps in
309 mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss ->
310 returnUs (CoRec (new_binders `zip` new_rhss), new_venv)
312 binders = map fst binds
316 @do_CoreBindings@ takes into account the semantics of a list of
317 @CoreBindings@---things defined early in the list are visible later in
318 the list, but not vice versa.
321 do_CoreBindings :: ValEnv
323 -> [PlainCoreBinding]
324 -> UniqSM [PlainCoreBinding]
326 do_CoreBindings venv tenv [] = returnUs []
327 do_CoreBindings venv tenv (b:bs)
328 = do_CoreBinding venv tenv b `thenUs` \ (new_b, new_venv) ->
329 do_CoreBindings new_venv tenv bs `thenUs` \ new_bs ->
330 returnUs (new_b : new_bs)
334 do_CoreAtom :: ValEnv
337 -> UniqSM PlainCoreExpr
339 do_CoreAtom venv tenv a@(CoLitAtom lit) = returnUs (CoLit lit)
341 do_CoreAtom venv tenv orig_a@(CoVarAtom v)
343 case (lookupIdEnv venv v) of
344 Nothing -> --false:ASSERT(toplevelishId v)
351 do_CoreExpr :: ValEnv
354 -> UniqSM PlainCoreExpr
356 do_CoreExpr venv tenv orig_expr@(CoVar var)
358 case (lookupIdEnv venv var) of
359 Nothing -> --false:ASSERT(toplevelishId var) (SIGH)
364 do_CoreExpr venv tenv e@(CoLit _) = returnUs e
366 do_CoreExpr venv tenv (CoCon con ts as)
368 new_ts = map (applyTypeEnvToTy tenv) ts
370 mapUs (do_CoreAtom venv tenv) as `thenUs` \ new_as ->
371 mkCoCon con new_ts new_as
373 do_CoreExpr venv tenv (CoPrim op tys as)
375 new_tys = map (applyTypeEnvToTy tenv) tys
377 mapUs (do_CoreAtom venv tenv) as `thenUs` \ new_as ->
378 do_PrimOp op `thenUs` \ new_op ->
379 mkCoPrim new_op new_tys new_as
381 do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty)
383 new_arg_tys = map (applyTypeEnvToTy tenv) arg_tys
384 new_result_ty = applyTypeEnvToTy tenv result_ty
386 returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty)
388 do_PrimOp other_op = returnUs other_op
390 do_CoreExpr venv tenv (CoLam binders expr)
391 = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) ->
392 let new_venv = growIdEnvList venv new_maps in
393 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
394 returnUs (CoLam new_binders new_expr)
396 do_CoreExpr venv tenv (CoTyLam tyvar expr)
397 = dup_tyvar tyvar `thenUs` \ (new_tyvar, (old, new)) ->
399 new_tenv = addOneToTyVarEnv tenv old new
401 do_CoreExpr venv new_tenv expr `thenUs` \ new_expr ->
402 returnUs (CoTyLam new_tyvar new_expr)
404 do_CoreExpr venv tenv (CoApp expr atom)
405 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
406 do_CoreAtom venv tenv atom `thenUs` \ new_atom ->
407 mkCoApp new_expr new_atom
409 do_CoreExpr venv tenv (CoTyApp expr ty)
410 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
412 new_ty = applyTypeEnvToTy tenv ty
414 returnUs (CoTyApp new_expr new_ty)
416 do_CoreExpr venv tenv (CoCase expr alts)
417 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
418 do_alts venv tenv alts `thenUs` \ new_alts ->
419 returnUs (CoCase new_expr new_alts)
421 do_alts venv tenv (CoAlgAlts alts deflt)
422 = mapUs (do_boxed_alt venv tenv) alts `thenUs` \ new_alts ->
423 do_default venv tenv deflt `thenUs` \ new_deflt ->
424 returnUs (CoAlgAlts new_alts new_deflt)
426 do_boxed_alt venv tenv (con, binders, expr)
427 = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_vmaps) ->
428 let new_venv = growIdEnvList venv new_vmaps in
429 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
430 returnUs (con, new_binders, new_expr)
433 do_alts venv tenv (CoPrimAlts alts deflt)
434 = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts ->
435 do_default venv tenv deflt `thenUs` \ new_deflt ->
436 returnUs (CoPrimAlts new_alts new_deflt)
438 do_unboxed_alt venv tenv (lit, expr)
439 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
440 returnUs (lit, new_expr)
442 do_alts venv tenv (CoParAlgAlts tycon dim params alts deflt)
443 = mapAndUnzipUs (dup_binder tenv) params `thenUs` \ (new_params,new_vmaps) ->
444 let new_venv = growIdEnvList venv new_vmaps in
445 mapUs (do_boxed_alt new_venv tenv) alts
446 `thenUs` \ new_alts ->
447 do_default venv tenv deflt `thenUs` \ new_deflt ->
448 returnUs (CoParAlgAlts tycon dim new_params new_alts new_deflt)
450 do_boxed_alt venv tenv (con, expr)
451 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
452 returnUs (con, new_expr)
454 do_alts venv tenv (CoParPrimAlts tycon dim alts deflt)
455 = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts ->
456 do_default venv tenv deflt `thenUs` \ new_deflt ->
457 returnUs (CoParPrimAlts tycon dim new_alts new_deflt)
459 do_unboxed_alt venv tenv (lit, expr)
460 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
461 returnUs (lit, new_expr)
462 #endif {- Data Parallel Haskell -}
464 do_default venv tenv CoNoDefault = returnUs CoNoDefault
466 do_default venv tenv (CoBindDefault binder expr)
467 = dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) ->
468 let new_venv = addOneToIdEnv venv old new in
469 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
470 returnUs (CoBindDefault new_binder new_expr)
472 do_CoreExpr venv tenv (CoLet core_bind expr)
473 = do_CoreBinding venv tenv core_bind `thenUs` \ (new_bind, new_venv) ->
474 -- and do the body of the let
475 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
476 returnUs (CoLet new_bind new_expr)
478 do_CoreExpr venv tenv (CoSCC label expr)
479 = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
480 returnUs (CoSCC label new_expr)
483 do_CoreExpr venv tenv (CoParCon con ctxt ts es)
485 new_ts = map (applyTypeEnvToTy tenv) ts
487 mapUs (do_CoreExpr venv tenv) es) `thenUs` \ new_es ->
488 returnUs (CoParCon con ctxt new_ts new_es)
490 do_CoreExpr venv tenv (CoZfExpr expr quals)
491 = do_CoreParQuals venv tenv quals `thenUs` \ (quals',venv') ->
492 do_CoreExpr venv' tenv expr `thenUs` \ expr' ->
493 returnUs (CoZfExpr expr' quals')
495 do_CoreExpr venv tenv (CoParComm dim expr comm)
496 = do_CoreExpr venv tenv expr `thenUs` \ expr' ->
497 do_ParComm comm `thenUs` \ comm' ->
498 returnUs (CoParComm dim expr' comm')
500 do_ParComm (CoParSend exprs)
501 = mapUs (do_CoreExpr venv tenv) exprs `thenUs` \ exprs' ->
502 returnUs (CoParSend exprs')
503 do_ParComm (CoParFetch exprs)
504 = mapUs (do_CoreExpr venv tenv) exprs `thenUs` \ exprs' ->
505 returnUs (CoParFetch exprs')
506 do_ParComm (CoToPodized)
507 = returnUs (CoToPodized)
508 do_ParComm (CoFromPodized)
509 = returnUs (CoFromPodized)
510 #endif {- Data Parallel Haskell -}
515 do_CoreParQuals :: ValEnv
518 -> UniqSM (PlainCoreParQuals, ValEnv)
520 do_CoreParQuals venv tenv (CoAndQuals l r)
521 = do_CoreParQuals venv tenv r `thenUs` \ (r',right_venv) ->
522 do_CoreParQuals right_venv tenv l `thenUs` \ (l',left_env) ->
523 returnUs (CoAndQuals l' r',left_env)
525 do_CoreParQuals venv tenv (CoParFilter expr)
526 = do_CoreExpr venv tenv expr `thenUs` \ expr' ->
527 returnUs (CoParFilter expr',venv))
529 do_CoreParQuals venv tenv (CoDrawnGen binders binder expr)
530 = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (newBs,newMs) ->
531 let new_venv = growIdEnvList venv newMs in
532 dup_binder tenv binder `thenUs` \ (newB,(old,new)) ->
533 let new_venv' = addOneToIdEnv new_venv old new in
534 do_CoreExpr new_venv' tenv expr `thenUs` \ new_expr ->
535 returnUs (CoDrawnGen newBs newB new_expr,new_venv')
537 do_CoreParQuals venv tenv (CoIndexGen exprs binder expr)
538 = mapUs (do_CoreExpr venv tenv) exprs `thenUs` \ new_exprs ->
539 dup_binder tenv binder `thenUs` \ (newB,(old,new)) ->
540 let new_venv = addOneToIdEnv venv old new in
541 do_CoreExpr new_venv tenv expr `thenUs` \ new_expr ->
542 returnUs (CoIndexGen new_exprs newB new_expr,new_venv)
543 #endif {- Data Parallel Haskell -}
547 dup_tyvar :: TyVar -> UniqSM (TyVar, (TyVar, UniType))
549 = getUnique `thenUs` \ uniq ->
550 let new_tyvar = cloneTyVar tyvar uniq in
551 returnUs (new_tyvar, (tyvar, mkTyVarTy new_tyvar))
553 -- same thing all over again --------------------
555 dup_binder :: TypeEnv -> Id -> UniqSM (Id, (Id, PlainCoreExpr))
557 = if (toplevelishId b) then
558 -- binder is "top-level-ish"; -- it should *NOT* be renamed
559 -- ToDo: it's unsavoury that we return something to heave in env
560 returnUs (b, (b, CoVar b))
562 else -- otherwise, the full business
563 getUnique `thenUs` \ uniq ->
565 new_b1 = mkIdWithNewUniq b uniq
566 new_b2 = applyTypeEnvToId tenv new_b1
568 returnUs (new_b2, (b, CoVar new_b2))
571 %************************************************************************
573 \subsection[mk_CoreExpr_bits]{Routines to manufacture bits of @CoreExpr@}
575 %************************************************************************
577 When making @CoLets@, we may want to take evasive action if the thing
578 being bound has unboxed type. We have different variants ...
580 @mkCoLet(s|rec)Any@ let-binds any binding, regardless of type
581 @mkCoLet(s|rec)NoUnboxed@ prohibits unboxed bindings
582 @mkCoLet(s)UnboxedToCase@ converts an unboxed binding to a case
583 (unboxed bindings in a letrec are still prohibited)
586 mkCoLetAny :: PlainCoreBinding -> PlainCoreExpr -> PlainCoreExpr
588 mkCoLetAny bind@(CoRec binds) body
589 = mkCoLetrecAny binds body
590 mkCoLetAny bind@(CoNonRec binder rhs) body
592 CoVar binder2 | binder `eqId` binder2
593 -> rhs -- hey, I have the rhs
597 mkCoLetsAny [] expr = expr
598 mkCoLetsAny binds expr = foldr mkCoLetAny expr binds
600 mkCoLetrecAny :: [(Id, PlainCoreExpr)] -- bindings
601 -> PlainCoreExpr -- body
602 -> PlainCoreExpr -- result
604 mkCoLetrecAny [] body = body
605 mkCoLetrecAny binds body
606 = CoLet (CoRec binds) body
610 mkCoLetNoUnboxed :: PlainCoreBinding -> PlainCoreExpr -> PlainCoreExpr
612 mkCoLetNoUnboxed bind@(CoRec binds) body
613 = mkCoLetrecNoUnboxed binds body
614 mkCoLetNoUnboxed bind@(CoNonRec binder rhs) body
615 = ASSERT (not (isUnboxedDataType (getIdUniType binder)))
617 CoVar binder2 | binder `eqId` binder2
618 -> rhs -- hey, I have the rhs
622 mkCoLetsNoUnboxed [] expr = expr
623 mkCoLetsNoUnboxed binds expr = foldr mkCoLetNoUnboxed expr binds
625 mkCoLetrecNoUnboxed :: [(Id, PlainCoreExpr)] -- bindings
626 -> PlainCoreExpr -- body
627 -> PlainCoreExpr -- result
629 mkCoLetrecNoUnboxed [] body = body
630 mkCoLetrecNoUnboxed binds body
631 = ASSERT (all is_boxed_bind binds)
632 CoLet (CoRec binds) body
634 is_boxed_bind (binder, rhs)
635 = (not . isUnboxedDataType . getIdUniType) binder
639 mkCoLetUnboxedToCase :: PlainCoreBinding -> PlainCoreExpr -> PlainCoreExpr
641 mkCoLetUnboxedToCase bind@(CoRec binds) body
642 = mkCoLetrecNoUnboxed binds body
643 mkCoLetUnboxedToCase bind@(CoNonRec binder rhs) body
645 CoVar binder2 | binder `eqId` binder2
646 -> rhs -- hey, I have the rhs
648 -> if (not (isUnboxedDataType (getIdUniType binder))) then
649 CoLet bind body -- boxed...
652 let (tycon,_,_) = getUniDataTyCon (getIdUniType binder) in
653 if isPodizedPodTyCon tycon
655 (CoParPrimAlts tycon (getPodizedPodDimension tycon) []
656 (CoBindDefault binder body))
659 CoCase rhs -- unboxed...
661 (CoBindDefault binder body))
663 mkCoLetsUnboxedToCase [] expr = expr
664 mkCoLetsUnboxedToCase binds expr = foldr mkCoLetUnboxedToCase expr binds
667 Clump CoLams together if possible; friendlier to the code generator.
670 mkCoLam :: [binder] -> CoreExpr binder bindee -> CoreExpr binder bindee
671 mkCoLam [] body = body
673 = case (digForLambdas body) of { (tyvars, body_binders, body_expr) ->
674 if not (null tyvars) then
675 pprTrace "Inner /\\'s:" (ppr PprDebug tyvars)
676 (CoLam binders (mkCoTyLam tyvars (mkCoLam body_binders body_expr)))
678 CoLam (binders ++ body_binders) body_expr
681 mkCoTyLam :: [TyVar] -> CoreExpr binder bindee -> CoreExpr binder bindee
682 mkCoTyLam tvs body = foldr CoTyLam body tvs
684 mkCoTyApps :: CoreExpr binder bindee -> [UniType] -> CoreExpr binder bindee
685 mkCoTyApps expr tys = foldl mkCoTyApp expr tys
689 mkCoreIfThenElse (CoVar bool) then_expr else_expr
690 | bool `eqId` trueDataCon = then_expr
691 | bool `eqId` falseDataCon = else_expr
693 mkCoreIfThenElse guard then_expr else_expr
695 (CoAlgAlts [ (trueDataCon, [], then_expr),
696 (falseDataCon, [], else_expr) ]
701 mkErrorCoApp :: UniType -> Id -> String -> PlainCoreExpr
703 mkErrorCoApp ty str_var error_msg
704 --OLD: | not (isPrimType ty)
705 = CoLet (CoNonRec str_var (CoLit (NoRepStr (_PK_ error_msg)))) (
706 CoApp (CoTyApp (CoVar pAT_ERROR_ID) ty) (CoVarAtom str_var))
707 {- TOO PARANOID: removed 95/02 WDP
709 -- for now, force the user to write their own suitably-typed error msg
710 = error (ppShow 80 (ppAboves [
711 ppStr "ERROR: can't generate a pattern-matching error message",
712 ppStr " when a primitive type is involved.",
713 ppCat [ppStr "Type:", ppr PprDebug ty],
714 ppCat [ppStr "Var :", ppr PprDebug str_var],
715 ppCat [ppStr "Msg :", ppStr error_msg]
720 escErrorMsg ('%':xs) = '%' : '%' : escErrorMsg xs
721 escErrorMsg (x:xs) = x : escErrorMsg xs
724 For making @CoApps@ and @CoLets@, we must take appropriate evasive
725 action if the thing being bound has unboxed type. @mkCoApp@ requires
726 a name supply to do its work. Other-monad code will call @mkCoApp@
727 through its own interface function (e.g., the desugarer uses
730 @mkCoApp@, @mkCoCon@ and @mkCoPrim@ also handle the
731 arguments-must-be-atoms constraint.
734 mkCoApp :: PlainCoreExpr -> PlainCoreExpr -> UniqSM PlainCoreExpr
736 mkCoApp e1 (CoVar v) = returnUs (CoApp e1 (CoVarAtom v))
737 mkCoApp e1 (CoLit l) = returnUs (CoApp e1 (CoLitAtom l))
740 e2_ty = typeOfCoreExpr e2
742 getUnique `thenUs` \ uniq ->
744 new_var = mkSysLocal SLIT("a") uniq e2_ty mkUnknownSrcLoc
747 mkCoLetUnboxedToCase (CoNonRec new_var e2)
748 (CoApp e1 (CoVarAtom new_var))
753 mkCoCon :: Id -> [UniType] -> [PlainCoreExpr] -> UniqSM PlainCoreExpr
754 mkCoPrim :: PrimOp -> [UniType] -> [PlainCoreExpr] -> UniqSM PlainCoreExpr
756 mkCoCon con tys args = mkCoThing (CoCon con) tys args
757 mkCoPrim op tys args = mkCoThing (CoPrim op) tys args
759 mkCoThing thing tys args
760 = mapAndUnzipUs expr_to_atom args `thenUs` \ (atoms, maybe_binds) ->
761 returnUs (mkCoLetsUnboxedToCase (catMaybes maybe_binds) (thing tys atoms))
763 expr_to_atom :: PlainCoreExpr
764 -> UniqSM (PlainCoreAtom, Maybe PlainCoreBinding)
766 expr_to_atom (CoVar v) = returnUs (CoVarAtom v, Nothing)
767 expr_to_atom (CoLit l) = returnUs (CoLitAtom l, Nothing)
768 expr_to_atom other_expr
770 e_ty = typeOfCoreExpr other_expr
772 getUnique `thenUs` \ uniq ->
774 new_var = mkSysLocal SLIT("a") uniq e_ty mkUnknownSrcLoc
775 new_atom = CoVarAtom new_var
777 returnUs (new_atom, Just (CoNonRec new_var other_expr))
781 atomToExpr :: CoreAtom bindee -> CoreExpr binder bindee
783 atomToExpr (CoVarAtom v) = CoVar v
784 atomToExpr (CoLitAtom lit) = CoLit lit
788 pairsFromCoreBinds :: [CoreBinding a b] -> [(a, CoreExpr a b)]
790 pairsFromCoreBinds [] = []
791 pairsFromCoreBinds ((CoNonRec b e) : bs) = (b,e) : (pairsFromCoreBinds bs)
792 pairsFromCoreBinds ((CoRec pairs) : bs) = pairs ++ (pairsFromCoreBinds bs)
797 mkNonRecBinds :: [(a, CoreExpr a b)] -> [CoreBinding a b]
798 mkNonRecBinds xs = [ CoNonRec b e | (b,e) <- xs ]
800 isParCoreCaseAlternative :: CoreCaseAlternatives a b -> Bool
802 isParCoreCaseAlternative (CoParAlgAlts _ _ _ _ _) = True
803 isParCoreCaseAlternative (CoParPrimAlts _ _ _ _) = True
805 isParCoreCaseAlternative _ = False
806 #endif {- Data Parallel Haskell -}
810 mkFunction tys args e
811 = foldr CoTyLam (mkCoLam args e) tys
813 mkCoApps :: PlainCoreExpr -> [PlainCoreExpr] -> UniqSM PlainCoreExpr
815 mkCoApps fun [] = returnUs fun
816 mkCoApps fun (arg:args)
817 = mkCoApp fun arg `thenUs` \ new_fun ->
818 mkCoApps new_fun args
821 We often want to strip off leading \tr{/\}-bound @TyVars@ and
822 \tr{\}-bound binders, before we get down to business. @digForLambdas@
826 digForLambdas :: CoreExpr bndr bdee -> ([TyVar], [bndr], CoreExpr bndr bdee)
828 digForLambdas (CoTyLam tyvar body)
830 (tyvars, args, final_body) = digForLambdas body
832 (tyvar:tyvars, args, final_body)
836 (args, body) = dig_in_lambdas other
840 dig_in_lambdas (CoLam args_here body)
842 (args, final_body) = dig_in_lambdas body
844 (args_here ++ args, final_body)
847 dig_in_lambdas body@(CoTyLam ty expr)
848 = trace "Inner /\\'s when digging" ([],body)
856 exprSmallEnoughToDup :: CoreExpr binder Id -> Bool
858 exprSmallEnoughToDup (CoCon _ _ _) = True -- Could check # of args
859 exprSmallEnoughToDup (CoPrim op _ _) = not (fragilePrimOp op) -- Could check # of args
860 exprSmallEnoughToDup (CoLit lit) = not (isNoRepLit lit)
862 exprSmallEnoughToDup expr -- for now, just: <var> applied to <args>
863 = case (collectArgs expr) of { (fun, args) ->
865 CoVar v -> v /= buildId && length args <= 6 -- or 10 or 1 or 4 or anything smallish.
869 Question (ADR): What is the above used for? Is a _ccall_ really small
872 @manifestlyWHNF@ looks at a Core expression and returns \tr{True} if
873 it is obviously in weak head normal form. It isn't a disaster if it
874 errs on the conservative side (returning \tr{False})---I've probably
875 left something out... [WDP]
878 manifestlyWHNF :: CoreExpr bndr Id -> Bool
880 manifestlyWHNF (CoVar _) = True
881 manifestlyWHNF (CoLit _) = True
882 manifestlyWHNF (CoCon _ _ _) = True -- ToDo: anything for CoPrim?
883 manifestlyWHNF (CoLam _ _) = True
884 manifestlyWHNF (CoTyLam _ e) = manifestlyWHNF e
885 manifestlyWHNF (CoSCC _ e) = manifestlyWHNF e
886 manifestlyWHNF (CoLet _ e) = False
887 manifestlyWHNF (CoCase _ _) = False
889 manifestlyWHNF other_expr -- look for manifest partial application
890 = case (collectArgs other_expr) of { (fun, args) ->
893 num_val_args = length [ a | (ValArg a) <- args ]
895 num_val_args == 0 || -- Just a type application of
896 -- a variable (f t1 t2 t3)
898 case (arityMaybe (getIdArity f)) of
900 Just arity -> num_val_args < arity
906 @manifestlyBottom@ looks at a Core expression and returns \tr{True} if
907 it is obviously bottom, that is, it will certainly return bottom at
908 some point. It isn't a disaster if it errs on the conservative side
909 (returning \tr{False}).
912 manifestlyBottom :: CoreExpr bndr Id -> Bool
914 manifestlyBottom (CoVar v) = isBottomingId v
915 manifestlyBottom (CoLit _) = False
916 manifestlyBottom (CoCon _ _ _) = False
917 manifestlyBottom (CoPrim _ _ _)= False
918 manifestlyBottom (CoLam _ _) = False -- we do not assume \x.bottom == bottom. should we? ToDo
919 manifestlyBottom (CoTyLam _ e) = manifestlyBottom e
920 manifestlyBottom (CoSCC _ e) = manifestlyBottom e
921 manifestlyBottom (CoLet _ e) = manifestlyBottom e
923 manifestlyBottom (CoCase e a)
926 CoAlgAlts alts def -> all mbalg alts && mbdef def
927 CoPrimAlts alts def -> all mbprim alts && mbdef def
930 mbalg (_,_,e') = manifestlyBottom e'
932 mbprim (_,e') = manifestlyBottom e'
934 mbdef CoNoDefault = True
935 mbdef (CoBindDefault _ e') = manifestlyBottom e'
937 manifestlyBottom other_expr -- look for manifest partial application
938 = case (collectArgs other_expr) of { (fun, args) ->
940 CoVar f | isBottomingId f -> True -- Application of a function which
941 -- always gives bottom; we treat this as
942 -- a WHNF, because it certainly doesn't
943 -- need to be shared!
948 UNUSED: @manifestWHNFArgs@ guarantees that an expression can absorb n args
949 before it ceases to be a manifest WHNF. E.g.,
952 (\x -> +Int x) gives 2
955 The function guarantees to err on the side of conservatism: the
956 conservative result is (Just 0).
958 An applications of @error@ are special, because it can absorb as many
959 arguments as you care to give it. For this special case we return Nothing.
963 manifestWHNFArgs :: CoreExpr bndr Id
964 -> Maybe Int -- Nothing indicates applicn of "error"
966 manifestWHNFArgs expr
967 = my_trace (man expr)
969 man (CoLit _) = Just 0
970 man (CoCon _ _ _) = Just 0
971 man (CoLam bs e) = man e `plus_args` length bs
972 man (CoApp e _) = man e `minus_args` 1
973 man (CoTyLam _ e) = man e
974 man (CoSCC _ e) = man e
975 man (CoLet _ e) = man e
978 | isBottomingId f = Nothing
979 | otherwise = case (arityMaybe (getIdArity f)) of
981 Just arity -> Just arity
983 man other = Just 0 -- Give up on case
985 plus_args, minus_args :: Maybe Int -> Int -> Maybe Int
987 plus_args Nothing m = Nothing
988 plus_args (Just n) m = Just (n+m)
990 minus_args Nothing m = Nothing
991 minus_args (Just n) m = Just (n-m)
995 -- else pprTrace "manifest:" (ppCat [ppr PprDebug fun,
996 -- ppr PprDebug args, ppStr "=>", ppInt n])
1003 :: (Id -> Maybe (CoreExpr bndr Id))
1006 coreExprArity f (CoLam bnds expr) = coreExprArity f expr + length (bnds)
1007 coreExprArity f (CoTyLam _ expr) = coreExprArity f expr
1008 coreExprArity f (CoApp expr arg) = max (coreExprArity f expr - 1) 0
1009 coreExprArity f (CoTyApp expr _) = coreExprArity f expr
1010 coreExprArity f (CoVar v) = max further info
1015 Just expr -> coreExprArity f expr
1016 info = case (arityMaybe (getIdArity v)) of
1019 coreExprArity f _ = 0
1022 @isWrapperFor@: we want to see exactly:
1024 /\ ... \ args -> case <arg> of ... -> case <arg> of ... -> wrkr <stuff>
1027 Probably a little too HACKY [WDP].
1030 isWrapperFor :: PlainCoreExpr -> Id -> Bool
1032 expr `isWrapperFor` var
1033 = case (digForLambdas expr) of { (_, args, body) -> -- lambdas off the front
1034 unravel_casing args body
1035 --NO, THANKS: && not (null args)
1038 var's_worker = getWorkerId (getIdStrictness var)
1040 is_elem = isIn "isWrapperFor"
1043 unravel_casing case_ables (CoCase scrut alts)
1044 = case (collectArgs scrut) of { (fun, args) ->
1046 CoVar scrut_var -> let
1048 scrut_var /= var && all (doesn't_mention var) args
1049 && scrut_var `is_elem` case_ables
1050 && unravel_alts case_ables alts
1057 unravel_casing case_ables other_expr
1058 = case (collectArgs other_expr) of { (fun, args) ->
1062 -- DOESN'T WORK: wrkr == var's_worker
1065 && all (doesn't_mention var) args
1066 && all (only_from case_ables) args
1074 unravel_alts case_ables (CoAlgAlts [(_,params,rhs)] CoNoDefault)
1075 = unravel_casing (params ++ case_ables) rhs
1076 unravel_alts case_ables other = False
1078 -------------------------
1079 doesn't_mention var (ValArg (CoVarAtom v)) = v /= var
1080 doesn't_mention var other = True
1082 -------------------------
1083 only_from case_ables (ValArg (CoVarAtom v)) = v `is_elem` case_ables
1084 only_from case_ables other = True
1087 All the following functions operate on binders, perform a uniform
1088 transformation on them; ie. the function @(\ x -> (x,False))@
1089 annotates all binders with False.
1092 unTagBinders :: CoreExpr (Id,tag) bdee -> CoreExpr Id bdee
1093 unTagBinders e = bop_expr fst e
1095 unTagBindersAlts :: CoreCaseAlternatives (Id,tag) bdee -> CoreCaseAlternatives Id bdee
1096 unTagBindersAlts alts = bop_alts fst alts
1100 bop_expr :: (a -> b) -> (CoreExpr a c) -> CoreExpr b c
1102 bop_expr f (CoVar b) = CoVar b
1103 bop_expr f (CoLit lit) = CoLit lit
1104 bop_expr f (CoCon id u atoms) = CoCon id u atoms
1105 bop_expr f (CoPrim op tys atoms)= CoPrim op tys atoms
1106 bop_expr f (CoLam binders expr) = CoLam [ f x | x <- binders ] (bop_expr f expr)
1107 bop_expr f (CoTyLam ty expr) = CoTyLam ty (bop_expr f expr)
1108 bop_expr f (CoApp expr atom) = CoApp (bop_expr f expr) atom
1109 bop_expr f (CoTyApp expr ty) = CoTyApp (bop_expr f expr) ty
1110 bop_expr f (CoSCC label expr) = CoSCC label (bop_expr f expr)
1111 bop_expr f (CoLet bind expr) = CoLet (bop_bind f bind) (bop_expr f expr)
1112 bop_expr f (CoCase expr alts)
1113 = CoCase (bop_expr f expr) (bop_alts f alts)
1115 bop_bind f (CoNonRec b e) = CoNonRec (f b) (bop_expr f e)
1116 bop_bind f (CoRec pairs) = CoRec [(f b, bop_expr f e) | (b, e) <- pairs]
1118 bop_alts f (CoAlgAlts alts deflt)
1119 = CoAlgAlts [ (con, [f b | b <- binders], bop_expr f e)
1120 | (con, binders, e) <- alts ]
1123 bop_alts f (CoPrimAlts alts deflt)
1124 = CoPrimAlts [ (lit, bop_expr f e) | (lit, e) <- alts ]
1127 bop_deflt f (CoNoDefault) = CoNoDefault
1128 bop_deflt f (CoBindDefault b expr) = CoBindDefault (f b) (bop_expr f expr)
1131 bop_expr f (CoZfExpr expr quals)
1132 = CoZfExpr (bop_expr f expr) (bop_quals quals)
1134 bop_quals (CoAndQuals l r) = CoAndQuals (bop_quals l) (bop_quals r)
1135 bop_quals (CoParFilter e) = CoParFilter (bop_expr f e)
1136 bop_quals (CoDrawnGen bs b e) = CoDrawnGen (map f bs) (f b) (bop_expr f e)
1137 bop_quals (CoIndexGen es b e) = CoIndexGen (map (bop_expr f) es) (f b)
1140 bop_expr f (CoParCon con ctxt tys args)
1141 = CoParCon con ctxt tys (map (bop_expr f) args)
1143 bop_expr f (CoParComm ctxt e comm)
1144 = CoParComm ctxt (bop_expr f e) (bop_comm comm)
1146 bop_comm (CoParSend es) = CoParSend (map (bop_expr f) es)
1147 bop_comm (CoParFetch es) = CoParFetch (map (bop_expr f) es)
1148 bop_comm (CoToPodized) = CoToPodized
1149 bop_comm (CoFromPodized) = CoFromPodized
1153 OLD (but left here because of the nice example): @singleAlt@ checks
1154 whether a bunch of case alternatives is actually just one alternative.
1155 It specifically {\em ignores} alternatives which consist of just a
1156 call to @error@, because they won't result in any code duplication.
1160 case (case <something> of
1162 False -> error "Foo") of
1168 True -> case <rhs> of
1170 False -> case error "Foo" of
1176 True -> case <rhs> of
1178 False -> error "Foo"
1180 Notice that the \tr{<alts>} don't get duplicated.
1184 boilsDownToConApp :: CoreExpr bndr bdee -> Bool -- Looks through lets
1185 -- ToDo: could add something for NoRep literals...
1187 boilsDownToConApp (CoCon _ _ _) = True
1188 boilsDownToConApp (CoTyLam _ e) = boilsDownToConApp e
1189 boilsDownToConApp (CoTyApp e _) = boilsDownToConApp e
1190 boilsDownToConApp (CoLet _ e) = boilsDownToConApp e
1191 boilsDownToConApp other = False
1196 nonErrorRHSs :: CoreCaseAlternatives binder Id -> [CoreExpr binder Id]
1198 nonErrorRHSs alts = filter not_error_app (find_rhss alts)
1200 find_rhss (CoAlgAlts alts deflt) = [rhs | (_,_,rhs) <- alts] ++ deflt_rhs deflt
1201 find_rhss (CoPrimAlts alts deflt) = [rhs | (_,rhs) <- alts] ++ deflt_rhs deflt
1203 deflt_rhs CoNoDefault = []
1204 deflt_rhs (CoBindDefault _ rhs) = [rhs]
1206 not_error_app rhs = case maybeErrorApp rhs Nothing of
1211 maybeErrorApp checkes whether an expression is of the form
1217 Just (error ty' args)
1219 where ty' is supplied as an argument to maybeErrorApp.
1221 Here's where it is useful:
1223 case (error ty "Foo" e1 e2) of <alts>
1227 where ty' is the type of any of the alternatives.
1228 You might think this never occurs, but see the comments on
1229 the definition of @singleAlt@.
1231 Note: we *avoid* the case where ty' might end up as a
1232 primitive type: this is very uncool (totally wrong).
1234 NOTICE: in the example above we threw away e1 and e2, but
1235 not the string "Foo". How did we know to do that?
1237 Answer: for now anyway, we only handle the case of a function
1238 whose type is of form
1240 bottomingFn :: forall a. t1 -> ... -> tn -> a
1241 ^---------------------^ NB!
1243 Furthermore, we only count a bottomingApp if the function is
1244 applied to more than n args. If so, we transform:
1246 bottomingFn ty e1 ... en en+1 ... em
1248 bottomingFn ty' e1 ... en
1250 That is, we discard en+1 .. em
1253 maybeErrorApp :: CoreExpr bndr Id -- Expr to look at
1254 -> Maybe UniType -- Just ty => a result type *already cloned*;
1255 -- Nothing => don't know result ty; we
1256 -- *pretend* that the result ty won't be
1257 -- primitive -- somebody later must
1259 -> Maybe (CoreExpr bndr Id)
1261 maybeErrorApp expr result_ty_maybe
1262 = case collectArgs expr of
1263 (CoVar fun, (TypeArg ty : other_args))
1265 && maybeToBool result_ty_maybe -- we *know* the result type
1266 -- (otherwise: live a fairy-tale existence...)
1267 && not (isPrimType result_ty) ->
1268 case splitType (getIdUniType fun) of
1269 ([tyvar_tmpl], [], tau_ty) ->
1270 case (splitTyArgs tau_ty) of { (arg_tys, res_ty) ->
1272 n_args_to_keep = length arg_tys
1273 args_to_keep = take n_args_to_keep other_args
1275 if res_ty == mkTyVarTemplateTy tyvar_tmpl &&
1276 n_args_to_keep <= length other_args
1278 -- Phew! We're in business
1279 Just (applyToArgs (CoVar fun)
1280 (TypeArg result_ty : args_to_keep))
1285 other -> -- Function type wrong shape
1289 Just result_ty = result_ty_maybe
1293 squashableDictishCcExpr :: CostCentre -> CoreExpr a b -> Bool
1295 squashableDictishCcExpr cc expr
1296 = if not (isDictCC cc) then
1297 False -- that was easy...
1299 squashable expr -- note: quite like the "atomic_rhs" stuff in simplifier
1301 squashable (CoVar _) = True
1302 squashable (CoTyApp f _) = squashable f
1303 squashable (CoCon _ _ _) = True -- I think so... WDP 94/09
1304 squashable (CoPrim _ _ _) = True -- ditto
1305 squashable other = False