projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Use unsafeDupableInterleaveIO in UniqSupply
[ghc-hetmet.git]
/
compiler
/
basicTypes
/
MkId.lhs
diff --git
a/compiler/basicTypes/MkId.lhs
b/compiler/basicTypes/MkId.lhs
index
42515eb
..
229d390
100644
(file)
--- a/
compiler/basicTypes/MkId.lhs
+++ b/
compiler/basicTypes/MkId.lhs
@@
-21,6
+21,7
@@
module MkId (
mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId,
mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId,
mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
+ wrapFamInstBody, unwrapFamInstScrut,
mkUnpackCase, mkProductBox,
-- And some particular Ids; see below for why they are wired in
mkUnpackCase, mkProductBox,
-- And some particular Ids; see below for why they are wired in
@@
-72,7
+73,7
@@
import Outputable
import FastString
import ListSetOps
import Module
import FastString
import ListSetOps
import Module
-\end{code}
+\end{code}
%************************************************************************
%* *
%************************************************************************
%* *
@@
-211,7
+212,6
@@
Now we want
mkDataConIds :: Name -> Name -> DataCon -> DataConIds
mkDataConIds wrap_name wkr_name data_con
| isNewTyCon tycon -- Newtype, only has a worker
mkDataConIds :: Name -> Name -> DataCon -> DataConIds
mkDataConIds wrap_name wkr_name data_con
| isNewTyCon tycon -- Newtype, only has a worker
- , not (isFamInstTyCon tycon) -- unless it's a family instancex
= DCIds Nothing nt_work_id
| any isMarkedStrict all_strict_marks -- Algebraic, needs wrapper
= DCIds Nothing nt_work_id
| any isMarkedStrict all_strict_marks -- Algebraic, needs wrapper
@@
-279,7
+279,7
@@
mkDataConIds wrap_name wkr_name data_con
wrapNewTypeBody tycon res_ty_args
(Var id_arg1)
wrapNewTypeBody tycon res_ty_args
(Var id_arg1)
- id_arg1 = mkTemplateLocal 1 (head orig_arg_tys)
+ id_arg1 = ASSERT( not (null orig_arg_tys) ) mkTemplateLocal 1 (head orig_arg_tys)
----------- Wrapper --------------
-- We used to include the stupid theta in the wrapper's args
----------- Wrapper --------------
-- We used to include the stupid theta in the wrapper's args
@@
-478,7
+478,8
@@
mkRecordSelId tycon field_label
| otherwise = sel_id
where
is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tv_set)
| otherwise = sel_id
where
is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tv_set)
- sel_id_details = RecordSelId tycon field_label is_naughty
+ sel_id_details = RecordSelId { sel_tycon = tycon, sel_label = field_label, sel_naughty = is_naughty }
+ -- For a data type family, the tycon is the *instance* TyCon
-- Escapist case here for naughty constructors
-- We give it no IdInfo, and a type of forall a.a (never looked at)
-- Escapist case here for naughty constructors
-- We give it no IdInfo, and a type of forall a.a (never looked at)
@@
-491,8
+492,10
@@
mkRecordSelId tycon field_label
data_cons_w_field = filter has_field data_cons -- Can't be empty!
has_field con = field_label `elem` dataConFieldLabels con
data_cons_w_field = filter has_field data_cons -- Can't be empty!
has_field con = field_label `elem` dataConFieldLabels con
- con1 = head data_cons_w_field
+ con1 = ASSERT( not (null data_cons_w_field) ) head data_cons_w_field
(univ_tvs, _, eq_spec, _, _, data_ty) = dataConFullSig con1
(univ_tvs, _, eq_spec, _, _, data_ty) = dataConFullSig con1
+ -- For a data type family, the data_ty (and hence selector_ty) mentions
+ -- only the family TyCon, not the instance TyCon
data_tv_set = tyVarsOfType data_ty
data_tvs = varSetElems data_tv_set
field_ty = dataConFieldType con1 field_label
data_tv_set = tyVarsOfType data_ty
data_tvs = varSetElems data_tv_set
field_ty = dataConFieldType con1 field_label