[project @ 2001-05-08 16:47:25 by sewardj]

Insert interim fix in the bytecode gen to ignore polymorphic case
for the time being.  I can't see any way to fix it right in the
timescale before 5.00.1 goes out.  This works well enough to
make Sergei's DoCon thing run on the interpreter without segfaults.

   -- Nasty hack; treat
   --     case scrut::suspect of bndr { DEFAULT -> rhs }
   --     as
   --     let bndr = scrut in rhs
   --     when suspect is polymorphic or arrowtyped
   -- So the required strictness properties are not observed.
   -- At some point, must fix this properly.

diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs
index 4b1bed5..39a54a4 100644 (file)
--- a/ghc/compiler/ghci/ByteCodeGen.lhs
+++ b/ghc/compiler/ghci/ByteCodeGen.lhs
@@ -25,14 +25,15 @@ import Literal              ( Literal(..), literalPrimRep )
 import PrimRep         ( PrimRep(..) )
 import PrimOp          ( PrimOp(..)  )
 import CoreFVs         ( freeVars )
-import Type            ( typePrimRep, splitTyConApp_maybe )
+import Type            ( typePrimRep, splitTyConApp_maybe, isTyVarTy, splitForAllTys )
 import DataCon         ( dataConTag, fIRST_TAG, dataConTyCon, 
                           dataConWrapId, isUnboxedTupleCon )
-import TyCon           ( TyCon(..), tyConFamilySize, isDataTyCon, tyConDataCons )
+import TyCon           ( TyCon(..), tyConFamilySize, isDataTyCon, tyConDataCons,
+                         isFunTyCon )
 import Class           ( Class, classTyCon )
 import Util            ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem )
 import Var             ( isTyVar )
-import VarSet          ( VarSet, varSetElems )
+import VarSet          ( VarSet, varSetElems, unitVarSet, unionVarSet )
 import PrimRep         ( getPrimRepSize, isFollowableRep )
 import CmdLineOpts     ( DynFlags, DynFlag(..) )
 import ErrUtils                ( showPass, dumpIfSet_dyn )
@@ -320,6 +321,40 @@ schemeE d s p (fvs, AnnLet binds b)
      returnBc (allocCode `appOL` thunkCode `appOL` bodyCode)
 
 
+
+
+
+schemeE d s p (fvs_case, AnnCase (fvs_scrut, scrut) bndr 
+                                 [(DEFAULT, [], (fvs_rhs, rhs))])
+
+   | let isFunType var_type 
+            = case splitForAllTys var_type of
+                 (_, ty) -> case splitTyConApp_maybe ty of
+                               Just (tycon,_) | isFunTyCon tycon -> True
+                               _ -> False
+         ty_bndr = idType bndr
+     in isFunType ty_bndr || isTyVarTy ty_bndr
+
+   -- Nasty hack; treat
+   --     case scrut::suspect of bndr { DEFAULT -> rhs }
+   --     as 
+   --     let bndr = scrut in rhs
+   --     when suspect is polymorphic or arrowtyped
+   -- So the required strictness properties are not observed.
+   -- At some point, must fix this properly.
+   = let new_expr
+            = (fvs_case, 
+               AnnLet 
+                  (AnnNonRec bndr (fvs_scrut, scrut)) (fvs_rhs, rhs)
+              )
+
+     in  trace ("WARNING: ignoring polymorphic case in interpreted mode.\n" ++
+                "   Possibly due to strict polymorphic/functional constructor args.\n" ++
+                "   Your program may leak space unexpectedly.\n")
+                -- ++ showSDoc (char ' ' $$ pprCoreExpr (deAnnotate new_expr) $$ char ' '))
+         (schemeE d s p new_expr)
+
+
 schemeE d s p (fvs, AnnCase scrut bndr alts)
    = let
         -- Top of stack is the return itbl, as usual.