Commit 6cce36f8 authored by Simon Peyton Jones's avatar Simon Peyton Jones Committed by Marge Bot

Add AnonArgFlag to FunTy

The big payload of this patch is:

  Add an AnonArgFlag to the FunTy constructor
  of Type, so that
    (FunTy VisArg   t1 t2) means (t1 -> t2)
    (FunTy InvisArg t1 t2) means (t1 => t2)

The big payoff is that we have a simple, local test to make
when decomposing a type, leading to many fewer calls to
isPredTy. To me the code seems a lot tidier, and probably
more efficient (isPredTy has to take the kind of the type).

See Note [Function types] in TyCoRep.

There are lots of consequences

* I made FunTy into a record, so that it'll be easier
  when we add a linearity field, something that is coming
  down the road.

* Lots of code gets touched in a routine way, simply because it
  pattern matches on FunTy.

* I wanted to make a pattern synonym for (FunTy2 arg res), which
  picks out just the argument and result type from the record. But
  alas the pattern-match overlap checker has a heart attack, and
  either reports false positives, or takes too long.  In the end
  I gave up on pattern synonyms.

  There's some commented-out code in TyCoRep that shows what I
  wanted to do.

* Much more clarity about predicate types, constraint types
  and (in particular) equality constraints in kinds.  See TyCoRep
  Note [Types for coercions, predicates, and evidence]
  and Note [Constraints in kinds].

  This made me realise that we need an AnonArgFlag on
  AnonTCB in a TyConBinder, something that was really plain
  wrong before. See TyCon Note [AnonTCB InivsArg]

* When building function types we must know whether we
  need VisArg (mkVisFunTy) or InvisArg (mkInvisFunTy).
  This turned out to be pretty easy in practice.

* Pretty-printing of types, esp in IfaceType, gets
  tidier, because we were already recording the (->)
  vs (=>) distinction in an ad-hoc way.  Death to
  IfaceFunTy.

* mkLamType needs to keep track of whether it is building
  (t1 -> t2) or (t1 => t2).  See Type
  Note [mkLamType: dictionary arguments]

Other minor stuff

* Some tidy-up in validity checking involving constraints;
  Trac #16263
parent ac34e784
...@@ -721,10 +721,8 @@ rnIfaceType (IfaceTyVar n) = pure (IfaceTyVar n) ...@@ -721,10 +721,8 @@ rnIfaceType (IfaceTyVar n) = pure (IfaceTyVar n)
rnIfaceType (IfaceAppTy t1 t2) rnIfaceType (IfaceAppTy t1 t2)
= IfaceAppTy <$> rnIfaceType t1 <*> rnIfaceAppArgs t2 = IfaceAppTy <$> rnIfaceType t1 <*> rnIfaceAppArgs t2
rnIfaceType (IfaceLitTy l) = return (IfaceLitTy l) rnIfaceType (IfaceLitTy l) = return (IfaceLitTy l)
rnIfaceType (IfaceFunTy t1 t2) rnIfaceType (IfaceFunTy af t1 t2)
= IfaceFunTy <$> rnIfaceType t1 <*> rnIfaceType t2 = IfaceFunTy af <$> rnIfaceType t1 <*> rnIfaceType t2
rnIfaceType (IfaceDFunTy t1 t2)
= IfaceDFunTy <$> rnIfaceType t1 <*> rnIfaceType t2
rnIfaceType (IfaceTupleTy s i tks) rnIfaceType (IfaceTupleTy s i tks)
= IfaceTupleTy s i <$> rnIfaceAppArgs tks = IfaceTupleTy s i <$> rnIfaceAppArgs tks
rnIfaceType (IfaceTyConApp tc tks) rnIfaceType (IfaceTyConApp tc tks)
......
...@@ -959,36 +959,33 @@ mkDataCon name declared_infix prom_info ...@@ -959,36 +959,33 @@ mkDataCon name declared_infix prom_info
-- If the DataCon has a wrapper, then the worker's type is never seen -- If the DataCon has a wrapper, then the worker's type is never seen
-- by the user. The visibilities we pick do not matter here. -- by the user. The visibilities we pick do not matter here.
DCR{} -> mkInvForAllTys univ_tvs $ mkTyCoInvForAllTys ex_tvs $ DCR{} -> mkInvForAllTys univ_tvs $ mkTyCoInvForAllTys ex_tvs $
mkFunTys rep_arg_tys $ mkVisFunTys rep_arg_tys $
mkTyConApp rep_tycon (mkTyVarTys univ_tvs) mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
-- See Note [Promoted data constructors] in TyCon -- See Note [Promoted data constructors] in TyCon
prom_tv_bndrs = [ mkNamedTyConBinder vis tv prom_tv_bndrs = [ mkNamedTyConBinder vis tv
| Bndr tv vis <- user_tvbs ] | Bndr tv vis <- user_tvbs ]
prom_arg_bndrs = mkCleanAnonTyConBinders prom_tv_bndrs (theta ++ orig_arg_tys) fresh_names = freshNames (map getName user_tvbs)
prom_res_kind = orig_res_ty -- fresh_names: make sure that the "anonymous" tyvars don't
promoted = mkPromotedDataCon con name prom_info -- clash in name or unique with the universal/existential ones.
(prom_tv_bndrs ++ prom_arg_bndrs) -- Tiresome! And unnecessary because these tyvars are never looked at
prom_res_kind roles rep_info prom_theta_bndrs = [ mkAnonTyConBinder InvisArg (mkTyVar n t)
{- Invisible -} | (n,t) <- fresh_names `zip` theta ]
prom_arg_bndrs = [ mkAnonTyConBinder VisArg (mkTyVar n t)
{- Visible -} | (n,t) <- dropList theta fresh_names `zip` orig_arg_tys ]
prom_bndrs = prom_tv_bndrs ++ prom_theta_bndrs ++ prom_arg_bndrs
prom_res_kind = orig_res_ty
promoted = mkPromotedDataCon con name prom_info prom_bndrs
prom_res_kind roles rep_info
roles = map (\tv -> if isTyVar tv then Nominal else Phantom) roles = map (\tv -> if isTyVar tv then Nominal else Phantom)
(univ_tvs ++ ex_tvs) (univ_tvs ++ ex_tvs)
++ map (const Representational) orig_arg_tys ++ map (const Representational) (theta ++ orig_arg_tys)
mkCleanAnonTyConBinders :: [TyConBinder] -> [Type] -> [TyConBinder]
-- Make sure that the "anonymous" tyvars don't clash in
-- name or unique with the universal/existential ones.
-- Tiresome! And unnecessary because these tyvars are never looked at
mkCleanAnonTyConBinders tc_bndrs tys
= [ mkAnonTyConBinder (mkTyVar name ty)
| (name, ty) <- fresh_names `zip` tys ]
where
fresh_names = freshNames (map getName (binderVars tc_bndrs))
freshNames :: [Name] -> [Name] freshNames :: [Name] -> [Name]
-- Make names whose Uniques and OccNames differ from -- Make an infinite list of Names whose Uniques and OccNames
-- those in the 'avoid' list -- differ from those in the 'avoid' list
freshNames avoids freshNames avoids
= [ mkSystemName uniq occ = [ mkSystemName uniq occ
| n <- [0..] | n <- [0..]
...@@ -1299,8 +1296,8 @@ dataConUserType (MkData { dcUserTyVarBinders = user_tvbs, ...@@ -1299,8 +1296,8 @@ dataConUserType (MkData { dcUserTyVarBinders = user_tvbs,
dcOtherTheta = theta, dcOrigArgTys = arg_tys, dcOtherTheta = theta, dcOrigArgTys = arg_tys,
dcOrigResTy = res_ty }) dcOrigResTy = res_ty })
= mkForAllTys user_tvbs $ = mkForAllTys user_tvbs $
mkFunTys theta $ mkInvisFunTys theta $
mkFunTys arg_tys $ mkVisFunTys arg_tys $
res_ty res_ty
-- | Finds the instantiated types of the arguments required to construct a -- | Finds the instantiated types of the arguments required to construct a
......
...@@ -337,7 +337,7 @@ mkDictSelId name clas ...@@ -337,7 +337,7 @@ mkDictSelId name clas
val_index = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name val_index = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name
sel_ty = mkForAllTys tyvars $ sel_ty = mkForAllTys tyvars $
mkFunTy (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $ mkInvisFunTy (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $
getNth arg_tys val_index getNth arg_tys val_index
base_info = noCafIdInfo base_info = noCafIdInfo
...@@ -1137,7 +1137,7 @@ mkPrimOpId prim_op ...@@ -1137,7 +1137,7 @@ mkPrimOpId prim_op
= id = id
where where
(tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op
ty = mkSpecForAllTys tyvars (mkFunTys arg_tys res_ty) ty = mkSpecForAllTys tyvars (mkVisFunTys arg_tys res_ty)
name = mkWiredInName gHC_PRIM (primOpOcc prim_op) name = mkWiredInName gHC_PRIM (primOpOcc prim_op)
(mkPrimOpIdUnique (primOpTag prim_op)) (mkPrimOpIdUnique (primOpTag prim_op))
(AnId id) UserSyntax (AnId id) UserSyntax
...@@ -1297,7 +1297,7 @@ unsafeCoerceId ...@@ -1297,7 +1297,7 @@ unsafeCoerceId
[_, _, a, b] = mkTyVarTys bndrs [_, _, a, b] = mkTyVarTys bndrs
ty = mkSpecForAllTys bndrs (mkFunTy a b) ty = mkSpecForAllTys bndrs (mkVisFunTy a b)
[x] = mkTemplateLocals [a] [x] = mkTemplateLocals [a]
rhs = mkLams (bndrs ++ [x]) $ rhs = mkLams (bndrs ++ [x]) $
...@@ -1331,7 +1331,7 @@ seqId = pcMiscPrelId seqName ty info ...@@ -1331,7 +1331,7 @@ seqId = pcMiscPrelId seqName ty info
-- see Note [seqId magic] -- see Note [seqId magic]
ty = mkSpecForAllTys [alphaTyVar,betaTyVar] ty = mkSpecForAllTys [alphaTyVar,betaTyVar]
(mkFunTy alphaTy (mkFunTy betaTy betaTy)) (mkVisFunTy alphaTy (mkVisFunTy betaTy betaTy))
[x,y] = mkTemplateLocals [alphaTy, betaTy] [x,y] = mkTemplateLocals [alphaTy, betaTy]
rhs = mkLams [alphaTyVar,betaTyVar,x,y] (Case (Var x) x betaTy [(DEFAULT, [], Var y)]) rhs = mkLams [alphaTyVar,betaTyVar,x,y] (Case (Var x) x betaTy [(DEFAULT, [], Var y)])
...@@ -1341,13 +1341,13 @@ lazyId :: Id -- See Note [lazyId magic] ...@@ -1341,13 +1341,13 @@ lazyId :: Id -- See Note [lazyId magic]
lazyId = pcMiscPrelId lazyIdName ty info lazyId = pcMiscPrelId lazyIdName ty info
where where
info = noCafIdInfo `setNeverLevPoly` ty info = noCafIdInfo `setNeverLevPoly` ty
ty = mkSpecForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy) ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy alphaTy alphaTy)
noinlineId :: Id -- See Note [noinlineId magic] noinlineId :: Id -- See Note [noinlineId magic]
noinlineId = pcMiscPrelId noinlineIdName ty info noinlineId = pcMiscPrelId noinlineIdName ty info
where where
info = noCafIdInfo `setNeverLevPoly` ty info = noCafIdInfo `setNeverLevPoly` ty
ty = mkSpecForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy) ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy alphaTy alphaTy)
oneShotId :: Id -- See Note [The oneShot function] oneShotId :: Id -- See Note [The oneShot function]
oneShotId = pcMiscPrelId oneShotName ty info oneShotId = pcMiscPrelId oneShotName ty info
...@@ -1356,8 +1356,8 @@ oneShotId = pcMiscPrelId oneShotName ty info ...@@ -1356,8 +1356,8 @@ oneShotId = pcMiscPrelId oneShotName ty info
`setUnfoldingInfo` mkCompulsoryUnfolding rhs `setUnfoldingInfo` mkCompulsoryUnfolding rhs
ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar
, openAlphaTyVar, openBetaTyVar ] , openAlphaTyVar, openBetaTyVar ]
(mkFunTy fun_ty fun_ty) (mkVisFunTy fun_ty fun_ty)
fun_ty = mkFunTy openAlphaTy openBetaTy fun_ty = mkVisFunTy openAlphaTy openBetaTy
[body, x] = mkTemplateLocals [fun_ty, openAlphaTy] [body, x] = mkTemplateLocals [fun_ty, openAlphaTy]
x' = setOneShotLambda x -- Here is the magic bit! x' = setOneShotLambda x -- Here is the magic bit!
rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar
...@@ -1387,7 +1387,8 @@ coerceId = pcMiscPrelId coerceName ty info ...@@ -1387,7 +1387,8 @@ coerceId = pcMiscPrelId coerceName ty info
, liftedTypeKind , liftedTypeKind
, alphaTy, betaTy ] , alphaTy, betaTy ]
ty = mkSpecForAllTys [alphaTyVar, betaTyVar] $ ty = mkSpecForAllTys [alphaTyVar, betaTyVar] $
mkFunTys [eqRTy, alphaTy] betaTy mkInvisFunTy eqRTy $
mkVisFunTy alphaTy betaTy
[eqR,x,eq] = mkTemplateLocals [eqRTy, alphaTy, eqRPrimTy] [eqR,x,eq] = mkTemplateLocals [eqRTy, alphaTy, eqRPrimTy]
rhs = mkLams [alphaTyVar, betaTyVar, eqR, x] $ rhs = mkLams [alphaTyVar, betaTyVar, eqR, x] $
......
...@@ -464,6 +464,6 @@ pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta ...@@ -464,6 +464,6 @@ pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta
, pprType sigma_ty ] , pprType sigma_ty ]
where where
sigma_ty = mkForAllTys ex_tvs $ sigma_ty = mkForAllTys ex_tvs $
mkFunTys prov_theta $ mkInvisFunTys prov_theta $
mkFunTys orig_args orig_res_ty mkVisFunTys orig_args orig_res_ty
insert_empty_ctxt = null req_theta && not (null prov_theta && null ex_tvs) insert_empty_ctxt = null req_theta && not (null prov_theta && null ex_tvs)
...@@ -60,10 +60,13 @@ module Var ( ...@@ -60,10 +60,13 @@ module Var (
isGlobalId, isExportedId, isGlobalId, isExportedId,
mustHaveLocalBinding, mustHaveLocalBinding,
-- * ArgFlags
ArgFlag(..), isVisibleArgFlag, isInvisibleArgFlag, sameVis,
AnonArgFlag(..),
-- * TyVar's -- * TyVar's
VarBndr(..), ArgFlag(..), TyCoVarBinder, TyVarBinder, VarBndr(..), TyCoVarBinder, TyVarBinder,
binderVar, binderVars, binderArgFlag, binderType, binderVar, binderVars, binderArgFlag, binderType,
isVisibleArgFlag, isInvisibleArgFlag, sameVis,
mkTyCoVarBinder, mkTyCoVarBinders, mkTyCoVarBinder, mkTyCoVarBinders,
mkTyVarBinder, mkTyVarBinders, mkTyVarBinder, mkTyVarBinders,
isTyVarBinder, isTyVarBinder,
...@@ -422,6 +425,31 @@ instance Binary ArgFlag where ...@@ -422,6 +425,31 @@ instance Binary ArgFlag where
1 -> return Specified 1 -> return Specified
_ -> return Inferred _ -> return Inferred
-- The non-dependent version of ArgFlag, namely AnonArgFlag,
-- appears here partly so that it's together with its friend ArgFlag,
-- but also because it is used in IfaceType, rather early in the
-- compilation chain
data AnonArgFlag
= VisArg -- Used for (->): an ordinary non-dependent arrow
-- The argument is visible in source code
| InvisArg -- Used for (=>): a non-dependent predicate arrow
-- The argument is invisible in source code
deriving (Eq, Ord, Data)
instance Outputable AnonArgFlag where
ppr VisArg = text "[vis]"
ppr InvisArg = text "[invis]"
instance Binary AnonArgFlag where
put_ bh VisArg = putByte bh 0
put_ bh InvisArg = putByte bh 1
get bh = do
h <- getByte bh
case h of
0 -> return VisArg
_ -> return InvisArg
{- ********************************************************************* {- *********************************************************************
* * * *
* VarBndr, TyCoVarBinder * VarBndr, TyCoVarBinder
......
-- Var.hs-boot is Imported (only) by TyCoRep.hs-boot
module Var where
import GhcPrelude ()
-- We compile this module with -XNoImplicitPrelude (for some
-- reason), so if there are no imports it does not seem to
-- depend on anything. But it does! We must, for example,
-- compile GHC.Types in the ghc-prim library first.
-- So this otherwise-unnecessary import tells the build system
-- that this module depends on GhcPrelude, which ensures
-- that GHC.Type is built first.
data ArgFlag
data AnonArgFlag
data Var
...@@ -928,15 +928,15 @@ getTyDescription ty ...@@ -928,15 +928,15 @@ getTyDescription ty
TyVarTy _ -> "*" TyVarTy _ -> "*"
AppTy fun _ -> getTyDescription fun AppTy fun _ -> getTyDescription fun
TyConApp tycon _ -> getOccString tycon TyConApp tycon _ -> getOccString tycon
FunTy _ res -> '-' : '>' : fun_result res FunTy {} -> '-' : fun_result tau_ty
ForAllTy _ ty -> getTyDescription ty ForAllTy _ ty -> getTyDescription ty
LitTy n -> getTyLitDescription n LitTy n -> getTyLitDescription n
CastTy ty _ -> getTyDescription ty CastTy ty _ -> getTyDescription ty
CoercionTy co -> pprPanic "getTyDescription" (ppr co) CoercionTy co -> pprPanic "getTyDescription" (ppr co)
} }
where where
fun_result (FunTy _ res) = '>' : fun_result res fun_result (FunTy { ft_res = res }) = '>' : fun_result res
fun_result other = getTyDescription other fun_result other = getTyDescription other
getTyLitDescription :: TyLit -> String getTyLitDescription :: TyLit -> String
getTyLitDescription l = getTyLitDescription l =
......
...@@ -353,7 +353,7 @@ orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon ...@@ -353,7 +353,7 @@ orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon
`unionNameSet` orphNamesOfTypes tys `unionNameSet` orphNamesOfTypes tys
orphNamesOfType (ForAllTy bndr res) = orphNamesOfType (binderType bndr) orphNamesOfType (ForAllTy bndr res) = orphNamesOfType (binderType bndr)
`unionNameSet` orphNamesOfType res `unionNameSet` orphNamesOfType res
orphNamesOfType (FunTy arg res) = unitNameSet funTyConName -- NB! See Trac #8535 orphNamesOfType (FunTy _ arg res) = unitNameSet funTyConName -- NB! See Trac #8535
`unionNameSet` orphNamesOfType arg `unionNameSet` orphNamesOfType arg
`unionNameSet` orphNamesOfType res `unionNameSet` orphNamesOfType res
orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSet` orphNamesOfType arg orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSet` orphNamesOfType arg
......
...@@ -1349,7 +1349,7 @@ lintType ty@(TyConApp tc tys) ...@@ -1349,7 +1349,7 @@ lintType ty@(TyConApp tc tys)
-- arrows can related *unlifted* kinds, so this has to be separate from -- arrows can related *unlifted* kinds, so this has to be separate from
-- a dependent forall. -- a dependent forall.
lintType ty@(FunTy t1 t2) lintType ty@(FunTy _ t1 t2)
= do { k1 <- lintType t1 = do { k1 <- lintType t1
; k2 <- lintType t2 ; k2 <- lintType t2
; lintArrow (text "type or kind" <+> quotes (ppr ty)) k1 k2 } ; lintArrow (text "type or kind" <+> quotes (ppr ty)) k1 k2 }
...@@ -1509,7 +1509,7 @@ lint_app doc kfn kas ...@@ -1509,7 +1509,7 @@ lint_app doc kfn kas
| Just kfn' <- coreView kfn | Just kfn' <- coreView kfn
= go_app in_scope kfn' tka = go_app in_scope kfn' tka
go_app _ (FunTy kfa kfb) tka@(_,ka) go_app _ (FunTy _ kfa kfb) tka@(_,ka)
= do { unless (ka `eqType` kfa) $ = do { unless (ka `eqType` kfa) $
addErrL (fail_msg (text "Fun:" <+> (ppr kfa $$ ppr tka))) addErrL (fail_msg (text "Fun:" <+> (ppr kfa $$ ppr tka)))
; return kfb } ; return kfb }
...@@ -1765,7 +1765,7 @@ lintCoercion co@(FunCo r co1 co2) ...@@ -1765,7 +1765,7 @@ lintCoercion co@(FunCo r co1 co2)
; k' <- lintArrow (text "coercion" <+> quotes (ppr co)) k'1 k'2 ; k' <- lintArrow (text "coercion" <+> quotes (ppr co)) k'1 k'2
; lintRole co1 r r1 ; lintRole co1 r r1
; lintRole co2 r r2 ; lintRole co2 r r2
; return (k, k', mkFunTy s1 s2, mkFunTy t1 t2, r) } ; return (k, k', mkVisFunTy s1 s2, mkVisFunTy t1 t2, r) }
lintCoercion (CoVarCo cv) lintCoercion (CoVarCo cv)
| not (isCoVar cv) | not (isCoVar cv)
......
...@@ -3,12 +3,14 @@ ...@@ -3,12 +3,14 @@
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-} -}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
module CoreMap( module CoreMap(
-- * Maps over Core expressions -- * Maps over Core expressions
CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap, CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap,
...@@ -33,6 +35,8 @@ module CoreMap( ...@@ -33,6 +35,8 @@ module CoreMap(
(>.>), (|>), (|>>), (>.>), (|>), (|>>),
) where ) where
#include "HsVersions.h"
import GhcPrelude import GhcPrelude
import TrieMap import TrieMap
...@@ -516,7 +520,7 @@ instance Eq (DeBruijn Type) where ...@@ -516,7 +520,7 @@ instance Eq (DeBruijn Type) where
-> D env t1 == D env' t1' && D env t2 == D env' t2' -> D env t1 == D env' t1' && D env t2 == D env' t2'
(s, AppTy t1' t2') | Just (t1, t2) <- repSplitAppTy_maybe s (s, AppTy t1' t2') | Just (t1, t2) <- repSplitAppTy_maybe s
-> D env t1 == D env' t1' && D env t2 == D env' t2' -> D env t1 == D env' t1' && D env t2 == D env' t2'
(FunTy t1 t2, FunTy t1' t2') (FunTy _ t1 t2, FunTy _ t1' t2')
-> D env t1 == D env' t1' && D env t2 == D env' t2' -> D env t1 == D env' t1' && D env t2 == D env' t2'
(TyConApp tc tys, TyConApp tc' tys') (TyConApp tc tys, TyConApp tc' tys')
-> tc == tc' && D env tys == D env' tys' -> tc == tc' && D env tys == D env' tys'
......
...@@ -1380,9 +1380,10 @@ isExpandableApp fn n_val_args ...@@ -1380,9 +1380,10 @@ isExpandableApp fn n_val_args
= True = True
| Just (bndr, ty) <- splitPiTy_maybe ty | Just (bndr, ty) <- splitPiTy_maybe ty
= caseBinder bndr = case bndr of
(\_tv -> all_pred_args n_val_args ty) Named {} -> all_pred_args n_val_args ty
(\bndr_ty -> isPredTy bndr_ty && all_pred_args (n_val_args-1) ty) Anon InvisArg _ -> all_pred_args (n_val_args-1) ty
Anon VisArg _ -> False
| otherwise | otherwise
= False = False
...@@ -1578,7 +1579,7 @@ app_ok primop_ok fun args ...@@ -1578,7 +1579,7 @@ app_ok primop_ok fun args
primop_arg_ok :: TyBinder -> CoreExpr -> Bool primop_arg_ok :: TyBinder -> CoreExpr -> Bool
primop_arg_ok (Named _) _ = True -- A type argument primop_arg_ok (Named _) _ = True -- A type argument
primop_arg_ok (Anon ty) arg -- A term argument primop_arg_ok (Anon _ ty) arg -- A term argument
| isUnliftedType ty = expr_ok primop_ok arg | isUnliftedType ty = expr_ok primop_ok arg
| otherwise = True -- See Note [Primops with lifted arguments] | otherwise = True -- See Note [Primops with lifted arguments]
......
...@@ -622,7 +622,7 @@ mkBuildExpr :: (MonadFail.MonadFail m, MonadThings m, MonadUnique m) ...@@ -622,7 +622,7 @@ mkBuildExpr :: (MonadFail.MonadFail m, MonadThings m, MonadUnique m)
mkBuildExpr elt_ty mk_build_inside = do mkBuildExpr elt_ty mk_build_inside = do
[n_tyvar] <- newTyVars [alphaTyVar] [n_tyvar] <- newTyVars [alphaTyVar]
let n_ty = mkTyVarTy n_tyvar let n_ty = mkTyVarTy n_tyvar
c_ty = mkFunTys [elt_ty, n_ty] n_ty c_ty = mkVisFunTys [elt_ty, n_ty] n_ty
[c, n] <- sequence [mkSysLocalM (fsLit "c") c_ty, mkSysLocalM (fsLit "n") n_ty] [c, n] <- sequence [mkSysLocalM (fsLit "c") c_ty, mkSysLocalM (fsLit "n") n_ty]
build_inside <- mk_build_inside (c, c_ty) (n, n_ty) build_inside <- mk_build_inside (c, c_ty) (n, n_ty)
...@@ -804,7 +804,7 @@ runtimeErrorTy :: Type ...@@ -804,7 +804,7 @@ runtimeErrorTy :: Type
-- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a -- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a
-- See Note [Error and friends have an "open-tyvar" forall] -- See Note [Error and friends have an "open-tyvar" forall]
runtimeErrorTy = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] runtimeErrorTy = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar]
(mkFunTy addrPrimTy openAlphaTy) (mkVisFunTy addrPrimTy openAlphaTy)
{- Note [Error and friends have an "open-tyvar" forall] {- Note [Error and friends have an "open-tyvar" forall]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
...@@ -894,7 +894,7 @@ be relying on anything from it. ...@@ -894,7 +894,7 @@ be relying on anything from it.
aBSENT_ERROR_ID aBSENT_ERROR_ID
= mkVanillaGlobalWithInfo absentErrorName absent_ty arity_info = mkVanillaGlobalWithInfo absentErrorName absent_ty arity_info
where where
absent_ty = mkSpecForAllTys [alphaTyVar] (mkFunTy addrPrimTy alphaTy) absent_ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy addrPrimTy alphaTy)
-- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for
-- lifted-type things; see Note [Absent errors] in WwLib -- lifted-type things; see Note [Absent errors] in WwLib
arity_info = vanillaIdInfo `setArityInfo` 1 arity_info = vanillaIdInfo `setArityInfo` 1
......
...@@ -120,7 +120,7 @@ mkFCall dflags uniq the_fcall val_args res_ty ...@@ -120,7 +120,7 @@ mkFCall dflags uniq the_fcall val_args res_ty
mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args
where where
arg_tys = map exprType val_args arg_tys = map exprType val_args
body_ty = (mkFunTys arg_tys res_ty) body_ty = (mkVisFunTys arg_tys res_ty)
tyvars = tyCoVarsOfTypeWellScoped body_ty tyvars = tyCoVarsOfTypeWellScoped body_ty
ty = mkInvForAllTys tyvars body_ty ty = mkInvForAllTys tyvars body_ty
the_fcall_id = mkFCallId dflags uniq the_fcall ty the_fcall_id = mkFCallId dflags uniq the_fcall ty
...@@ -251,7 +251,7 @@ boxResult result_ty ...@@ -251,7 +251,7 @@ boxResult result_ty
[the_alt] [the_alt]
] ]
; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) } ; return (realWorldStatePrimTy `mkVisFunTy` ccall_res_ty, wrap) }
boxResult result_ty boxResult result_ty
= do -- It isn't IO, so do unsafePerformIO = do -- It isn't IO, so do unsafePerformIO
...@@ -263,7 +263,7 @@ boxResult result_ty ...@@ -263,7 +263,7 @@ boxResult result_ty
ccall_res_ty ccall_res_ty
(coreAltType the_alt) (coreAltType the_alt)
[the_alt] [the_alt]
return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) return (realWorldStatePrimTy `mkVisFunTy` ccall_res_ty, wrap)
where where
return_result _ [ans] = ans return_result _ [ans] = ans
return_result _ _ = panic "return_result: expected single result" return_result _ _ = panic "return_result: expected single result"
......
...@@ -271,7 +271,7 @@ dsFCall fn_id co fcall mDeclHeader = do ...@@ -271,7 +271,7 @@ dsFCall fn_id co fcall mDeclHeader = do
return (fcall, empty) return (fcall, empty)
let let
-- Build the worker -- Build the worker
worker_ty = mkForAllTys tv_bndrs (mkFunTys (map idType work_arg_ids) ccall_result_ty) worker_ty = mkForAllTys tv_bndrs (mkVisFunTys (map idType work_arg_ids) ccall_result_ty)
tvs = map binderVar tv_bndrs tvs = map binderVar tv_bndrs
the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty
work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app) work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app)
...@@ -431,7 +431,7 @@ dsFExportDynamic id co0 cconv = do ...@@ -431,7 +431,7 @@ dsFExportDynamic id co0 cconv = do
stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName
let let
stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty] stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]
export_ty = mkFunTy stable_ptr_ty arg_ty export_ty = mkVisFunTy stable_ptr_ty arg_ty
bindIOId <- dsLookupGlobalId bindIOName bindIOId <- dsLookupGlobalId bindIOName
stbl_value <- newSysLocalDs stable_ptr_ty stbl_value <- newSysLocalDs stable_ptr_ty
(h_code, c_code, typestring, args_size) <- dsFExport id (mkRepReflCo export_ty) fe_nm cconv True (h_code, c_code, typestring, args_size) <- dsFExport id (mkRepReflCo export_ty) fe_nm cconv True
......
...@@ -282,7 +282,7 @@ deBindComp pat core_list1 quals core_list2 = do ...@@ -282,7 +282,7 @@ deBindComp pat core_list1 quals core_list2 = do
let u2_ty = hsLPatType pat let u2_ty = hsLPatType pat
let res_ty = exprType core_list2 let res_ty = exprType core_list2
h_ty = u1_ty `mkFunTy` res_ty h_ty = u1_ty `mkVisFunTy` res_ty
-- no levity polymorphism here, as list comprehensions don't work -- no levity polymorphism here, as list comprehensions don't work
-- with RebindableSyntax. NB: These are *not* monad comps. -- with RebindableSyntax. NB: These are *not* monad comps.
...@@ -425,7 +425,7 @@ mkZipBind elt_tys = do ...@@ -425,7 +425,7 @@ mkZipBind elt_tys = do
elt_tuple_ty = mkBigCoreTupTy elt_tys elt_tuple_ty = mkBigCoreTupTy elt_tys