Ticket #5075: 5075.dpatch

File 5075.dpatch, 35.4 KB (added by batterseapower, 2 years ago)
Line 
11 patch for repository darcs.haskell.org:/srv/darcs/ghc:
2
3Fri Apr  1 21:58:28 BST 2011  Max Bolingbroke <batterseapower@hotmail.com>
4  * Product-type CPR for the case where we only return one of the possible constructors
5
6New patches:
7
8[Product-type CPR for the case where we only return one of the possible constructors
9Max Bolingbroke <batterseapower@hotmail.com>**20110401205828
10 Ignore-this: 77ff296ac6efe2b4fc586c2518e61742
11] {
12hunk ./compiler/basicTypes/DataCon.lhs 38
13 
14         -- * Splitting product types
15        splitProductType_maybe, splitProductType, deepSplitProductType,
16-        deepSplitProductType_maybe
17+        deepSplitProductType_maybe,
18+       
19+        -- * Splitting types for CPR
20+        cprableDataConInstOrigArgTys_maybe
21     ) where
22 
23 #include "HsVersions.h"
24hunk ./compiler/basicTypes/DataCon.lhs 888
25                         head (tyConDataCons tycon)
26        _other -> Nothing
27 
28+cprableDataConInstOrigArgTys_maybe
29+        :: Type                      -- ^ Type of expression, t
30+        -> DataCon                   -- ^ Data constructor (dc :: \forall a1 .. am. t1 -> .. -> tn -> t') we found constructing thing of this type
31+        -> Maybe ([Type], [Type], Type, CoercionI) -- ^ Universal types (s1, ..., sm), argument types (t1[si/ai], ..., tn[si/ai]), raw type t'[si/ai] and overall coercion co :: (t'[si/ai] ~ t)
32+cprableDataConInstOrigArgTys_maybe ty dc
33+  = case splitTyConApp_maybe ty of
34+          Just (tycon, tycon_args)
35+           | Just (ty', co) <- instNewTyCon_maybe tycon tycon_args
36+           , not (isRecursiveTyCon tycon)
37+           , Just (tycon_args, arg_tys, raw_ty, rebuild_co) <- cprableDataConInstOrigArgTys_maybe ty' dc
38+           -> Just (tycon_args, arg_tys, raw_ty, rebuild_co `mkTransCoI` mkSymCoI co)
39+           
40+           -- We can't (yet) unbox existentials, and we don't *want* to unbox unboxed tuples, so this is OK:
41+           | isDataTyCon tycon && isVanillaDataCon dc
42+           -> Just (tycon_args, dataConInstArgTys dc tycon_args, ty, IdCo ty)
43+         
44+          _ -> Nothing
45+
46 -- | As 'splitProductType_maybe', but panics if the 'Type' is not a product type
47 splitProductType :: String -> Type -> (TyCon, [Type], DataCon, [Type])
48 splitProductType str ty
49hunk ./compiler/basicTypes/DataCon.lhs-boot 6
50 import Name( Name )
51 
52 data DataCon
53+
54+instance Eq DataCon
55+instance Show DataCon
56+
57 dataConName      :: DataCon -> Name
58 isVanillaDataCon :: DataCon -> Bool
59 \end{code}
60hunk ./compiler/basicTypes/Demand.lhs 23
61        StrictSig(..), mkStrictSig, topSig, botSig, cprSig,
62         isTopSig,
63        splitStrictSig, increaseStrictSigArity,
64-       pprIfaceStrictSig, appIsBottom, isBottomingSig, seqStrictSig,
65+       appIsBottom, isBottomingSig, seqStrictSig,
66      ) where
67 
68 #include "HsVersions.h"
69hunk ./compiler/basicTypes/Demand.lhs 28
70 
71+import {-# SOURCE #-} DataCon (DataCon)
72 import StaticFlags
73 import BasicTypes
74 import VarEnv
75hunk ./compiler/basicTypes/Demand.lhs 62
76   deriving( Eq )
77        -- Equality needed for fixpoints in DmdAnal
78 
79-data Demands = Poly Demand     -- Polymorphic case
80-            | Prod [Demand]    -- Product case
81+data Demands = Poly Demand             -- Polymorphic case
82+            | Prod DataCon [Demand]    -- "Product" case. Actually says that we demanded components of this *particular* DataCon
83             deriving( Eq )
84 
85 allTop :: Demands -> Bool
86hunk ./compiler/basicTypes/Demand.lhs 67
87-allTop (Poly d)  = isTop d
88-allTop (Prod ds) = all isTop ds
89+allTop (Poly d)    = isTop d
90+allTop (Prod _ ds) = all isTop ds
91 
92 isTop :: Demand -> Bool
93 isTop Top = True
94hunk ./compiler/basicTypes/Demand.lhs 79
95 isAbsent _   = False
96 
97 mapDmds :: (Demand -> Demand) -> Demands -> Demands
98-mapDmds f (Poly d)  = Poly (f d)
99-mapDmds f (Prod ds) = Prod (map f ds)
100+mapDmds f (Poly d)     = Poly (f d)
101+mapDmds f (Prod dc ds) = Prod dc (map f ds)
102 
103 zipWithDmds :: (Demand -> Demand -> Demand)
104            -> Demands -> Demands -> Demands
105hunk ./compiler/basicTypes/Demand.lhs 84
106-zipWithDmds f (Poly d1)  (Poly d2)  = Poly (d1 `f` d2)
107-zipWithDmds f (Prod ds1) (Poly d2)  = Prod [d1 `f` d2 | d1 <- ds1]
108-zipWithDmds f (Poly d1)  (Prod ds2) = Prod [d1 `f` d2 | d2 <- ds2]
109-zipWithDmds f (Prod ds1) (Prod ds2)
110-  | length ds1 == length ds2 = Prod (zipWithEqual "zipWithDmds" f ds1 ds2)
111+zipWithDmds f (Poly d1)  (Poly d2)      = Poly (d1 `f` d2)
112+zipWithDmds f (Prod dc1 ds1) (Poly d2)  = Prod dc1 [d1 `f` d2 | d1 <- ds1]
113+zipWithDmds f (Poly d1)  (Prod dc2 ds2) = Prod dc2 [d1 `f` d2 | d2 <- ds2]
114+zipWithDmds f (Prod dc1 ds1) (Prod dc2 ds2)
115+  | dc1 == dc2
116+  , length ds1 == length ds2 = Prod dc1 (zipWithEqual "zipWithDmds" f ds1 ds2)
117   | otherwise               = Poly topDmd
118        -- This really can happen with polymorphism
119        -- \f. case f x of (a,b) -> ...
120hunk ./compiler/basicTypes/Demand.lhs 118
121 seqDemand _          = ()
122 
123 seqDemands :: Demands -> ()
124-seqDemands (Poly d)  = seqDemand d
125-seqDemands (Prod ds) = seqDemandList ds
126+seqDemands (Poly d)     = seqDemand d
127+seqDemands (Prod dc ds) = dc `seq` seqDemandList ds
128 
129 seqDemandList :: [Demand] -> ()
130 seqDemandList [] = ()
131hunk ./compiler/basicTypes/Demand.lhs 142
132 
133 
134 instance Outputable Demands where
135-    ppr (Poly Abs) = empty
136-    ppr (Poly d)   = parens (ppr d <> char '*')
137-    ppr (Prod ds)  = parens (hcat (map ppr ds))
138+    ppr (Poly Abs)   = empty
139+    ppr (Poly d)     = parens (ppr d <> char '*')
140+    ppr (Prod _ ds)  = parens (hcat (map ppr ds))
141        -- At one time I printed U(AAA) as U, but that
142        -- confuses (Poly Abs) with (Prod AAA), and the
143        -- worker/wrapper generation differs slightly for these two
144hunk ./compiler/basicTypes/Demand.lhs 182
145 -- by making sure that everything uses TopRes instead of RetCPR
146 -- Assuming, of course, that they don't mention RetCPR by name.
147 -- They should onlyu use retCPR
148-retCPR :: DmdResult
149-retCPR | opt_CprOff = TopRes
150-       | otherwise  = RetCPR
151+retCPR :: Maybe DataCon -> DmdResult
152+retCPR dc | opt_CprOff = TopRes
153+          | otherwise  = RetCPR dc
154 
155 seqDmdType :: DmdType -> ()
156 seqDmdType (DmdType _env ds res) =
157hunk ./compiler/basicTypes/Demand.lhs 192
158 
159 type DmdEnv = VarEnv Demand
160 
161-data DmdResult = TopRes        -- Nothing known       
162-              | RetCPR -- Returns a constructed product
163-              | BotRes -- Diverges or errors
164+data DmdResult = TopRes                        -- Nothing known       
165+              | RetCPR (Maybe DataCon)
166+               -- Returns constructed data. The field is:
167+               --  1. Nothing if we are in the first iteration of DmdAnal
168+               --     where we assume the CPR property before actually looking
169+               --     at the RHS
170+               --  2. Just dc if we have found that we have the CPR property
171+               --     and return the dc datacon. Because we record the actual
172+               --     datacon that we construct, we can actually optimise
173+               --     sum-types as well, as long as the function only returns
174+               --     *one* of the possible constructors
175+              | BotRes                 -- Diverges or errors
176               deriving( Eq, Show )
177        -- Equality for fixpoints
178        -- Show needed for Show in Lex.Token (sigh)
179hunk ./compiler/basicTypes/Demand.lhs 225
180       fv_elts = ufmToList fv
181 
182 instance Outputable DmdResult where
183-  ppr TopRes = empty     -- Keep these distinct from Demand letters
184-  ppr RetCPR = char 'm'          -- so that we can print strictness sigs as
185-  ppr BotRes = char 'b'   --    dddr
186+  ppr TopRes     = empty         -- Keep these distinct from Demand letters
187+  ppr (RetCPR _) = char 'm'      -- so that we can print strictness sigs as
188+  ppr BotRes     = char 'b'   --    dddr
189                          -- without ambiguity
190 
191 emptyDmdEnv :: VarEnv Demand
192hunk ./compiler/basicTypes/Demand.lhs 233
193 emptyDmdEnv = emptyVarEnv
194 
195-topDmdType, botDmdType, cprDmdType :: DmdType
196+topDmdType, botDmdType :: DmdType
197+cprDmdType :: Maybe DataCon -> DmdType
198 topDmdType = DmdType emptyDmdEnv [] TopRes
199 botDmdType = DmdType emptyDmdEnv [] BotRes
200hunk ./compiler/basicTypes/Demand.lhs 237
201-cprDmdType = DmdType emptyVarEnv [] retCPR
202+cprDmdType dc = DmdType emptyVarEnv [] (retCPR dc)
203 
204 isTopDmdType :: DmdType -> Bool
205 -- Only used on top-level types, hence the assert
206hunk ./compiler/basicTypes/Demand.lhs 256
207 -- We can get a RetCPR, because of the way in which we are (now)
208 -- giving CPR info to strict arguments.  On the first pass, when
209 -- nothing has demand info, we optimistically give CPR info or RetCPR to all args
210-resTypeArgDmd TopRes = Top
211-resTypeArgDmd RetCPR = Top
212-resTypeArgDmd BotRes = Bot
213+resTypeArgDmd TopRes     = Top
214+resTypeArgDmd (RetCPR _) = Top
215+resTypeArgDmd BotRes     = Bot
216 
217 returnsCPR :: DmdResult -> Bool
218hunk ./compiler/basicTypes/Demand.lhs 261
219-returnsCPR RetCPR = True
220-returnsCPR _      = False
221+returnsCPR (RetCPR _) = True
222+returnsCPR _          = False
223 
224 mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType
225 mkDmdType fv ds res = DmdType fv ds res
226hunk ./compiler/basicTypes/Demand.lhs 330
227 isTopSig :: StrictSig -> Bool
228 isTopSig (StrictSig ty) = isTopDmdType ty
229 
230-topSig, botSig, cprSig :: StrictSig
231+topSig, botSig :: StrictSig
232+cprSig :: Maybe DataCon -> StrictSig
233 topSig = StrictSig topDmdType
234 botSig = StrictSig botDmdType
235hunk ./compiler/basicTypes/Demand.lhs 334
236-cprSig = StrictSig cprDmdType
237+cprSig dc = StrictSig (cprDmdType dc)
238       
239 
240 -- appIsBottom returns true if an application to n args would diverge
241hunk ./compiler/basicTypes/Demand.lhs 348
242 
243 seqStrictSig :: StrictSig -> ()
244 seqStrictSig (StrictSig ty) = seqDmdType ty
245-
246-pprIfaceStrictSig :: StrictSig -> SDoc
247--- Used for printing top-level strictness pragmas in interface files
248-pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
249-  = hcat (map ppr dmds) <> ppr res
250 \end{code}
251     
252 
253hunk ./compiler/basicTypes/MkId.lhs 261
254         -- but that's fine... dataConRepStrictness comes from the data con
255         -- not from the worker Id.
256 
257-    cpr_info | isProductTyCon tycon &&
258-               isDataTyCon tycon    &&
259+    cpr_info | isDataTyCon tycon    &&
260                wkr_arity > 0        &&
261hunk ./compiler/basicTypes/MkId.lhs 263
262-               wkr_arity <= mAX_CPR_SIZE        = retCPR
263+               wkr_arity <= mAX_CPR_SIZE        = retCPR (Just data_con)
264              | otherwise                        = TopRes
265         -- RetCPR is only true for products that are real data types;
266         -- that is, not unboxed tuples or [non-recursive] newtypes
267hunk ./compiler/basicTypes/MkId.lhs 468
268         -- even if the selector isn't inlined
269     strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] TopRes)
270     arg_dmd | new_tycon = evalDmd
271-            | otherwise = Eval (Prod [ if the_arg_id == id then evalDmd else Abs
272-                                     | id <- arg_ids ])
273+            | otherwise = Eval (Prod data_con [ if the_arg_id == id then evalDmd else Abs
274+                                              | id <- arg_ids ])
275 
276     tycon                 = classTyCon clas
277     new_tycon             = isNewTyCon tycon
278hunk ./compiler/basicTypes/MkId.lhs 544
279     rhs = body i'' con_args
280 
281 mkUnpackCase ::  Id -> CoreExpr -> [Id] -> DataCon -> CoreExpr -> CoreExpr
282--- (mkUnpackCase x e args Con body)
283+-- (mkUnpackCase bndr e args Con body)
284 --      returns
285 -- case (e `cast` ...) of bndr { Con args -> body }
286 --
287hunk ./compiler/iface/BinIface.hs 20
288 import IfaceEnv
289 import HscTypes
290 import BasicTypes
291-import Demand
292 import Annotations
293 import CoreSyn
294 import IfaceSyn
295hunk ./compiler/iface/BinIface.hs 25
296 import Module
297 import Name
298-import VarEnv
299 import DynFlags
300 import UniqFM
301 import UniqSupply
302hunk ./compiler/iface/BinIface.hs 710
303 --             Types from: Demand
304 -------------------------------------------------------------------------
305 
306-instance Binary DmdType where
307-       -- Ignore DmdEnv when spitting out the DmdType
308-  put bh (DmdType _ ds dr) = do p <- put bh ds; put_ bh dr; return (castBin p)
309-  get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
310 
311hunk ./compiler/iface/BinIface.hs 711
312-instance Binary Demand where
313-    put_ bh Top = do
314+ -- We ignore the DmdEnv from the original DmdType when spitting out the IfaceDmdType
315+instance Binary IfaceDmdType where
316+  put bh (IfDmdType ds dr) = do p <- put bh ds; put_ bh dr; return (castBin p)
317+  get bh = do ds <- get bh; dr <- get bh; return (IfDmdType ds dr)
318+
319+instance Binary IfaceDemand where
320+    put_ bh IfaceTop = do
321            putByte bh 0
322hunk ./compiler/iface/BinIface.hs 719
323-    put_ bh Abs = do
324+    put_ bh IfaceAbs = do
325            putByte bh 1
326hunk ./compiler/iface/BinIface.hs 721
327-    put_ bh (Call aa) = do
328+    put_ bh (IfaceCall aa) = do
329            putByte bh 2
330            put_ bh aa
331hunk ./compiler/iface/BinIface.hs 724
332-    put_ bh (Eval ab) = do
333+    put_ bh (IfaceEval ab) = do
334            putByte bh 3
335            put_ bh ab
336hunk ./compiler/iface/BinIface.hs 727
337-    put_ bh (Defer ac) = do
338+    put_ bh (IfaceDefer ac) = do
339            putByte bh 4
340            put_ bh ac
341hunk ./compiler/iface/BinIface.hs 730
342-    put_ bh (Box ad) = do
343+    put_ bh (IfaceBox ad) = do
344            putByte bh 5
345            put_ bh ad
346hunk ./compiler/iface/BinIface.hs 733
347-    put_ bh Bot = do
348+    put_ bh IfaceBot = do
349            putByte bh 6
350     get bh = do
351            h <- getByte bh
352hunk ./compiler/iface/BinIface.hs 738
353            case h of
354-             0 -> do return Top
355-             1 -> do return Abs
356+             0 -> do return IfaceTop
357+             1 -> do return IfaceAbs
358              2 -> do aa <- get bh
359hunk ./compiler/iface/BinIface.hs 741
360-                     return (Call aa)
361+                     return (IfaceCall aa)
362              3 -> do ab <- get bh
363hunk ./compiler/iface/BinIface.hs 743
364-                     return (Eval ab)
365+                     return (IfaceEval ab)
366              4 -> do ac <- get bh
367hunk ./compiler/iface/BinIface.hs 745
368-                     return (Defer ac)
369+                     return (IfaceDefer ac)
370              5 -> do ad <- get bh
371hunk ./compiler/iface/BinIface.hs 747
372-                     return (Box ad)
373-             _ -> do return Bot
374+                     return (IfaceBox ad)
375+             _ -> do return IfaceBot
376 
377hunk ./compiler/iface/BinIface.hs 750
378-instance Binary Demands where
379-    put_ bh (Poly aa) = do
380+instance Binary IfaceDemands where
381+    put_ bh (IfacePoly aa) = do
382            putByte bh 0
383            put_ bh aa
384hunk ./compiler/iface/BinIface.hs 754
385-    put_ bh (Prod ab) = do
386+    put_ bh (IfaceProd dc ab) = do
387            putByte bh 1
388hunk ./compiler/iface/BinIface.hs 756
389+           put_ bh dc
390            put_ bh ab
391     get bh = do
392            h <- getByte bh
393hunk ./compiler/iface/BinIface.hs 762
394            case h of
395              0 -> do aa <- get bh
396-                     return (Poly aa)
397-             _ -> do ab <- get bh
398-                     return (Prod ab)
399+                     return (IfacePoly aa)
400+             _ -> do dc <- get bh
401+                     ab <- get bh
402+                     return (IfaceProd dc ab)
403 
404hunk ./compiler/iface/BinIface.hs 767
405-instance Binary DmdResult where
406-    put_ bh TopRes = do
407+instance Binary IfaceDmdResult where
408+    put_ bh IfaceTopRes = do
409            putByte bh 0
410hunk ./compiler/iface/BinIface.hs 770
411-    put_ bh RetCPR = do
412-           putByte bh 1
413-    put_ bh BotRes = do
414+    put_ bh (IfaceRetCPR dc) = do
415+            putByte bh 1
416+            put_ bh dc
417+    put_ bh IfaceBotRes = do
418            putByte bh 2
419     get bh = do
420            h <- getByte bh
421hunk ./compiler/iface/BinIface.hs 778
422            case h of
423-             0 -> do return TopRes
424-             1 -> do return RetCPR     -- Really use RetCPR even if -fcpr-off
425-                                       -- The wrapper was generated for CPR in
426-                                       -- the imported module!
427-             _ -> do return BotRes
428-
429-instance Binary StrictSig where
430-    put_ bh (StrictSig aa) = do
431-           put_ bh aa
432-    get bh = do
433-         aa <- get bh
434-         return (StrictSig aa)
435+             0 -> do return IfaceTopRes
436+             1 -> do fmap IfaceRetCPR (get bh) -- Really use RetCPR even if -fcpr-off
437+                                               -- The wrapper was generated for CPR in
438+                                               -- the imported module!
439+             _ -> do return IfaceBotRes
440 
441 
442 -------------------------------------------------------------------------
443hunk ./compiler/iface/IfaceSyn.lhs 14
444        IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..),
445        IfaceBinding(..), IfaceConAlt(..),
446        IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..),
447+       IfaceDmdType(..), IfaceDmdResult(..), IfaceDemands(..), IfaceDemand(..),
448        IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
449        IfaceInst(..), IfaceFamInst(..),
450 
451hunk ./compiler/iface/IfaceSyn.lhs 33
452 import IfaceType
453 import CoreSyn( DFunArg, dfunArgExprs )
454 import PprCore()            -- Printing DFunArgs
455-import Demand
456 import Annotations
457 import Class
458 import NameSet
459hunk ./compiler/iface/IfaceSyn.lhs 203
460 --   * The version comparsion sees that new (=NoInfo) differs from old (=HasInfo *)
461 --     and so gives a new version.
462 
463+data IfaceDemand
464+  = IfaceTop
465+  | IfaceAbs
466+  | IfaceCall IfaceDemand
467+  | IfaceEval IfaceDemands
468+  | IfaceDefer IfaceDemands
469+  | IfaceBox IfaceDemand
470+  | IfaceBot
471+
472+data IfaceDemands = IfacePoly IfaceDemand
473+                  | IfaceProd IfExtName [IfaceDemand]
474+
475+data IfaceDmdResult = IfaceTopRes | IfaceRetCPR IfExtName | IfaceBotRes
476+
477+data IfaceDmdType = IfDmdType [IfaceDemand] IfaceDmdResult
478+
479 data IfaceInfoItem
480   = HsArity     Arity
481hunk ./compiler/iface/IfaceSyn.lhs 221
482-  | HsStrictness StrictSig
483+  | HsStrictness IfaceDmdType
484   | HsInline     InlinePragma
485   | HsUnfold    Bool             -- True <=> isNonRuleLoopBreaker is true
486                 IfaceUnfolding   -- See Note [Expose recursive functions]
487hunk ./compiler/iface/IfaceSyn.lhs 706
488                            <> colon <+> ppr unf
489   ppr (HsInline prag)    = ptext (sLit "Inline:") <+> ppr prag
490   ppr (HsArity arity)    = ptext (sLit "Arity:") <+> int arity
491-  ppr (HsStrictness str) = ptext (sLit "Strictness:") <+> pprIfaceStrictSig str
492+  ppr (HsStrictness str) = ptext (sLit "Strictness:") <+> ppr str
493   ppr HsNoCafRefs       = ptext (sLit "HasNoCafRefs")
494 
495hunk ./compiler/iface/IfaceSyn.lhs 709
496+instance Outputable IfaceDemand where
497+  ppr IfaceTop  = char 'T'
498+  ppr IfaceAbs  = char 'A'
499+  ppr IfaceBot  = char 'B'
500+ 
501+  ppr (IfaceDefer ds) = char 'D' <> ppr ds
502+  ppr (IfaceEval ds)  = char 'U' <> ppr ds
503+ 
504+  ppr (IfaceBox (IfaceEval ds)) = char 'S' <> ppr ds
505+  ppr (IfaceBox IfaceAbs)       = char 'L'
506+  ppr (IfaceBox IfaceBot)       = char 'X'
507+  ppr d@(IfaceBox _)            = pprPanic "ppr: Bad boxed demand" (ppr d)
508+ 
509+  ppr (IfaceCall d) = char 'C' <> parens (ppr d)
510+
511+instance Outputable IfaceDemands where
512+  ppr (IfacePoly IfaceAbs) = empty
513+  ppr (IfacePoly d)        = parens (ppr d <> char '*')
514+  ppr (IfaceProd _ ds)     = parens (hcat (map ppr ds))
515+
516+instance Outputable IfaceDmdResult where
517+  ppr IfaceTopRes     = empty
518+  ppr (IfaceRetCPR _) = char 'm'
519+  ppr IfaceBotRes     = char 'b'
520+
521+instance Outputable IfaceDmdType where
522+  ppr (IfDmdType dmds res) = hcat (map ppr dmds) <> ppr res
523+
524 instance Outputable IfaceUnfolding where
525   ppr (IfCompulsory e)     = ptext (sLit "<compulsory>") <+> parens (ppr e)
526   ppr (IfCoreUnfold s e)   = (if s then ptext (sLit "<stable>") else empty) <+> parens (ppr e)
527hunk ./compiler/iface/IfaceSyn.lhs 862
528 freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i
529 
530 freeNamesItem :: IfaceInfoItem -> NameSet
531-freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u
532-freeNamesItem _              = emptyNameSet
533+freeNamesItem (HsStrictness s) = freeNamesIfDmdType s
534+freeNamesItem (HsUnfold _ u)   = freeNamesIfUnfold u
535+freeNamesItem _                = emptyNameSet
536+
537+freeNamesIfDemand :: IfaceDemand -> NameSet
538+freeNamesIfDemand (IfaceCall dmd) = freeNamesIfDemand dmd
539+freeNamesIfDemand (IfaceEval dmds) = freeNamesIfDemands dmds
540+freeNamesIfDemand (IfaceDefer dmds) = freeNamesIfDemands dmds
541+freeNamesIfDemand (IfaceBox dmd) = freeNamesIfDemand dmd
542+freeNamesIfDemand _ = emptyNameSet
543+
544+freeNamesIfDemands :: IfaceDemands -> NameSet
545+freeNamesIfDemands (IfacePoly dmd) = freeNamesIfDemand dmd
546+freeNamesIfDemands (IfaceProd n dmds) = unitNameSet n &&& fnList freeNamesIfDemand dmds
547+
548+freeNamesIfDmdResult :: IfaceDmdResult -> NameSet
549+freeNamesIfDmdResult (IfaceRetCPR n) = unitNameSet n
550+freeNamesIfDmdResult _               = emptyNameSet
551+
552+freeNamesIfDmdType :: IfaceDmdType -> NameSet
553+freeNamesIfDmdType (IfDmdType dmd_args dmd_res)
554+  = fnList freeNamesIfDemand dmd_args &&& freeNamesIfDmdResult dmd_res
555 
556 freeNamesIfUnfold :: IfaceUnfolding -> NameSet
557 freeNamesIfUnfold (IfCoreUnfold _ e)     = freeNamesIfExpr e
558hunk ./compiler/iface/MkIface.lhs 1503
559     ------------  Strictness  --------------
560        -- No point in explicitly exporting TopSig
561     strict_hsinfo = case strictnessInfo id_info of
562-                       Just sig | not (isTopSig sig) -> Just (HsStrictness sig)
563+                       Just sig | not (isTopSig sig) -> Just (HsStrictness (toIfaceStrictSig sig))
564                        _other                        -> Nothing
565 
566     ------------  Unfolding  --------------
567hunk ./compiler/iface/MkIface.lhs 1515
568     inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing
569                   | otherwise = Just (HsInline inline_prag)
570 
571+--------------------------
572+toIfaceStrictSig :: StrictSig -> IfaceDmdType
573+toIfaceStrictSig (StrictSig (DmdType _ args_dmd res_dmd)) = IfDmdType (map toIfaceDemand args_dmd) (toIfaceDmdResult res_dmd)
574+
575+toIfaceDmdResult :: DmdResult -> IfaceDmdResult
576+toIfaceDmdResult TopRes      = IfaceTopRes
577+toIfaceDmdResult (RetCPR dc) = IfaceRetCPR (getName (expectJust "toIfaceDmdResult" dc))
578+toIfaceDmdResult BotRes      = IfaceBotRes
579+
580+toIfaceDemand :: Demand -> IfaceDemand
581+toIfaceDemand Top          = IfaceTop
582+toIfaceDemand Abs          = IfaceAbs
583+toIfaceDemand (Call dmd)   = IfaceCall (toIfaceDemand dmd)
584+toIfaceDemand (Eval dmds)  = IfaceEval (toIfaceDemands dmds)
585+toIfaceDemand (Defer dmds) = IfaceDefer (toIfaceDemands dmds)
586+toIfaceDemand (Box dmd)    = IfaceBox (toIfaceDemand dmd)
587+toIfaceDemand Bot          = IfaceBot
588+
589+toIfaceDemands :: Demands -> IfaceDemands
590+toIfaceDemands (Poly dmd)     = IfacePoly (toIfaceDemand dmd)
591+toIfaceDemands (Prod dc dmds) = IfaceProd (getName dc) (map toIfaceDemand dmds)
592+
593 --------------------------
594 toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem
595 toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
596hunk ./compiler/iface/TcIface.lhs 49
597 import Name
598 import NameEnv
599 import OccurAnal       ( occurAnalyseExpr )
600-import Demand          ( isBottomingSig )
601+import Demand          ( StrictSig(..), DmdType(..), Demand(..), Demands(..), DmdResult(..), isBottomingSig )
602 import Module
603 import UniqFM
604 import UniqSupply
605hunk ./compiler/iface/TcIface.lhs 1012
606     tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
607     tcPrag info HsNoCafRefs        = return (info `setCafInfo`   NoCafRefs)
608     tcPrag info (HsArity arity)    = return (info `setArityInfo` arity)
609-    tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` Just str)
610+    tcPrag info (HsStrictness str) = fmap (\str -> info `setStrictnessInfo` Just str) $ tcStrictSig str
611     tcPrag info (HsInline prag)    = return (info `setInlinePragInfo` prag)
612 
613        -- The next two are lazy, so they don't transitively suck stuff in
614hunk ./compiler/iface/TcIface.lhs 1021
615           ; let info1 | lb        = info `setOccInfo` nonRuleLoopBreaker
616                       | otherwise = info
617           ; return (info1 `setUnfoldingInfoLazily` unf) }
618+
619+tcStrictSig :: IfaceDmdType -> IfL StrictSig
620+tcStrictSig (IfDmdType if_arg_dmds if_res_dmd)
621+  = liftM2 (\arg_dmds res_dmd -> StrictSig (DmdType emptyVarEnv arg_dmds res_dmd))
622+           (mapM tcDemand if_arg_dmds)
623+           (tcDmdResult if_res_dmd)
624+
625+tcDemand :: IfaceDemand -> IfL Demand
626+tcDemand IfaceTop = return Top
627+tcDemand IfaceAbs = return Abs
628+tcDemand (IfaceCall dmd) = fmap Call (tcDemand dmd)
629+tcDemand (IfaceEval dmds) = fmap Eval (tcDemands dmds)
630+tcDemand (IfaceDefer dmds) = fmap Defer (tcDemands dmds)
631+tcDemand (IfaceBox dmd) = fmap Box (tcDemand dmd)
632+tcDemand IfaceBot = return Bot
633+
634+tcDemands :: IfaceDemands -> IfL Demands
635+tcDemands (IfacePoly dmd) = fmap Poly (tcDemand dmd)
636+tcDemands (IfaceProd data_occ dmds) = liftM2 Prod (tcIfaceDataCon data_occ) (mapM tcDemand dmds)
637+
638+tcDmdResult :: IfaceDmdResult -> IfL DmdResult
639+tcDmdResult IfaceTopRes            = return TopRes
640+tcDmdResult (IfaceRetCPR data_occ) = fmap (RetCPR . Just) $ tcIfaceDataCon data_occ
641+tcDmdResult IfaceBotRes            = return BotRes
642 \end{code}
643 
644 \begin{code}
645hunk ./compiler/specialise/SpecConstr.lhs 1425
646 
647     go_one env d   (Var v) = extendVarEnv_C both env v d
648     go_one env (Box d)   e = go_one env d e
649-    go_one env (Eval (Prod ds)) e
650+    go_one env (Eval (Prod _dc ds)) e
651           | (Var _, args) <- collectArgs e = go env ds args
652     go_one env _         _ = env
653 
654hunk ./compiler/stranal/DmdAnal.lhs 24
655 import CoreUtils       ( exprIsHNF, exprIsTrivial )
656 import CoreArity       ( exprArity )
657 import DataCon         ( dataConTyCon, dataConRepStrictness )
658-import TyCon           ( isProductTyCon, isRecursiveTyCon )
659+import TyCon           ( isRecursiveTyCon )
660 import Id              ( Id, idType, idInlineActivation,
661                          isDataConWorkId, isGlobalId, idArity,
662                          idStrictness,
663hunk ./compiler/stranal/DmdAnal.lhs 210
664 
665 dmdAnal env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)])
666   | let tycon = dataConTyCon dc
667-  , isProductTyCon tycon
668   , not (isRecursiveTyCon tycon)
669   = let
670        env_alt       = extendAnalEnv NotTopLevel env case_bndr case_bndr_sig
671hunk ./compiler/stranal/DmdAnal.lhs 216
672        (alt_ty, alt')        = dmdAnalAlt env_alt dmd alt
673        (alt_ty1, case_bndr') = annotateBndr alt_ty case_bndr
674        (_, bndrs', _)        = alt'
675-       case_bndr_sig         = cprSig
676+       case_bndr_sig         = cprSig (Just dc)
677                -- Inside the alternative, the case binder has the CPR property.
678                -- Meaning that a case on it will successfully cancel.
679                -- Example:
680hunk ./compiler/stranal/DmdAnal.lhs 247
681        -- The insight is, of course, that a demand on y is a demand on the
682        -- scrutinee, so we need to `both` it with the scrut demand
683 
684-       alt_dmd            = Eval (Prod [idDemandInfo b | b <- bndrs', isId b])
685+       alt_dmd            = Eval (Prod dc [idDemandInfo b | b <- bndrs', isId b])
686         scrut_dmd         = alt_dmd `both`
687                             idDemandInfo case_bndr'
688 
689hunk ./compiler/stranal/DmdAnal.lhs 421
690                -- If so we must make up a suitable bunch of demands
691           arg_ds = case dmd_ds of
692                      Poly d  -> replicate arity d
693-                     Prod ds -> ASSERT( ds `lengthIs` arity ) ds
694+                     Prod _ ds -> ASSERT( ds `lengthIs` arity ) ds
695 
696        in
697        mkDmdType emptyDmdEnv arg_ds con_res
698hunk ./compiler/stranal/DmdAnal.lhs 749
699        -- Set the unpacking strategy
700       
701     res' = case res of
702-               RetCPR | ignore_cpr_info -> TopRes
703-               _                        -> res
704+               RetCPR _ | ignore_cpr_info -> TopRes
705+               _                          -> res
706     ignore_cpr_info = not (exprIsHNF rhs || thunk_cpr_ok)
707 \end{code}
708 
709hunk ./compiler/stranal/DmdAnal.lhs 767
710        -> [Demand]
711        -> (Int, [Demand])      -- Args remaining after subcomponents of [Demand] are unpacked
712 
713-    go n (Eval (Prod cs) : ds)
714-       | n' >= 0   = Eval (Prod cs') `cons` go n'' ds
715-        | otherwise = Box (Eval (Prod cs)) `cons` go n ds
716+    go n (Eval (Prod dc cs) : ds)
717+       | n' >= 0   = Eval (Prod dc cs') `cons` go n'' ds
718+        | otherwise = Box (Eval (Prod dc cs)) `cons` go n ds
719        where
720          (n'',cs') = go n' cs
721          n' = n + 1 - non_abs_args
722hunk ./compiler/stranal/DmdAnal.lhs 982
723 
724 extendSigsWithLam env id
725   = case idDemandInfo_maybe id of
726-       Nothing              -> extendAnalEnv NotTopLevel env id cprSig
727+       Nothing              -> extendAnalEnv NotTopLevel env id (cprSig Nothing)
728                -- Optimistic in the Nothing case;
729                -- See notes [CPR-AND-STRICTNESS]
730hunk ./compiler/stranal/DmdAnal.lhs 985
731-       Just (Eval (Prod _)) -> extendAnalEnv NotTopLevel env id cprSig
732-       _                    -> env
733+       Just (Eval (Prod dc _)) -> extendAnalEnv NotTopLevel env id (cprSig (Just dc))
734+       _                       -> env
735 \end{code}
736 
737 Note [Initialising strictness]
738hunk ./compiler/stranal/DmdAnal.lhs 1095
739 
740 \begin{code}
741 lubRes :: DmdResult -> DmdResult -> DmdResult
742-lubRes BotRes r      = r
743-lubRes r      BotRes = r
744-lubRes RetCPR RetCPR = RetCPR
745-lubRes _      _      = TopRes
746+lubRes BotRes              r                   = r
747+lubRes r                   BotRes              = r
748+lubRes (RetCPR Nothing)    (RetCPR Nothing)    = RetCPR Nothing
749+lubRes (RetCPR (Just dc1)) (RetCPR Nothing)    = RetCPR (Just dc1)
750+lubRes (RetCPR Nothing)    (RetCPR (Just dc2)) = RetCPR (Just dc2)
751+lubRes (RetCPR (Just dc1)) (RetCPR (Just dc2)) | dc1 == dc2 = RetCPR (Just dc1)
752+lubRes _                   _                   = TopRes
753 
754 bothRes :: DmdResult -> DmdResult -> DmdResult
755 -- If either diverges, the whole thing does
756hunk ./compiler/stranal/WorkWrap.lhs 456
757        -- and hence do_strict_ww is False if arity is zero and there is no CPR
758   -- See Note [Worker-wrapper for bottoming functions]
759   where
760-    worth_it Abs             = True    -- Absent arg
761-    worth_it (Eval (Prod _)) = True    -- Product arg to evaluate
762-    worth_it _               = False
763+    worth_it Abs               = True  -- Absent arg
764+    worth_it (Eval (Prod _ _)) = True  -- Product arg to evaluate
765+    worth_it _                 = False
766 
767 worthSplittingThunk :: Maybe Demand    -- Demand on the thunk
768                    -> DmdResult        -- CPR info for the thunk
769hunk ./compiler/stranal/WorkWrap.lhs 467
770   = worth_it maybe_dmd || returnsCPR res
771   where
772        -- Split if the thing is unpacked
773-    worth_it (Just (Eval (Prod ds))) = not (all isAbsent ds)
774-    worth_it _                      = False
775+    worth_it (Just (Eval (Prod _ ds))) = not (all isAbsent ds)
776+    worth_it _                        = False
777 \end{code}
778 
779 Note [Worker-wrapper for bottoming functions]
780hunk ./compiler/stranal/WwLib.lhs 12
781 #include "HsVersions.h"
782 
783 import CoreSyn
784-import CoreUtils       ( exprType )
785+import CoreUtils       ( exprType, mkCoerceI )
786 import Id              ( Id, idType, mkSysLocal, idDemandInfo, setIdDemandInfo,
787                          isOneShotLambda, setOneShotLambda, setIdUnfolding,
788hunk ./compiler/stranal/WwLib.lhs 15
789-                          setIdInfo
790+                          setIdInfo, setIdType
791                        )
792 import IdInfo          ( vanillaIdInfo )
793 import DataCon
794hunk ./compiler/stranal/WwLib.lhs 21
795 import Demand          ( Demand(..), DmdResult(..), Demands(..) )
796 import MkCore          ( mkRuntimeErrorApp, aBSENT_ERROR_ID )
797-import MkId            ( realWorldPrimId, voidArgId,
798-                          mkUnpackCase, mkProductBox )
799+import MkId            ( realWorldPrimId, voidArgId )
800 import TysPrim         ( realWorldStatePrimTy )
801 import TysWiredIn      ( tupleCon )
802 import Type
803hunk ./compiler/stranal/WwLib.lhs 25
804-import Coercion         ( mkSymCoercion, splitNewTypeRepCo_maybe )
805+import Coercion         ( CoercionI, mkSymCoI, mkSymCoercion, splitNewTypeRepCo_maybe )
806 import BasicTypes      ( Boxity(..) )
807 import Literal         ( absentLiteralOf )
808 import Var              ( Var )
809hunk ./compiler/stranal/WwLib.lhs 354
810           -> return ([], nop_fn, work_fn)
811 
812        -- Unpack case
813-      Eval (Prod cs)
814-       | Just (_arg_tycon, _tycon_arg_tys, data_con, inst_con_arg_tys)
815-               <- deepSplitProductType_maybe (idType arg)
816+      Eval (Prod data_con cs)
817+       | Just (tycon_args, inst_con_arg_tys, raw_data_ty, co) <- cprableDataConInstOrigArgTys_maybe (idType arg) data_con
818        -> do uniqs <- getUniquesM
819              let
820                unpk_args      = zipWith mk_ww_local uniqs inst_con_arg_tys
821hunk ./compiler/stranal/WwLib.lhs 360
822                unpk_args_w_ds = zipWithEqual "mkWWstr" set_worker_arg_info unpk_args cs
823-               unbox_fn       = mkUnpackCase (sanitiseCaseBndr arg) (Var arg) unpk_args data_con
824+               unbox_fn       = mkUnpackCase (sanitiseCaseBndr arg) (Var arg) raw_data_ty co unpk_args data_con
825                rebox_fn       = Let (NonRec arg con_app)
826hunk ./compiler/stranal/WwLib.lhs 362
827-               con_app        = mkProductBox unpk_args (idType arg)
828+               con_app        = mkCoerceI co (mkConApp data_con (map Type tycon_args ++ map Var unpk_args))
829              (worker_args, wrap_fn, work_fn) <- mkWWstr unpk_args_w_ds
830              return (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn)
831                           -- Don't pass the arg, rebox instead
832hunk ./compiler/stranal/WwLib.lhs 430
833                    CoreExpr -> CoreExpr,            -- New worker
834                   Type)                        -- Type of worker's body
835 
836-mkWWcpr body_ty RetCPR
837-    | not (isClosedAlgType body_ty)
838-    = WARN( True,
839+mkWWcpr body_ty (RetCPR mb_data_con)
840+  -- The DataCon should only be Nothing temporarily during the DmdAnal fixed point
841+  = let Just data_con = mb_data_con in case cprableDataConInstOrigArgTys_maybe body_ty data_con of
842+      -- Un-CPRable types can creep in. For example, existential packages are products
843+      -- and so we often get to this stage, but we can't CPR them. We just give up in that case:
844+    Nothing ->
845+      WARN( True,
846             text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )
847       return (id, id, body_ty)
848 
849hunk ./compiler/stranal/WwLib.lhs 440
850-    | n_con_args == 1 && isUnLiftedType con_arg_ty1 = do
851+    Just (tycon_args, con_arg_tys, raw_data_ty, co)
852+     | [con_arg_ty1] <- con_arg_tys, isUnLiftedType con_arg_ty1 -> do
853        -- Special case when there is a single result of unlifted type
854        --
855        -- Wrapper:     case (..call worker..) of x -> C x
856hunk ./compiler/stranal/WwLib.lhs 450
857       let
858        work_wild = mk_ww_local work_uniq body_ty
859        arg       = mk_ww_local arg_uniq  con_arg_ty1
860-       con_app   = mkProductBox [arg] body_ty
861+       con_app   = mkCoerceI co (mkConApp data_con $ map Type tycon_args ++ [Var arg])
862 
863       return (\ wkr_call -> Case wkr_call (arg) (exprType con_app) [(DEFAULT, [], con_app)],
864hunk ./compiler/stranal/WwLib.lhs 453
865-               \ body     -> workerCase (work_wild) body [arg] data_con (Var arg),
866+               \ body     -> workerCase work_wild body raw_data_ty co [arg] data_con (Var arg),
867                con_arg_ty1)
868 
869hunk ./compiler/stranal/WwLib.lhs 456
870-    | otherwise = do   -- The general case
871+     | otherwise -> do -- The general case
872        -- Wrapper: case (..call worker..) of (# a, b #) -> C a b
873        -- Worker:  case (   ...body...  ) of C a b -> (# a, b #)     
874       uniqs <- getUniquesM
875hunk ./compiler/stranal/WwLib.lhs 463
876       let
877         (wrap_wild : work_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : body_ty : con_arg_tys)
878        arg_vars                       = map Var args
879-       ubx_tup_con                    = tupleCon Unboxed n_con_args
880+       ubx_tup_con                    = tupleCon Unboxed (length con_arg_tys)
881        ubx_tup_ty                     = exprType ubx_tup_app
882hunk ./compiler/stranal/WwLib.lhs 465
883-       ubx_tup_app                    = mkConApp ubx_tup_con (map Type con_arg_tys   ++ arg_vars)
884-        con_app                               = mkProductBox args body_ty
885+       ubx_tup_app                    =               mkConApp ubx_tup_con (map Type con_arg_tys ++ arg_vars)
886+        con_app                               = mkCoerceI co (mkConApp data_con    (map Type tycon_args  ++ map Var args))
887 
888       return (\ wkr_call -> Case wkr_call (wrap_wild) (exprType con_app)  [(DataAlt ubx_tup_con, args, con_app)],
889hunk ./compiler/stranal/WwLib.lhs 469
890-               \ body     -> workerCase (work_wild) body args data_con ubx_tup_app,
891+               \ body     -> workerCase work_wild body raw_data_ty co args data_con ubx_tup_app,
892                ubx_tup_ty)
893hunk ./compiler/stranal/WwLib.lhs 471
894-    where
895-      (_arg_tycon, _tycon_arg_tys, data_con, con_arg_tys) = deepSplitProductType "mkWWcpr" body_ty
896-      n_con_args  = length con_arg_tys
897-      con_arg_ty1 = head con_arg_tys
898 
899 mkWWcpr body_ty _other         -- No CPR info
900     = return (id, id, body_ty)
901hunk ./compiler/stranal/WwLib.lhs 485
902 --
903 -- This transform doesn't move work or allocation
904 -- from one cost centre to another
905-workerCase :: Id -> CoreExpr -> [Id] -> DataCon -> CoreExpr -> CoreExpr
906-workerCase bndr (Note (SCC cc) e) args con body = Note (SCC cc) (mkUnpackCase bndr e args con body)
907-workerCase bndr e args con body = mkUnpackCase bndr e args con body
908+workerCase :: Id -> CoreExpr -> Type -> CoercionI -> [Id] -> DataCon -> CoreExpr -> CoreExpr
909+workerCase bndr (Note (SCC cc) e) raw_arg_ty co args con body = Note (SCC cc) (mkUnpackCase bndr e raw_arg_ty co args con body)
910+workerCase bndr e raw_arg_ty co args con body = mkUnpackCase bndr e raw_arg_ty co args con body
911+
912+mkUnpackCase ::  Id -> CoreExpr -> Type -> CoercionI -> [Id] -> DataCon -> CoreExpr -> CoreExpr
913+-- (mkUnpackCase bndr e raw_e_ty co args Con body)
914+--      returns
915+-- case (e `cast` sym co) of (bndr :: raw_e_ty) { Con args -> body }
916+--
917+-- the type of the bndr passed in is irrelevent
918+mkUnpackCase bndr arg raw_arg_ty co unpk_args boxing_con body
919+  = Case (mkCoerceI (mkSymCoI co) arg) (setIdType bndr raw_arg_ty) (exprType body) [(DataAlt boxing_con, unpk_args, body)]
920 \end{code}
921 
922 
923}
924
925Context:
926
927[TAG git migration
928Ian Lynagh <igloo@earth.li>**20110331134846
929 Ignore-this: 5572f46dda57e62defcb124c3a80069a
930]
931Patch bundle hash:
932605803f2988502064228c37da9acb4034fa21d4c