From: simonm <unknown>
Date: Mon, 19 Apr 1999 13:57:23 +0000 (+0000)
Subject: [project @ 1999-04-19 13:57:21 by simonm]
X-Git-Tag: Approximately_9120_patches~6318
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=078766185e6d4487239ea912449dd35b9d906441;p=ghc-hetmet.git

[project @ 1999-04-19 13:57:21 by simonm]
Fixes to the unbox-strict-fields stuff for existential constructors.
---

diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs
index d8c0935..0ecb8e0 100644
--- a/ghc/compiler/basicTypes/DataCon.lhs
+++ b/ghc/compiler/basicTypes/DataCon.lhs
@@ -190,10 +190,11 @@ mkDataCon name arg_stricts fields tyvars theta ex_tyvars ex_theta orig_arg_tys t
     (real_arg_stricts, strict_arg_tyss) 
 	= unzip (zipWith (unbox_strict_arg_ty tycon) arg_stricts orig_arg_tys)
     rep_arg_tys = concat strict_arg_tyss
-
-    all_stricts = (map mk_dict_strict_mark ex_theta) ++ real_arg_stricts
-    user_stricts = (map mk_dict_strict_mark ex_theta) ++ arg_stricts
+	
+    ex_dict_stricts = map mk_dict_strict_mark ex_theta
 	-- Add a strictness flag for the existential dictionary arguments
+    all_stricts     = ex_dict_stricts ++ real_arg_stricts
+    user_stricts    = ex_dict_stricts ++ arg_stricts
 
     tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con
     ty  = mkSigmaTy (tyvars ++ ex_tyvars) 
@@ -255,12 +256,17 @@ maybe_unpack_field set ty MarkedStrict | not opt_UnboxStrictFields
 maybe_unpack_field set ty strict
   = case splitAlgTyConApp_maybe ty of
 	Just (tycon,ty_args,[con])
+		-- loop breaker
 	   | tycon `elementOfUniqSet` set -> Nothing
+		-- don't unpack constructors with existential tyvars
+	   | not (null ex_tyvars) -> Nothing
+		-- ok, let's do it
 	   | otherwise ->
 		let set' = addOneToUniqSet set tycon in
 		maybe_unpack_fields set' 
 		    (zip (dataConOrigArgTys con ty_args)
 			 (dcUserStricts con))
+	   where (_, _, ex_tyvars, _, _, _) = dataConSig con
 	_ -> Just [ty]
 
 maybe_unpack_fields :: UniqSet TyCon -> [(Type,StrictnessMark)] -> Maybe [Type]
diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index cb53da0..237b210 100644
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -180,7 +180,8 @@ dataConInfo data_con
 
 	con_rhs = mkLams all_tyvars $ mkLams dict_args $ 
 		  mkLams ex_dict_args $ mkLams id_args $
-		  foldr mk_case con_app (zip id_args strict_marks) i3 []
+		  foldr mk_case con_app 
+		     (zip (ex_dict_args++id_args) strict_marks) i3 []
 
 	mk_case 
 	   :: (Id, StrictnessMark)	-- arg, strictness
diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 9da5d95..e945912 100644
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -239,6 +239,9 @@ rebuildConArgs
   -> DsM (CoreExpr, [Id])
 
 rebuildConArgs con [] stricts body = returnDs (body, [])
+rebuildConArgs con (arg:args) stricts body | isTyVar arg
+  = rebuildConArgs con args stricts body `thenDs` \ (body', args') ->
+    returnDs (body',arg:args')
 rebuildConArgs con (arg:args) (str:stricts) body
   = rebuildConArgs con args stricts body `thenDs` \ (body', real_args) ->
     case str of
diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index f05373f..aca723c 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -1488,8 +1488,8 @@ simplAlts zap_occ_info scrut_cons case_bndr'' alts cont'
     add_evals other_con    vs = vs
 
     cat_evals [] [] = []
-    cat_evals (v:vs) (str:strs) 
-	| isTyVar v = cat_evals vs (str:strs)
+    cat_evals (v:vs) (str:strs)
+	| isTyVar v = v : cat_evals vs (str:strs)
 	| otherwise = 
 	   case str of
 		MarkedStrict    ->