[commit: ghc] supercompiler: Use a VoidRep placeholder that doesn't crash the simplifier (7b37a89)

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

On branch  : supercompiler

http://hackage.haskell.org/trac/ghc/changeset/7b37a896cea7df490526d520fc30399177a894b9

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

commit 7b37a896cea7df490526d520fc30399177a894b9
Author: Max Bolingbroke <[email protected]>
Date:   Tue Jan 3 15:33:18 2012 +0000

    Use a VoidRep placeholder that doesn't crash the simplifier

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

 .../supercompile/Supercompile/Drive/Process.hs     |   37 +++++++++++++------
 .../supercompile/Supercompile/Drive/Process1.hs    |    2 +-
 2 files changed, 26 insertions(+), 13 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs b/compiler/supercompile/Supercompile/Drive/Process.hs
index 76e7efd..f91d7c2 100644
--- a/compiler/supercompile/Supercompile/Drive/Process.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process.hs
@@ -14,7 +14,9 @@ module Supercompile.Drive.Process (
     AlreadySpeculated, nothingSpeculated,
     speculate,
 
-    AbsVar(..), mkLiveAbsVar, renameAbsVar, absVarLambdas, applyAbsVars, stateAbsVars
+    AbsVar(..), mkLiveAbsVar, renameAbsVar, absVarLambdas, applyAbsVars, stateAbsVars,
+
+    extraOutputFvs
   ) where
 
 #include "HsVersions.h"
@@ -45,9 +47,9 @@ import Supercompile.Utilities hiding (Monad(..))
 
 import Var        (isId, isTyVar, varType, setVarType)
 import Id         (idType, zapFragileIdInfo, localiseId)
-import MkId       (voidArgId)
+import MkId       (voidArgId, realWorldPrimId)
 import Type       (isUnLiftedType, mkTyVarTy)
-import Coercion   (isCoVar, mkCoVarCo, mkUnsafeCo, coVarKind_maybe, mkCoercionType)
+import Coercion   (isCoVar, isReflCo, mkCoVarCo, mkUnsafeCo, coVarKind_maybe, mkCoercionType)
 import CoreUtils  (mkPiTypes)
 import TyCon      (PrimRep(..))
 import Type       (mkFunTy, typePrimRep, splitTyConApp_maybe)
@@ -501,17 +503,23 @@ applyAbsVars x xs = snd (foldl go (unitVarSet x, var x) xs)
          -- Just choose some value with the same *representation* as what we want and then
          -- cast it to the right type:
          | let (e_repr_ty, e_repr) = case typePrimRep ty of
-                 VoidRep   -> (mkCoercionType unitTy unitTy, coercion (mkUnsafeCo unitTy unitTy))
-                 IntRep    -> (intPrimTy,    literal (mkMachInt 0))
-                 WordRep   -> (wordPrimTy,   literal (mkMachWord 0))
-                 Int64Rep  -> (int64PrimTy,  literal (mkMachInt64 0))
-                 Word64Rep -> (word64PrimTy, literal (mkMachWord64 0))
-                 AddrRep   -> (addrPrimTy,   literal nullAddrLit)
-                 FloatRep  -> (floatPrimTy,  literal (mkMachChar 'x'))
-                 DoubleRep -> (doublePrimTy, literal (mkMachDouble 0))
+                 -- This causes the simplifier to fail with an error about (!!) out of bounds because
+                 -- it tries to reduce the cast coercion, causing it to decompose the unsafe coercion:
+                 --VoidRep   -> (mkCoercionType unitTy unitTy, coercion (mkUnsafeCo unitTy unitTy))
+                 -- We'll do this instead, even though it means we have to special-case realWorldPrimId
+                 -- in the free-variable sanity checks:
+                 VoidRep   -> (realWorldStatePrimTy, var realWorldPrimId)
+                 IntRep    -> (intPrimTy,            literal (mkMachInt 0))
+                 WordRep   -> (wordPrimTy,           literal (mkMachWord 0))
+                 Int64Rep  -> (int64PrimTy,          literal (mkMachInt64 0))
+                 Word64Rep -> (word64PrimTy,         literal (mkMachWord64 0))
+                 AddrRep   -> (addrPrimTy,           literal nullAddrLit)
+                 FloatRep  -> (floatPrimTy,          literal (mkMachChar 'x'))
+                 DoubleRep -> (doublePrimTy,         literal (mkMachDouble 0))
                  -- Unlifted thing of PtrRep: yes, this can really happen (ByteArray# etc)
                  PtrRep    -> pprPanic "applyAbsVars: dead unlifted variable with PrimRep PtrRep: FIXME" (ppr ty)
-         -> let_ x (e_repr `cast` mkUnsafeCo e_repr_ty ty) (e `app` x))
+               co = mkUnsafeCo e_repr_ty ty
+         -> let_ x (if isReflCo co then e_repr else e_repr `cast` co) (e `app` x))
          where shadowy_x = absVarBinder absx
                x = uniqAway (mkInScopeSet fvs) shadowy_x
                ty = idType x
@@ -542,3 +550,8 @@ stateAbsVars mb_lvs state = (abstracted, realWorldStatePrimTy `mkFunTy` (vs_list
 
 sortLambdaBounds :: [Var] -> [Var]
 sortLambdaBounds = sortBy (comparing (not . isTyVar)) -- True type variables go first since coercion/value variables may reference them
+
+
+-- | Free variables that are allowed to be in the output term even though they weren't in the input (in addition to h-function names)
+extraOutputFvs :: FreeVars
+extraOutputFvs = unitVarSet realWorldPrimId
diff --git a/compiler/supercompile/Supercompile/Drive/Process1.hs b/compiler/supercompile/Supercompile/Drive/Process1.hs
index 4555b14..a04987f 100644
--- a/compiler/supercompile/Supercompile/Drive/Process1.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process1.hs
@@ -229,7 +229,7 @@ promise p opt = ScpM $ \e s k -> {- traceRender ("promise", fun p, abstracted p)
        ScpM $ \_e s k -> k () (s { pTreeHole = Split False [(p { abstracted = abstracted' },
                                Fulfilled (absVarLambdas abstracted' optimised_e))] (pTreeHole s) })
       
-      fmap (((mkVarSet (map absVarVar abstracted') `unionVarSet` stateLetBounders (meaning p)) `unionVarSet`) . mkVarSet) getPromiseNames >>=
+      fmap (((mkVarSet (map absVarVar abstracted') `unionVarSet` stateLetBounders (meaning p) `unionVarSet` extraOutputFvs) `unionVarSet`) . mkVarSet) getPromiseNames >>=
         \fvs -> ASSERT2(optimised_fvs `subVarSet` fvs, ppr (fun p, optimised_fvs `minusVarSet` fvs, fvs, optimised_e)) return ()
       
       return (a, fun p `applyAbsVars` abstracted')