Commit 07876618 authored by simonm's avatar simonm
Browse files

[project @ 1999-04-19 13:57:21 by simonm]

Fixes to the unbox-strict-fields stuff for existential constructors.
parent 27ce7270
...@@ -190,10 +190,11 @@ mkDataCon name arg_stricts fields tyvars theta ex_tyvars ex_theta orig_arg_tys t ...@@ -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) (real_arg_stricts, strict_arg_tyss)
= unzip (zipWith (unbox_strict_arg_ty tycon) arg_stricts orig_arg_tys) = unzip (zipWith (unbox_strict_arg_ty tycon) arg_stricts orig_arg_tys)
rep_arg_tys = concat strict_arg_tyss rep_arg_tys = concat strict_arg_tyss
all_stricts = (map mk_dict_strict_mark ex_theta) ++ real_arg_stricts ex_dict_stricts = map mk_dict_strict_mark ex_theta
user_stricts = (map mk_dict_strict_mark ex_theta) ++ arg_stricts
-- Add a strictness flag for the existential dictionary arguments -- 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 tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con
ty = mkSigmaTy (tyvars ++ ex_tyvars) ty = mkSigmaTy (tyvars ++ ex_tyvars)
...@@ -255,12 +256,17 @@ maybe_unpack_field set ty MarkedStrict | not opt_UnboxStrictFields ...@@ -255,12 +256,17 @@ maybe_unpack_field set ty MarkedStrict | not opt_UnboxStrictFields
maybe_unpack_field set ty strict maybe_unpack_field set ty strict
= case splitAlgTyConApp_maybe ty of = case splitAlgTyConApp_maybe ty of
Just (tycon,ty_args,[con]) Just (tycon,ty_args,[con])
-- loop breaker
| tycon `elementOfUniqSet` set -> Nothing | tycon `elementOfUniqSet` set -> Nothing
-- don't unpack constructors with existential tyvars
| not (null ex_tyvars) -> Nothing
-- ok, let's do it
| otherwise -> | otherwise ->
let set' = addOneToUniqSet set tycon in let set' = addOneToUniqSet set tycon in
maybe_unpack_fields set' maybe_unpack_fields set'
(zip (dataConOrigArgTys con ty_args) (zip (dataConOrigArgTys con ty_args)
(dcUserStricts con)) (dcUserStricts con))
where (_, _, ex_tyvars, _, _, _) = dataConSig con
_ -> Just [ty] _ -> Just [ty]
maybe_unpack_fields :: UniqSet TyCon -> [(Type,StrictnessMark)] -> Maybe [Type] maybe_unpack_fields :: UniqSet TyCon -> [(Type,StrictnessMark)] -> Maybe [Type]
......
...@@ -180,7 +180,8 @@ dataConInfo data_con ...@@ -180,7 +180,8 @@ dataConInfo data_con
con_rhs = mkLams all_tyvars $ mkLams dict_args $ con_rhs = mkLams all_tyvars $ mkLams dict_args $
mkLams ex_dict_args $ mkLams id_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 mk_case
:: (Id, StrictnessMark) -- arg, strictness :: (Id, StrictnessMark) -- arg, strictness
......
...@@ -239,6 +239,9 @@ rebuildConArgs ...@@ -239,6 +239,9 @@ rebuildConArgs
-> DsM (CoreExpr, [Id]) -> DsM (CoreExpr, [Id])
rebuildConArgs con [] stricts body = returnDs (body, []) 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 (arg:args) (str:stricts) body
= rebuildConArgs con args stricts body `thenDs` \ (body', real_args) -> = rebuildConArgs con args stricts body `thenDs` \ (body', real_args) ->
case str of case str of
......
...@@ -1488,8 +1488,8 @@ simplAlts zap_occ_info scrut_cons case_bndr'' alts cont' ...@@ -1488,8 +1488,8 @@ simplAlts zap_occ_info scrut_cons case_bndr'' alts cont'
add_evals other_con vs = vs add_evals other_con vs = vs
cat_evals [] [] = [] cat_evals [] [] = []
cat_evals (v:vs) (str:strs) cat_evals (v:vs) (str:strs)
| isTyVar v = cat_evals vs (str:strs) | isTyVar v = v : cat_evals vs (str:strs)
| otherwise = | otherwise =
case str of case str of
MarkedStrict -> MarkedStrict ->
......
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