Commit 713af4d5 authored by sewardj's avatar sewardj

[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.
parent ac60a2e4
......@@ -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.
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment