projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Remove ndpFlatten
[ghc-hetmet.git]
/
compiler
/
basicTypes
/
MkId.lhs
diff --git
a/compiler/basicTypes/MkId.lhs
b/compiler/basicTypes/MkId.lhs
index
3ea5091
..
7d472b1
100644
(file)
--- a/
compiler/basicTypes/MkId.lhs
+++ b/
compiler/basicTypes/MkId.lhs
@@
-12,7
+12,7
@@
have a standard form, namely:
* primitive operations
\begin{code}
* primitive operations
\begin{code}
-{-# OPTIONS -w #-}
+{-# OPTIONS -fno-warn-missing-signatures #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
@@
-656,7
+656,6
@@
mkRecordSelId tycon field_label
-- T1 b' (c : [b]=[b']) (x:Maybe b')
-- -> x `cast` Maybe (sym (right c))
-- T1 b' (c : [b]=[b']) (x:Maybe b')
-- -> x `cast` Maybe (sym (right c))
-
-- Generate the refinement for b'=b,
-- and apply to (Maybe b'), to get (Maybe b)
Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs
-- Generate the refinement for b'=b,
-- and apply to (Maybe b'), to get (Maybe b)
Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs
@@
-799,6
+798,7
@@
mkReboxingAlt us con args rhs
| otherwise
= let (binds, args') = go args stricts us
in (binds, arg:args')
| otherwise
= let (binds, args') = go args stricts us
in (binds, arg:args')
+ go (_ : _) [] _ = panic "mkReboxingAlt"
\end{code}
\end{code}
@@
-827,8
+827,11
@@
at the outside. When dealing with classes it's very convenient to
recover the original type signature from the class op selector.
\begin{code}
recover the original type signature from the class op selector.
\begin{code}
-mkDictSelId :: Name -> Class -> Id
-mkDictSelId name clas
+mkDictSelId :: Bool -- True <=> don't include the unfolding
+ -- Little point on imports without -O, because the
+ -- dictionary itself won't be visible
+ -> Name -> Class -> Id
+mkDictSelId no_unf name clas
= mkGlobalId (ClassOpId clas) name sel_ty info
where
sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id))
= mkGlobalId (ClassOpId clas) name sel_ty info
where
sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id))
@@
-840,8
+843,9
@@
mkDictSelId name clas
info = noCafIdInfo
`setArityInfo` 1
info = noCafIdInfo
`setArityInfo` 1
- `setUnfoldingInfo` mkTopUnfolding rhs
`setAllStrictnessInfo` Just strict_sig
`setAllStrictnessInfo` Just strict_sig
+ `setUnfoldingInfo` (if no_unf then noUnfolding
+ else mkTopUnfolding rhs)
-- We no longer use 'must-inline' on record selectors. They'll
-- inline like crazy if they scrutinise a constructor
-- We no longer use 'must-inline' on record selectors. They'll
-- inline like crazy if they scrutinise a constructor
@@
-1221,6
+1225,7
@@
realWorldPrimId -- :: State# RealWorld
-- which in turn makes INLINE things applied to realWorld# likely
-- to be inlined
-- which in turn makes INLINE things applied to realWorld# likely
-- to be inlined
+voidArgId :: Id
voidArgId -- :: State# RealWorld
= mkSysLocal FSLIT("void") voidArgIdKey realWorldStatePrimTy
\end{code}
voidArgId -- :: State# RealWorld
= mkSysLocal FSLIT("void") voidArgIdKey realWorldStatePrimTy
\end{code}
@@
-1269,7
+1274,11
@@
nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName
nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName
-- The runtime error Ids take a UTF8-encoded string as argument
nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName
-- The runtime error Ids take a UTF8-encoded string as argument
+
+mkRuntimeErrorId :: Name -> Id
mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy
mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy
+
+runtimeErrorTy :: Type
runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy)
\end{code}
runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy)
\end{code}
@@
-1300,6
+1309,7
@@
pcMiscPrelId name ty info
-- being compiled, then it's just a matter of luck if the definition
-- will be in "the right place" to be in scope.
-- being compiled, then it's just a matter of luck if the definition
-- will be in "the right place" to be in scope.
+pc_bottoming_Id :: Name -> Type -> Id
pc_bottoming_Id name ty
= pcMiscPrelId name ty bottoming_info
where
pc_bottoming_Id name ty
= pcMiscPrelId name ty bottoming_info
where