mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
-- Taking expressions apart
- findDefault, findAlt, isDefaultAlt,
+ findDefault, findAlt, isDefaultAlt, mergeAlts,
-- Properties of expressions
exprType, coreAltType,
mkNote InlineMe expr = mkInlineMe expr
mkNote note expr = Note note expr
#endif
-
--- Slide InlineCall in around the function
--- No longer necessary I think (SLPJ Apr 99)
--- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
--- mkNote InlineCall (Var v) = Note InlineCall (Var v)
--- mkNote InlineCall expr = expr
\end{code}
Drop trivial InlineMe's. This is somewhat important, because if we have an unfolding
isDefaultAlt :: CoreAlt -> Bool
isDefaultAlt (DEFAULT, _, _) = True
isDefaultAlt other = False
+
+---------------------------------
+mergeAlts :: [CoreAlt] -> [CoreAlt] -> [CoreAlt]
+-- Merge preserving order; alternatives in the first arg
+-- shadow ones in the second
+mergeAlts [] as2 = as2
+mergeAlts as1 [] = as1
+mergeAlts (a1:as1) (a2:as2)
+ = case a1 `cmpAlt` a2 of
+ LT -> a1 : mergeAlts as1 (a2:as2)
+ EQ -> a1 : mergeAlts as1 as2 -- Discard a2
+ GT -> a2 : mergeAlts (a1:as1) as2
\end{code}
-- False -> \(s:RealWorld) -> e
-- where foo has arity 1. Then we want the state hack to
-- apply to foo too, so we can eta expand the case.
- mk 0 tys | isBottomingId v = ABot
- | otherwise = ATop
+ mk 0 tys | isBottomingId v = ABot
+ | (ty:tys) <- tys, isStateHackType ty = AFun True ATop
+ | otherwise = ATop
mk n (ty:tys) = AFun (isStateHackType ty) (mk (n-1) tys)
mk n [] = AFun False (mk (n-1) [])
-- f x y = case x of { (a,b) -> e }
-- The difference is observable using 'seq'
arityType (Case scrut _ _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
- xs@(AFun one_shot _) | one_shot -> xs
- xs | exprIsCheap scrut -> xs
- | otherwise -> ATop
+ xs | exprIsCheap scrut -> xs
+ xs@(AFun one_shot _) | one_shot -> AFun True ATop
+ other -> ATop
arityType (Let b e) = case arityType e of
- xs@(AFun one_shot _) | one_shot -> xs
xs | all exprIsCheap (rhssOfBind b) -> xs
- | otherwise -> ATop
+ xs@(AFun one_shot _) | one_shot -> AFun True ATop
+ other -> ATop
arityType other = ATop
eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
eq_note env (Coerce t1 f1) (Coerce t2 f2) = tcEqTypeX env t1 t2 && tcEqTypeX env f1 f2
-eq_note env InlineCall InlineCall = True
eq_note env (CoreNote s1) (CoreNote s2) = s1 == s2
eq_note env other1 other2 = False
\end{code}
noteSize (SCC cc) = cc `seq` 1
noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
-noteSize InlineCall = 1
noteSize InlineMe = 1
noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations