mk_bind ((tyvars, global, local, prags), n) -- locals !! n == local
= -- Need to make fresh locals to bind in the selector, because
-- some of the tyvars will be bound to 'Any'
- do { locals' <- newSysLocalsDs (map substitute local_tys)
+ do { ty_args <- mapM mk_ty_arg all_tyvars
+ ; let substitute = substTyWith all_tyvars ty_args
+ ; locals' <- newSysLocalsDs (map substitute local_tys)
; tup_id <- newSysLocalDs (substitute tup_ty)
; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind)
prags
mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args
; returnDs ((global', rhs) : spec_binds) }
where
- mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
- | otherwise = mkArbitraryType all_tyvar
- ty_args = map mk_ty_arg all_tyvars
- substitute = substTyWith all_tyvars ty_args
+ mk_ty_arg all_tyvar
+ | all_tyvar `elem` tyvars = return (mkTyVarTy all_tyvar)
+ | otherwise = dsMkArbitraryType all_tyvar
; export_binds_s <- mappM mk_bind (exports `zip` [0..])
-- don't scc (auto-)annotate the tuple itself.
case mb_lhs of
Nothing -> do { warnDs decomp_msg; return Nothing }
- Just (var, args) -> return (Just (addInlineInfo inl spec_id spec_rhs, rule))
- where
- local_poly = setIdNotExported poly_id
+ Just (var, args) -> do
+
+ { f_body <- fix_up (Let mono_bind (Var mono_id))
+
+ ; let local_poly = setIdNotExported poly_id
-- Very important to make the 'f' non-exported,
-- else it won't be inlined!
spec_id = mkLocalId spec_name spec_ty
spec_rhs = Let (NonRec local_poly poly_f_body) ds_spec_expr
- poly_f_body = mkLams (tvs ++ dicts) $
- fix_up (Let mono_bind (Var mono_id))
-
+ poly_f_body = mkLams (tvs ++ dicts) f_body
+
rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
AlwaysActive poly_name
bndrs args
(mkVarApps (Var spec_id) bndrs)
- } }
+ ; return (Just (addInlineInfo inl spec_id spec_rhs, rule))
+ } } }
where
-- Bind to Any any of all_ptvs that aren't
-- relevant for this particular function
- fix_up body | null void_tvs = body
- | otherwise = mkTyApps (mkLams void_tvs body)
- (map mkArbitraryType void_tvs)
+ fix_up body | null void_tvs = return body
+ | otherwise = do { void_tys <- mapM dsMkArbitraryType void_tvs
+ ; return (mkTyApps (mkLams void_tvs body) void_tys) }
+
void_tvs = all_tvs \\ tvs
dead_msg bs = vcat [ sep [ptext SLIT("Useless constraint") <> plural bs
decomp_msg = hang (ptext SLIT("Specialisation too complicated to desugar; ignored"))
2 (ppr spec_expr)
+
+dsMkArbitraryType tv = mkArbitraryType warn tv
+ where
+ warn span msg = putSrcSpanDs span (warnDs msg)
\end{code}
Note [Unused spec binders]
-- mutable tyvar to a fresh immutable one. So the mutable store
-- plays the role of an environment. If we come across a mutable
-- type variable that isn't so bound, it must be completely free.
- zonk_unbound_tyvar tv = do { writeMetaTyVar tv ty; return ty }
- where
- ty = mkArbitraryType tv
-
-
--- When the type checker finds a type variable with no binding,
--- which means it can be instantiated with an arbitrary type, it
--- usually instantiates it to Void. Eg.
---
--- length []
--- ===>
--- length Void (Nil Void)
---
--- But in really obscure programs, the type variable might have
--- a kind other than *, so we need to invent a suitably-kinded type.
---
--- This commit uses
--- Void for kind *
--- List for kind *->*
--- Tuple for kind *->...*->*
---
--- which deals with most cases. (Previously, it only dealt with
--- kind *.)
---
--- In the other cases, it just makes up a TyCon with a suitable
--- kind. If this gets into an interface file, anyone reading that
--- file won't understand it. This is fixable (by making the client
--- of the interface file make up a TyCon too) but it is tiresome and
--- never happens, so I am leaving it
-
-mkArbitraryType :: TcTyVar -> Type
--- Make up an arbitrary type whose kind is the same as the tyvar.
--- We'll use this to instantiate the (unbound) tyvar.
-mkArbitraryType tv
- | liftedTypeKind `isSubKind` kind = anyPrimTy -- The vastly common case
- | otherwise = mkTyConApp tycon []
- where
- kind = tyVarKind tv
- (args,res) = splitKindFunTys kind
+ zonk_unbound_tyvar tv = do { ty <- mkArbitraryType warn tv
+ ; writeMetaTyVar tv ty
+ ; return ty }
+ where
+ warn span msg = setSrcSpan span (addWarnTc msg)
+
+
+{- Note [Strangely-kinded void TyCons]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ See Trac #959 for more examples
+
+When the type checker finds a type variable with no binding, which
+means it can be instantiated with an arbitrary type, it usually
+instantiates it to Void. Eg.
+
+ length []
+===>
+ length Void (Nil Void)
- tycon | eqKind kind (tyConKind anyPrimTyCon1) -- *->*
- = anyPrimTyCon1 -- No tuples this size
+But in really obscure programs, the type variable might have a kind
+other than *, so we need to invent a suitably-kinded type.
- | all isLiftedTypeKind args && isLiftedTypeKind res
- = tupleTyCon Boxed (length args) -- *-> ... ->*->*
- -- Horrible hack to make less use of mkAnyPrimTyCon
+This commit uses
+ Void for kind *
+ List for kind *->*
+ Tuple for kind *->...*->*
- | otherwise
- = mkAnyPrimTyCon (getUnique tv) kind
+which deals with most cases. (Previously, it only dealt with
+kind *.)
+
+In the other cases, it just makes up a TyCon with a suitable kind. If
+this gets into an interface file, anyone reading that file won't
+understand it. This is fixable (by making the client of the interface
+file make up a TyCon too) but it is tiresome and never happens, so I
+am leaving it.
+
+Meanwhile I have now fixed GHC to emit a civilized warning.
+ -}
+
+mkArbitraryType :: (SrcSpan -> SDoc -> TcRnIf g l a) -- How to complain
+ -> TcTyVar
+ -> TcRnIf g l Type -- Used by desugarer too
+-- Make up an arbitrary type whose kind is the same as the tyvar.
+-- We'll use this to instantiate the (unbound) tyvar.
+--
+-- Also used by the desugarer; hence the (tiresome) parameter
+-- to use when generating a warning
+mkArbitraryType warn tv
+ | liftedTypeKind `isSubKind` kind -- The vastly common case
+ = return anyPrimTy
+ | eqKind kind (tyConKind anyPrimTyCon1) -- *->*
+ = return (mkTyConApp anyPrimTyCon1 []) -- No tuples this size
+ | all isLiftedTypeKind args -- *-> ... ->*->*
+ , isLiftedTypeKind res -- Horrible hack to make less use
+ = return (mkTyConApp tup_tc []) -- of mkAnyPrimTyCon
+ | otherwise
+ = do { warn (getSrcSpan tv) msg
+ ; return (mkTyConApp (mkAnyPrimTyCon (getUnique tv) kind) []) }
-- Same name as the tyvar, apart from making it start with a colon (sigh)
-- I dread to think what will happen if this gets out into an
-- interface file. Catastrophe likely. Major sigh.
+ where
+ kind = tyVarKind tv
+ (args,res) = splitKindFunTys kind
+ tup_tc = tupleTyCon Boxed (length args)
+
+ msg = vcat [ hang (ptext SLIT("Inventing strangely-kinded Any TyCon"))
+ 2 (ptext SLIT("of kind") <+> quotes (ppr kind))
+ , nest 2 (ptext SLIT("from an instantiation of type variable") <+> quotes (ppr tv))
+ , ptext SLIT("This warning can be suppressed by a type signature fixing") <+> quotes (ppr tv)
+ , nest 2 (ptext SLIT("but is harmless without -O (and usually harmless anyway)."))
+ , ptext SLIT("See http://hackage.haskell.org/trac/ghc/ticket/959 for details") ]
\end{code}