From: sewardj <unknown>
Date: Tue, 8 May 2001 16:47:25 +0000 (+0000)
Subject: [project @ 2001-05-08 16:47:25 by sewardj]
X-Git-Tag: Approximately_9120_patches~1972
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=713af4d5c60f5d706c20eb3a712cddf6116be393;p=ghc-hetmet.git

[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
--- 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.