projects / ghc-hetmet.git / commitdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | patch | inline | side by side (parent: 10f1855)
Fix a nasty float-in bug
authorsimonpj@microsoft.com <unknown>
Fri, 22 Aug 2008 13:34:27 +0000 (13:34 +0000)
committersimonpj@microsoft.com <unknown>
Fri, 22 Aug 2008 13:34:27 +0000 (13:34 +0000)
This is a long-standing bug in FloatIn, which I somehow managed to
tickle (it's actually surprisingly hard to provoke which is why
it has not shown up before).

The problem was that we had a specialisation like this:

  let
f_spec = ...
  in let
{-# RULE f Int = f_spec #-}
f = ...
  in
<body>

The 'f_spec' binding was being floated inside the binding for 'f',
which makes the RULE invalid becuase 'f_spec' isn't in scope.

We just need to add the free variables of the RULE in the right
places...

compiler/simplCore/FloatIn.lhs patch | blob | history

diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs
index 8938731..0dd318b 100644 (file)
--- a/compiler/simplCore/FloatIn.lhs
+++ b/compiler/simplCore/FloatIn.lhs
@@ -291,21 +291,21 @@ fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body)
 
        -- Push rhs_binds into the right hand side of the binding
     rhs'     = fiExpr rhs_binds rhs
-    rhs_fvs' = rhs_fvs `unionVarSet` floatedBindsFVs rhs_binds
+    rhs_fvs' = rhs_fvs `unionVarSet` floatedBindsFVs rhs_binds `unionVarSet` rule_fvs
+                       -- Don't forget the rule_fvs; the binding mentions them!
 
 fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
   = fiExpr new_to_drop body
   where
-    rhss = map snd bindings
-
+    (ids, rhss) = unzip bindings
     rhss_fvs = map freeVarsOf rhss
     body_fvs = freeVarsOf body
 
        -- See Note [extra_fvs (1,2)]
-    extra_fvs = foldr (unionVarSet . get_extras) emptyVarSet bindings
-    get_extras (id, (rhs_fvs, rhs)) 
-       | noFloatIntoRhs rhs = idRuleVars id `unionVarSet` rhs_fvs
-       | otherwise          = idRuleVars id
+    rule_fvs = foldr (unionVarSet . idRuleVars) emptyVarSet ids
+    extra_fvs = rule_fvs `unionVarSet` 
+               unionVarSets [ fvs | (fvs, rhs) <- rhss
+                            , noFloatIntoRhs rhs ]
 
     (shared_binds:extra_binds:body_binds:rhss_binds) 
        = sepBindsByDropPoint False (extra_fvs:body_fvs:rhss_fvs) to_drop
@@ -316,8 +316,9 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
                  extra_binds ++        -- Note [extra_fvs (1,2)]
                  shared_binds          -- Used in more than one place
 
-    rhs_fvs' = unionVarSet (unionVarSets rhss_fvs)
-                          (unionVarSets (map floatedBindsFVs rhss_binds))
+    rhs_fvs' = unionVarSets rhss_fvs `unionVarSet`
+              unionVarSets (map floatedBindsFVs rhss_binds) `unionVarSet`
+              rule_fvs         -- Don't forget the rule variables!
 
     -- Push rhs_binds into the right hand side of the binding
     fi_bind :: [FloatingBinds]     -- one per "drop pt" conjured w/ fvs_of_rhss
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)