[commit: ghc] master: Make the call to chooseBoxingStrategy lazy again (ba8fd08)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/ba8fd081ba9b222dd5f93604d7deeaca372e4511

>---------------------------------------------------------------

commit ba8fd081ba9b222dd5f93604d7deeaca372e4511
Author: Simon Peyton Jones <[email protected]>
Date:   Mon Sep 17 18:22:10 2012 +0100

    Make the call to chooseBoxingStrategy lazy again
    
    I made it strict, as an incidental consequence of this patch:
    
      commit 5bae803a18b17bdb158a7780e6b6ac3c520e5b39
      Author: Simon Peyton Jones <[email protected]>
      Date:   Sat Sep 15 23:09:25 2012 +0100
          Fix UNPACK with -fomit-interface-pragmas.
    
    But it's very important that chooseBoxingStrategy is lazy, else
    (in bigger programs with lots of recursion in types) GHC can
    loop. This showed up in Data.Sequence; and I think it was making
    haddock loop as well.
    
    Anyway this patch makes it lazy again.

>---------------------------------------------------------------

 compiler/typecheck/TcTyClsDecls.lhs |   34 +++++++++++++++++-----------------
 1 files changed, 17 insertions(+), 17 deletions(-)

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 40ed898..e25ddc7 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -1042,7 +1042,9 @@ tcConArg new_or_data bty
   = do  { traceTc "tcConArg 1" (ppr bty)
         ; arg_ty <- tcHsConArgType new_or_data bty
         ; traceTc "tcConArg 2" (ppr bty)
-        ; strict_mark <- chooseBoxingStrategy arg_ty (getBangStrictness bty)
+        ; dflags <- getDynFlags
+        ; let strict_mark = chooseBoxingStrategy dflags arg_ty (getBangStrictness bty)
+                            -- Must be computed lazily
 	; return (arg_ty, strict_mark) }
 
 tcConRes :: ResType (LHsType Name) -> TcM (ResType Type)
@@ -1178,10 +1180,20 @@ conRepresentibleWithH98Syntax
 --
 -- We have turned off unboxing of newtypes because coercions make unboxing 
 -- and reboxing more complicated
-chooseBoxingStrategy :: TcType -> HsBang -> TcM HsBang
-chooseBoxingStrategy arg_ty bang
-  = do { dflags <- getDynFlags
-       ; let choice = case bang of
+chooseBoxingStrategy :: DynFlags -> TcType -> HsBang -> HsBang
+chooseBoxingStrategy dflags arg_ty bang
+  = case initial_choice of
+      HsUnpack | dopt Opt_OmitInterfacePragmas dflags
+               -> HsStrict
+      _other   -> initial_choice
+       -- Do not respect UNPACK pragmas if OmitInterfacePragmas is on
+       -- See Trac #5252: unpacking means we must not conceal the
+       --                 representation of the argument type
+       -- However: even when OmitInterfacePragmas is on, we still want
+       -- to know if we have HsUnpackFailed, because we omit a
+       -- warning in that case (#3966)
+  where
+    initial_choice = case bang of
 	               HsNoBang -> HsNoBang
 	               HsStrict | dopt Opt_UnboxStrictFields dflags
                                 -> can_unbox HsStrict arg_ty
@@ -1191,18 +1203,6 @@ chooseBoxingStrategy arg_ty bang
                        HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty)
 		                    	  -- Source code never has HsUnpackFailed
 
-       ; case choice of
-           HsUnpack | dopt Opt_OmitInterfacePragmas dflags
-                    -> return HsStrict
-           _other   -> return choice
-            -- Do not respect UNPACK pragmas if OmitInterfacePragmas is on
-	    -- See Trac #5252: unpacking means we must not conceal the
-	    --                 representation of the argument type
-            -- However: even when OmitInterfacePragmas is on, we still want
-            -- to know if we have HsUnpackFailed, because we omit a
-            -- warning in that case (#3966)
-       }
-  where
     can_unbox :: HsBang -> TcType -> HsBang
     -- Returns   HsUnpack  if we can unpack arg_ty
     -- 		 fail_bang if we know what arg_ty is but we can't unpack it