diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2011-05-12 11:09:28 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2011-05-12 11:09:28 +0100 |
| commit | c8c2f6bb7d79a2a6aeaa3233363fdf0bbbfad205 (patch) | |
| tree | 9975e33afe9569f73b8436bef5df3cea4f830af4 /compiler/basicTypes/MkId.lhs | |
| parent | 025477ef644353f9168a16d0cb9431bcca36be4d (diff) | |
| download | haskell-c8c2f6bb7d79a2a6aeaa3233363fdf0bbbfad205.tar.gz | |
The final batch of changes for the new coercion representation
* Fix bugs in the packing and unpacking of data
constructors with equality predicates in their types
* Remove PredCo altogether; instead, coercions between predicated
types (like (Eq a, [a]~b) => blah) are treated as if they
were precisely their underlying representation type
Eq a -> ((~) [a] b) -> blah
in this case
* Similarly, Type.coreView no longer treats equality
predciates specially.
* Implement the cast-of-coercion optimisation in
Simplify.simplCoercionF
Numerous other small bug-fixes and refactorings.
Annoyingly, OptCoercion had Windows line endings, and this
patch switches to Unix, so it looks as if every line has changed.
Diffstat (limited to 'compiler/basicTypes/MkId.lhs')
| -rw-r--r-- | compiler/basicTypes/MkId.lhs | 19 |
1 files changed, 11 insertions, 8 deletions
diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 328c51b872..4d0e7f81a9 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -230,7 +230,7 @@ mkDataConIds wrap_name wkr_name data_con = DCIds Nothing wrk_id where (univ_tvs, ex_tvs, eq_spec, - theta, orig_arg_tys, res_ty) = dataConFullSig data_con + other_theta, orig_arg_tys, res_ty) = dataConFullSig data_con tycon = dataConTyCon data_con -- The representation TyCon (not family) ----------- Worker (algebraic data types only) -------------- @@ -293,7 +293,7 @@ mkDataConIds wrap_name wkr_name data_con -- extra constraints where necessary. wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs res_ty_args = substTyVars (mkTopTvSubst eq_spec) univ_tvs - ev_tys = mkPredTys theta + ev_tys = mkPredTys other_theta wrap_ty = mkForAllTys wrap_tvs $ mkFunTys ev_tys $ mkFunTys orig_arg_tys $ res_ty @@ -309,8 +309,9 @@ mkDataConIds wrap_name wkr_name data_con `setStrictnessInfo` Just wrap_sig all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con - wrap_sig = mkStrictSig (mkTopDmdType arg_dmds cpr_info) - arg_dmds = map mk_dmd all_strict_marks + wrap_sig = mkStrictSig (mkTopDmdType wrap_arg_dmds cpr_info) + wrap_stricts = dropList eq_spec all_strict_marks + wrap_arg_dmds = map mk_dmd wrap_stricts mk_dmd str | isBanged str = evalDmd | otherwise = lazyDmd -- The Cpr info can be important inside INLINE rhss, where the @@ -327,8 +328,11 @@ mkDataConIds wrap_name wkr_name data_con mkLams ev_args $ mkLams id_args $ foldr mk_case con_app - (zip (ev_args ++ id_args) all_strict_marks) + (zip (ev_args ++ id_args) wrap_stricts) i3 [] + -- The ev_args is the evidence arguments *other than* the eq_spec + -- Because we are going to apply the eq_spec args manually in the + -- wrapper con_app _ rep_ids = wrapFamInstBody tycon res_ty_args $ Var wrk_id `mkTyApps` res_ty_args @@ -598,7 +602,7 @@ mkProductBox arg_ids ty mkReboxingAlt :: [Unique] -- Uniques for the new Ids -> DataCon - -> [Var] -- Source-level args, including existential dicts + -> [Var] -- Source-level args, *including* all evidence vars -> CoreExpr -- RHS -> CoreAlt @@ -626,8 +630,7 @@ mkReboxingAlt us con args rhs -- Term variable case go (arg:args) (str:stricts) us | isMarkedUnboxed str - = - let (binds, unpacked_args') = go args stricts us' + = let (binds, unpacked_args') = go args stricts us' (us', bind_rhs, unpacked_args) = reboxProduct us (idType arg) in (NonRec arg bind_rhs : binds, unpacked_args ++ unpacked_args') |