Fix an ASSERT failure with profiling

The problem arose with this kind of thing

   x = (,) (scc "blah" Nothing)

Then 'x' is marked NoCafRefs by CoreTidy, becuase it has 
arity 1, and doesn't mention any caffy things.

That in turns means that CorePrep must not float out the
sat binding to give

  sat = scc "blah" Nothing
  x = (,) sat

Rather we must generate

  x = \eta. let sat = scc "blah" Nothing 
            in (,) sat eta

URGH! This Caf stuff is such a mess.

compiler/coreSyn/CorePrep.lhs

@@ -197,7 +197,7 @@ And then x will actually end up case-bound
 
 Note [CafInfo and floating]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
-What happense when we try to float bindings to the top level.  At this
+What happens when we try to float bindings to the top level?  At this
 point all the CafInfo is supposed to be correct, and we must make certain
 that is true of the new top-level bindings.  There are two cases
 to consider
@@ -297,16 +297,18 @@ cpePair :: TopLevelFlag -> RecFlag -> RhsDemand
 cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs
   = do { (floats1, rhs1) <- cpeRhsE env rhs
 
-       ; (floats2, rhs2)
+       -- See if we are allowed to float this stuff out of the RHS
+       ; (floats2, rhs2) <- float_from_rhs floats1 rhs1
+
+       -- Make the arity match up
+       ; (floats3, rhs')
             <- if manifestArity rhs1 <= arity 
-	       then return (floats1, cpeEtaExpand arity rhs1)
+	       then return (floats2, cpeEtaExpand arity rhs2)
 	       else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
 	       	    	       -- Note [Silly extra arguments]
 	       	    (do { v <- newVar (idType bndr)
-		        ; let float = mkFloat False False v rhs1
-		        ; return (addFloat floats1 float, cpeEtaExpand arity (Var v)) })
-
-       ; (floats3, rhs') <- float_from_rhs floats2 rhs2
+		        ; let float = mkFloat False False v rhs2
+		        ; return (addFloat floats2 float, cpeEtaExpand arity (Var v)) })
 
 	     	-- Record if the binder is evaluated
        ; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding
@@ -317,37 +319,38 @@ cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs
     arity = idArity bndr	-- We must match this arity
 
     ---------------------
-    float_from_rhs floats2 rhs2
-      | isEmptyFloats floats2 = return (emptyFloats, rhs2)
-      | isTopLevel top_lvl    = float_top    floats2 rhs2
-      | otherwise             = float_nested floats2 rhs2
+    float_from_rhs floats rhs
+      | isEmptyFloats floats = return (emptyFloats, rhs)
+      | isTopLevel top_lvl    = float_top    floats rhs
+      | otherwise             = float_nested floats rhs
 
     ---------------------
-    float_nested floats2 rhs2
-      | wantFloatNested is_rec is_strict_or_unlifted floats2 rhs2
-                  = return (floats2, rhs2)
-      | otherwise = dont_float floats2 rhs2
+    float_nested floats rhs
+      | wantFloatNested is_rec is_strict_or_unlifted floats rhs
+                  = return (floats, rhs)
+      | otherwise = dont_float floats rhs
 
     ---------------------
-    float_top floats2 rhs2	-- Urhgh!  See Note [CafInfo and floating]
+    float_top floats rhs	-- Urhgh!  See Note [CafInfo and floating]
       | mayHaveCafRefs (idCafInfo bndr)
-      = if allLazyTop floats2
-        then return (floats2, rhs2)
-        else dont_float floats2 rhs2
+      , allLazyTop floats
+      = return (floats, rhs)
+
+      -- So the top-level binding is marked NoCafRefs
+      | Just (floats', rhs') <- canFloatFromNoCaf floats rhs
+      = return (floats', rhs')
 
       | otherwise
-      = case canFloatFromNoCaf floats2 rhs2 of
-          Just (floats2', rhs2') -> return (floats2', rhs2')
-          Nothing -> pprPanic "cpePair" (ppr bndr $$ ppr rhs2 $$ ppr floats2)
+      = dont_float floats rhs
 
     ---------------------
-    dont_float floats2 rhs2
+    dont_float floats rhs
       -- Non-empty floats, but do not want to float from rhs
       -- So wrap the rhs in the floats
       -- But: rhs1 might have lambdas, and we can't
       --      put them inside a wrapBinds
-      = do { body2 <- rhsToBodyNF rhs2
-  	   ; return (emptyFloats, wrapBinds floats2 body2) } 
+      = do { body <- rhsToBodyNF rhs
+  	   ; return (emptyFloats, wrapBinds floats body) } 
 
 {- Note [Silly extra arguments]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -897,35 +900,50 @@ deFloatTop (Floats _ floats)
 canFloatFromNoCaf ::  Floats -> CpeRhs -> Maybe (Floats, CpeRhs)
        -- Note [CafInfo and floating]
 canFloatFromNoCaf (Floats ok_to_spec fs) rhs
-  | OkToSpec <- ok_to_spec 
-  = Just (Floats OkToSpec (toOL fs'), subst_expr subst rhs)
+  | OkToSpec <- ok_to_spec 	     -- Worth trying
+  , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs)
+  = Just (Floats OkToSpec fs', subst_expr subst rhs)
   | otherwise              
   = Nothing
   where
-    (subst, fs') = mapAccumL set_nocaf emptySubst (fromOL fs)
-
     subst_expr = substExpr (text "CorePrep")
 
-    set_nocaf _ (FloatCase {}) 
-      = panic "canFloatFromNoCaf"
+    go :: (Subst, OrdList FloatingBind) -> [FloatingBind]
+       -> Maybe (Subst, OrdList FloatingBind)
 
-    set_nocaf subst (FloatLet (NonRec b r)) 
-      = (subst', FloatLet (NonRec b' (subst_expr subst r)))
+    go (subst, fbs_out) [] = Just (subst, fbs_out)
+    
+    go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in) 
+      | rhs_ok r
+      = go (subst', fbs_out `snocOL` new_fb) fbs_in
       where
         (subst', b') = set_nocaf_bndr subst b
+        new_fb = FloatLet (NonRec b' (subst_expr subst r))
 
-    set_nocaf subst (FloatLet (Rec prs))
-      = (subst', FloatLet (Rec (bs' `zip` rs')))
+    go (subst, fbs_out) (FloatLet (Rec prs) : fbs_in)
+      | all rhs_ok rs
+      = go (subst', fbs_out `snocOL` new_fb) fbs_in
       where
         (bs,rs) = unzip prs
         (subst', bs') = mapAccumL set_nocaf_bndr subst bs
         rs' = map (subst_expr subst') rs
+        new_fb = FloatLet (Rec (bs' `zip` rs'))
+
+    go _ _ = Nothing	  -- Encountered a caffy binding
 
+    ------------
     set_nocaf_bndr subst bndr 
       = (extendIdSubst subst bndr (Var bndr'), bndr')
       where
         bndr' = bndr `setIdCafInfo` NoCafRefs
 
+    ------------
+    rhs_ok :: CoreExpr -> Bool
+    -- We can only float to top level from a NoCaf thing if
+    -- the new binding is static. However it can't mention
+    -- any non-static things or it would *already* be Caffy
+    rhs_ok = rhsIsStatic (\_ -> False)
+
 wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool
 wantFloatNested is_rec strict_or_unlifted floats rhs
   =  isEmptyFloats floats

compiler/coreSyn/CoreUtils.lhs

@@ -55,7 +55,6 @@ import SrcLoc
 import VarEnv
 import VarSet
 import Name
-import Module
 #if mingw32_TARGET_OS
 import Packages
 #endif
@@ -1337,7 +1336,7 @@ and 'execute' it rather than allocating it statically.
 -- | This function is called only on *top-level* right-hand sides.
 -- Returns @True@ if the RHS can be allocated statically in the output,
 -- with no thunks involved at all.
-rhsIsStatic :: PackageId -> CoreExpr -> Bool
+rhsIsStatic :: (Name -> Bool) -> CoreExpr -> Bool
 -- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
 -- refers to, CAFs; (ii) in CoreToStg to decide whether to put an
 -- update flag on it and (iii) in DsExpr to decide how to expand
@@ -1392,7 +1391,7 @@ rhsIsStatic :: PackageId -> CoreExpr -> Bool
 -- 
 --    c) don't look through unfolding of f in (f x).
 
-rhsIsStatic _this_pkg rhs = is_static False rhs
+rhsIsStatic _is_dynamic_name rhs = is_static False rhs
   where
   is_static :: Bool	-- True <=> in a constructor argument; must be atomic
   	  -> CoreExpr -> Bool
@@ -1420,7 +1419,7 @@ rhsIsStatic _this_pkg rhs = is_static False rhs
    where
     go (Var f) n_val_args
 #if mingw32_TARGET_OS
-        | not (isDllName _this_pkg (idName f))
+        | not (_is_dynamic_name (idName f))
 #endif
 	=  saturated_data_con f n_val_args
 	|| (in_arg && n_val_args == 0)	

compiler/main/Packages.lhs

@@ -947,6 +947,9 @@ missingDependencyMsg (Just parent)
 
 -- | Will the 'Name' come from a dynamically linked library?
 isDllName :: PackageId -> Name -> Bool
+-- Despite the "dll", I think this function just means that
+-- the synbol comes from another dynamically-linked package,
+-- and applies on all platforms, not just Windows
 isDllName this_pkg name
   | opt_Static = False
   | Just mod <- nameModule_maybe name = modulePackageId mod /= this_pkg

compiler/main/TidyPgm.lhs

@@ -37,6 +37,7 @@ import TcType
 import DataCon
 import TyCon
 import Module
+import Packages( isDllName )
 import HscTypes
 import Maybes
 import UniqSupply
@@ -1139,12 +1140,12 @@ CAF list to keep track of non-collectable CAFs.
 \begin{code}
 hasCafRefs  :: PackageId -> VarEnv Var -> Arity -> CoreExpr -> CafInfo
 hasCafRefs this_pkg p arity expr 
-  | is_caf || mentions_cafs 
-                            = MayHaveCafRefs
+  | is_caf || mentions_cafs = MayHaveCafRefs
   | otherwise 		    = NoCafRefs
  where
   mentions_cafs = isFastTrue (cafRefs p expr)
-  is_caf = not (arity > 0 || rhsIsStatic this_pkg expr)
+  is_dynamic_name = isDllName this_pkg 
+  is_caf = not (arity > 0 || rhsIsStatic is_dynamic_name expr)
 
   -- NB. we pass in the arity of the expression, which is expected
   -- to be calculated by exprArity.  This is because exprArity

compiler/stgSyn/CoreToStg.lhs

@@ -12,7 +12,7 @@ module CoreToStg ( coreToStg, coreExprToStg ) where
 #include "HsVersions.h"
 
 import CoreSyn
-import CoreUtils	( rhsIsStatic, exprType, findDefault )
+import CoreUtils	( exprType, findDefault )
 import CoreArity	( manifestArity )
 import StgSyn
 
@@ -184,7 +184,7 @@ coreTopBindToStg this_pkg env body_fvs (NonRec id rhs)
 	
 	bind = StgNonRec id stg_rhs
     in
-    ASSERT2(consistentCafInfo id bind, ppr id $$ ppr rhs $$ ppr bind )
+    ASSERT2(consistentCafInfo id bind, ppr id {- $$ ppr rhs $$ ppr bind -} )
     (env', fvs' `unionFVInfo` body_fvs, bind)
 
 coreTopBindToStg this_pkg env body_fvs (Rec pairs)
@@ -214,15 +214,14 @@ coreTopBindToStg this_pkg env body_fvs (Rec pairs)
 -- floated out a binding, in which case it will be approximate.
 consistentCafInfo :: Id -> GenStgBinding Var Id -> Bool
 consistentCafInfo id bind
-  | occNameFS (nameOccName (idName id)) == fsLit "sat"
-  = safe
-  | otherwise
-  = WARN (not exact, ppr id) safe
+  = WARN( not (exact || is_sat_thing) , ppr id ) 
+    safe
   where
-	safe  = id_marked_caffy || not binding_is_caffy
-	exact = id_marked_caffy == binding_is_caffy
-	id_marked_caffy  = mayHaveCafRefs (idCafInfo id)
-	binding_is_caffy = stgBindHasCafRefs bind
+    safe  = id_marked_caffy || not binding_is_caffy
+    exact = id_marked_caffy == binding_is_caffy
+    id_marked_caffy  = mayHaveCafRefs (idCafInfo id)
+    binding_is_caffy = stgBindHasCafRefs bind
+    is_sat_thing = occNameFS (nameOccName (idName id)) == fsLit "sat"
 \end{code}
 
 \begin{code}
@@ -236,13 +235,12 @@ coreToTopStgRhs this_pkg scope_fv_info (bndr, rhs)
   = do { (new_rhs, rhs_fvs, _) <- coreToStgExpr rhs
        ; lv_info <- freeVarsToLiveVars rhs_fvs
 
-       ; let stg_rhs   = mkTopStgRhs is_static rhs_fvs (mkSRT lv_info) bndr_info new_rhs
+       ; let stg_rhs   = mkTopStgRhs this_pkg rhs_fvs (mkSRT lv_info) bndr_info new_rhs
              stg_arity = stgRhsArity stg_rhs
        ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs, 
                  rhs_fvs) }
   where
     bndr_info = lookupFVInfo scope_fv_info bndr
-    is_static = rhsIsStatic this_pkg rhs
 
 	-- It's vital that the arity on a top-level Id matches
 	-- the arity of the generated STG binding, else an importing 
@@ -263,25 +261,23 @@ coreToTopStgRhs this_pkg scope_fv_info (bndr, rhs)
                 ptext (sLit "Id arity:") <+> ppr id_arity,
                 ptext (sLit "STG arity:") <+> ppr stg_arity]
 
-mkTopStgRhs :: Bool -> FreeVarsInfo
+mkTopStgRhs :: PackageId -> FreeVarsInfo
 	    -> SRT -> StgBinderInfo -> StgExpr
    	    -> StgRhs
 
-mkTopStgRhs is_static rhs_fvs srt binder_info (StgLam _ bndrs body)
-  = ASSERT( is_static )
-    StgRhsClosure noCCS binder_info
+mkTopStgRhs _ rhs_fvs srt binder_info (StgLam _ bndrs body)
+  = StgRhsClosure noCCS binder_info
 		  (getFVs rhs_fvs)		 
 		  ReEntrant
 		  srt
 		  bndrs body
 
-mkTopStgRhs is_static _ _ _ (StgConApp con args)
-  | is_static	 -- StgConApps can be updatable (see isCrossDllConApp)
+mkTopStgRhs this_pkg _ _ _ (StgConApp con args)
+  | not (isDllConApp this_pkg con args)  -- Dynamic StgConApps are updatable
   = StgRhsCon noCCS con args
 
-mkTopStgRhs is_static rhs_fvs srt binder_info rhs
-  = ASSERT2( not is_static, ppr rhs )
-    StgRhsClosure noCCS binder_info
+mkTopStgRhs _ rhs_fvs srt binder_info rhs
+  = StgRhsClosure noCCS binder_info
 		  (getFVs rhs_fvs)		 
 	          Updatable
 		  srt

compiler/stgSyn/StgSyn.lhs

@@ -48,12 +48,11 @@ module StgSyn (
 
 import CostCentre	( CostCentreStack, CostCentre )
 import VarSet		( IdSet, isEmptyVarSet )
-import Id		( Id, idName, idType, idCafInfo, isId )
+import Id		
+import DataCon
 import IdInfo		( mayHaveCafRefs )
-import Packages		( isDllName )
 import Literal		( Literal, literalType )
 import ForeignCall	( ForeignCall )
-import DataCon		( DataCon, dataConName )
 import CoreSyn		( AltCon )
 import PprCore		( {- instances -} )
 import PrimOp		( PrimOp, PrimCall )
@@ -66,6 +65,11 @@ import Bitmap
 import StaticFlags	( opt_SccProfilingOn )
 import Module
 import FastString
+
+#if mingw32_TARGET_OS
+import Packages		( isDllName )
+
+#endif
 \end{code}
 
 %************************************************************************
@@ -105,17 +109,20 @@ isStgTypeArg :: StgArg -> Bool
 isStgTypeArg (StgTypeArg _) = True
 isStgTypeArg _              = False
 
-isDllArg :: PackageId -> StgArg -> Bool
-	-- Does this argument refer to something in a different DLL?
-isDllArg this_pkg (StgVarArg v)  = isDllName this_pkg (idName v)
-isDllArg _        _              = False
-
 isDllConApp :: PackageId -> DataCon -> [StgArg] -> Bool
-	-- Does this constructor application refer to 
-	-- anything in a different DLL?
-	-- If so, we can't allocate it statically
+-- Does this constructor application refer to 
+-- anything in a different *Windows* DLL?
+-- If so, we can't allocate it statically
+#if mingw32_TARGET_OS
 isDllConApp this_pkg con args
-   = isDllName this_pkg (dataConName con) || any (isDllArg this_pkg) args
+  = isDllName this_pkg (dataConName con) || any is_dll_arg args
+  where
+    is_dll_arg ::StgArg -> Bool
+    is_dll_arg (StgVarArg v) = isDllName this_pkg (idName v)
+    is_dll_arg _             = False
+#else
+isDllConApp _ _ _ = False
+#endif
 
 stgArgType :: StgArg -> Type
 	-- Very half baked becase we have lost the type arguments