summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/deSugar/Coverage.lhs3
-rw-r--r--compiler/deSugar/Desugar.lhs31
-rw-r--r--compiler/deSugar/DsExpr.lhs78
-rw-r--r--compiler/deSugar/DsMeta.hs9
-rw-r--r--compiler/deSugar/DsMonad.lhs22
-rw-r--r--compiler/deSugar/SPT.lhs88
-rw-r--r--compiler/ghc.cabal.in1
-rw-r--r--compiler/hsSyn/Convert.lhs1
-rw-r--r--compiler/hsSyn/HsExpr.lhs7
-rw-r--r--compiler/main/DynFlags.hs4
-rw-r--r--compiler/parser/Lexer.x7
-rw-r--r--compiler/parser/Parser.y2
-rw-r--r--compiler/prelude/PrelNames.lhs25
-rw-r--r--compiler/prelude/TysWiredIn.lhs86
-rw-r--r--compiler/rename/RnExpr.lhs33
-rw-r--r--compiler/typecheck/TcBinds.lhs2
-rw-r--r--compiler/typecheck/TcExpr.lhs30
-rw-r--r--compiler/typecheck/TcHsSyn.lhs4
-rw-r--r--compiler/typecheck/TcHsType.lhs2
-rw-r--r--compiler/typecheck/TcRnDriver.lhs65
-rw-r--r--compiler/typecheck/TcRnMonad.lhs6
-rw-r--r--compiler/typecheck/TcRnTypes.lhs24
-rw-r--r--compiler/typecheck/TcType.lhs2
-rw-r--r--compiler/typecheck/TcValidity.lhs1
24 files changed, 506 insertions, 27 deletions
diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 5e7289f00c..935f24e36b 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -534,6 +534,9 @@ addTickHsExpr (ExplicitPArr ty es) =
liftM2 ExplicitPArr
(return ty)
(mapM (addTickLHsExpr) es)
+
+addTickHsExpr e@(HsStatic _) = return e
+
addTickHsExpr (RecordCon id ty rec_binds) =
liftM3 RecordCon
(return id)
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index e2170e7dd4..2ec2aebbe8 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -49,6 +49,7 @@ import Coverage
import Util
import MonadUtils
import OrdList
+import SPT
import Data.List
import Data.IORef
import Control.Monad( when )
@@ -91,7 +92,8 @@ deSugar hsc_env
tcg_tcs = tcs,
tcg_insts = insts,
tcg_fam_insts = fam_insts,
- tcg_hpc = other_hpc_info })
+ tcg_hpc = other_hpc_info,
+ tcg_static_binds = static_binds_var })
= do { let dflags = hsc_dflags hsc_env
print_unqual = mkPrintUnqualified dflags rdr_env
@@ -121,23 +123,36 @@ deSugar hsc_env
; (ds_fords, foreign_prs) <- dsForeigns fords
; ds_rules <- mapMaybeM dsRule rules
; ds_vects <- mapM dsVect vects
+ ; stBinds <- dsGetStaticBindsVar >>= liftIO . readIORef
+ ; let core_prs' = core_prs `appOL` toOL stBinds
; let hpc_init
| gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
| otherwise = empty
+ ; -- Collects the sptEntries of the module
+ let spt_init = sptInitCode mod stBinds
; return ( ds_ev_binds
- , foreign_prs `appOL` core_prs `appOL` spec_prs
+ , foreign_prs `appOL` core_prs' `appOL` spec_prs
, spec_rules ++ ds_rules, ds_vects
- , ds_fords `appendStubC` hpc_init) }
+ , ds_fords `appendStubC` hpc_init `appendStubC` spt_init) }
; case mb_res of {
Nothing -> return (msgs, Nothing) ;
- Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) -> do
+ Just (ds_ev_binds, all_prs, {-st_binds,-} all_rules, vects0, ds_fords) ->
- do { -- Add export flags to bindings
- keep_alive <- readIORef keep_var
+ do { st_binds' <- readIORef static_binds_var
+ -- Add export flags to bindings
+ ; keep_alive <- readIORef keep_var
+ -- ; let static_names = map (map (idName . fst)) $ [ st_binds', st_binds ]
+ -- keep_alive_all = foldl addListToNameSet keep_alive static_names
; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules
- final_prs = addExportFlagsAndRules target export_set keep_alive
- rules_for_locals (fromOL all_prs)
+ final_prs = addExportFlagsAndRules
+ target export_set keep_alive
+ rules_for_locals $ fromOL $ all_prs
+
+ -- target export_set keep_alive_all
+ -- rules_for_locals $ fromOL $
+ -- all_prs `appOL`
+ -- toOL st_binds' `appOL` toOL st_binds
final_pgm = combineEvBinds ds_ev_binds final_prs
-- Notice that we put the whole lot in a big Rec, even the foreign binds
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index ce2d5a5d4a..e9c06fa812 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -62,6 +62,10 @@ import Bag
import Outputable
import FastString
+import IdInfo
+-- import Module ( HasModule(..), lookupWithDefaultModuleEnv, extendModuleEnv )
+import Data.IORef ( atomicModifyIORef, modifyIORef )
+
import Control.Monad
\end{code}
@@ -413,6 +417,51 @@ dsExpr (PArrSeq _ _)
\end{code}
\noindent
+\underline{\bf Static Pointers}
+% ~~~~~~~~~~~~~~~
+\begin{verbatim}
+ static f
+==>
+ StaticPtr (StaticName "pkg id of f" "module of f" "f")
+\end{verbatim}
+
+\begin{code}
+dsExpr (HsStatic expr@(L loc _)) = do
+ expr_ds <- dsLExpr expr
+ let ty = exprType expr_ds
+ case dropTypeApps expr_ds of
+ Var _ -> return ()
+ _ -> do
+ failWithDs $ cat
+ [ ptext (sLit "The argument of a static form can be only a name")
+ , ptext (sLit "but found: static") <+> parens (ppr expr)
+ ]
+ n' <- mkSptEntryName loc
+ static_binds_var <- dsGetStaticBindsVar
+
+ let mod = nameModule n'
+ pkgKey = modulePackageKey mod
+ pkgName = packageKeyString pkgKey
+
+ -- create static name
+ nm <- fmap (mkConApp staticNameDataCon) $
+ mapM mkStringExprFS
+ [ fsLit pkgName
+ , moduleNameFS $ moduleName mod
+ , occNameFS $ nameOccName n'
+ ]
+ let tvars = varSetElems $ tyVarsOfType ty
+ speId = mkExportedLocalId VanillaId n' staticSptEntryTy
+ spe = mkConApp staticSptEntryDataCon
+ [Type (mkForAllTys tvars ty), nm, mkLams tvars expr_ds]
+ liftIO $ modifyIORef static_binds_var ((speId, spe) :)
+ putSrcSpanDs loc $ return $ mkConApp staticPtrDataCon [Type ty, nm, expr_ds]
+ where
+ dropTypeApps (App e (Type _)) = dropTypeApps e
+ dropTypeApps e = e
+\end{code}
+
+\noindent
\underline{\bf Record construction and update}
% ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For record construction we do this (assuming T has three arguments)
@@ -887,3 +936,32 @@ badMonadBind rhs elt_ty flag_doc
2 (quotes $ ptext (sLit "_ <-") <+> ppr rhs)
, ptext (sLit "or by using the flag") <+> flag_doc ]
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Static pointers}
+%* *
+%************************************************************************
+
+
+-- mkStaticRhs :: CoreExpr ->
+
+\begin{code}
+mkSptEntryName :: SrcSpan -> DsM Name
+mkSptEntryName loc = do
+ uniq <- newUnique
+ mod <- getModule
+ occ <- mkWrapperName "sptEntry"
+ return $ mkExternalName uniq mod occ loc
+ where
+ mkWrapperName what
+ = do dflags <- getDynFlags
+ thisMod <- getModule
+ let -- Note [Generating fresh names for ccall wrapper]
+ -- in compiler/typecheck/TcEnv.hs
+ wrapperRef = nextWrapperNum dflags
+ wrapperNum <- liftIO $ atomicModifyIORef wrapperRef $ \mod_env ->
+ let num = lookupWithDefaultModuleEnv mod_env 0 thisMod
+ in (extendModuleEnv mod_env thisMod (num+1), num)
+ return $ mkVarOcc $ what ++ ":" ++ show wrapperNum
+\end{code}
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 083c466baa..e344070df1 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1075,6 +1075,7 @@ repE (ArithSeq _ _ aseq) =
repFromThenTo ds1 ds2 ds3
repE (HsSpliceE _ splice) = repSplice splice
+repE (HsStatic e) = repLE e >>= rep2 staticEName . (:[]) . unC
repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
@@ -2105,7 +2106,7 @@ templateHaskellNames = [
tupEName, unboxedTupEName,
condEName, multiIfEName, letEName, caseEName, doEName, compEName,
fromEName, fromThenEName, fromToEName, fromThenToEName,
- listEName, sigEName, recConEName, recUpdEName,
+ listEName, sigEName, recConEName, recUpdEName, staticEName,
-- FieldExp
fieldExpName,
-- Body
@@ -2287,7 +2288,7 @@ clauseName = libFun (fsLit "clause") clauseIdKey
varEName, conEName, litEName, appEName, infixEName, infixAppName,
sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,
unboxedTupEName, condEName, multiIfEName, letEName, caseEName,
- doEName, compEName :: Name
+ doEName, compEName, staticEName :: Name
varEName = libFun (fsLit "varE") varEIdKey
conEName = libFun (fsLit "conE") conEIdKey
litEName = libFun (fsLit "litE") litEIdKey
@@ -2318,6 +2319,7 @@ listEName = libFun (fsLit "listE") listEIdKey
sigEName = libFun (fsLit "sigE") sigEIdKey
recConEName = libFun (fsLit "recConE") recConEIdKey
recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey
+staticEName = libFun (fsLit "staticE") staticEIdKey
-- type FieldExp = ...
fieldExpName :: Name
@@ -2657,7 +2659,7 @@ varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
unboxedTupEIdKey, condEIdKey, multiIfEIdKey,
letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
- listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique
+ listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey :: Unique
varEIdKey = mkPreludeMiscIdUnique 270
conEIdKey = mkPreludeMiscIdUnique 271
litEIdKey = mkPreludeMiscIdUnique 272
@@ -2684,6 +2686,7 @@ listEIdKey = mkPreludeMiscIdUnique 292
sigEIdKey = mkPreludeMiscIdUnique 293
recConEIdKey = mkPreludeMiscIdUnique 294
recUpdEIdKey = mkPreludeMiscIdUnique 295
+staticEIdKey = mkPreludeMiscIdUnique 296
-- type FieldExp = ...
fieldExpIdKey :: Unique
diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs
index c017a7cc01..ea4f581880 100644
--- a/compiler/deSugar/DsMonad.lhs
+++ b/compiler/deSugar/DsMonad.lhs
@@ -21,7 +21,7 @@ module DsMonad (
mkPrintUnqualifiedDs,
newUnique,
UniqSupply, newUniqueSupply,
- getGhcModeDs, dsGetFamInstEnvs,
+ getGhcModeDs, dsGetFamInstEnvs, dsGetStaticBindsVar,
dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, dsLookupDataCon,
PArrBuiltin(..),
@@ -167,6 +167,8 @@ data DsGblEnv
-- exported entities of 'Data.Array.Parallel' iff
-- '-XParallelArrays' was given; otherwise, empty
, ds_parr_bi :: PArrBuiltin -- desugarar names for '-XParallelArrays'
+ , ds_static_binds :: IORef [(Id,CoreExpr)]
+ -- ^ Bindings resulted from floating static forms
}
instance ContainsModule DsGblEnv where
@@ -197,8 +199,11 @@ initDs :: HscEnv
initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside
= do { msg_var <- newIORef (emptyBag, emptyBag)
+ ; static_binds_var <- newIORef []
; let dflags = hsc_dflags hsc_env
- (ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var
+ (ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env
+ fam_inst_env msg_var
+ static_binds_var
; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
loadDAP $
@@ -276,12 +281,15 @@ initDsTc thing_inside
; let type_env = tcg_type_env tcg_env
rdr_env = tcg_rdr_env tcg_env
fam_inst_env = tcg_fam_inst_env tcg_env
- ds_envs = mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env msg_var
+ static_binds_var = tcg_static_binds tcg_env
+ ds_envs = mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env
+ msg_var static_binds_var
; setEnvs ds_envs thing_inside
}
-mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv -> IORef Messages -> (DsGblEnv, DsLclEnv)
-mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var
+mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
+ -> IORef Messages -> IORef [(Id, CoreExpr)] -> (DsGblEnv, DsLclEnv)
+mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var static_binds_var
= let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
if_lenv = mkIfLclEnv mod (ptext (sLit "GHC error in desugarer lookup in") <+> ppr mod)
gbl_env = DsGblEnv { ds_mod = mod
@@ -291,6 +299,7 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var
, ds_msgs = msg_var
, ds_dph_env = emptyGlobalRdrEnv
, ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi"
+ , ds_static_binds = static_binds_var
}
lcl_env = DsLclEnv { ds_meta = emptyNameEnv
, ds_loc = noSrcSpan
@@ -496,6 +505,9 @@ dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env
dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
dsExtendMetaEnv menv thing_inside
= updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
+
+dsGetStaticBindsVar :: DsM (IORef [(Id,CoreExpr)])
+dsGetStaticBindsVar = fmap ds_static_binds getGblEnv
\end{code}
\begin{code}
diff --git a/compiler/deSugar/SPT.lhs b/compiler/deSugar/SPT.lhs
new file mode 100644
index 0000000000..b5823413e0
--- /dev/null
+++ b/compiler/deSugar/SPT.lhs
@@ -0,0 +1,88 @@
+%
+% Code generation for the Static Pointer Table
+%
+% (c) 2014 I/O Tweag
+%
+\begin{code}
+module SPT (sptInitCode) where
+
+import CoreSyn
+import Module
+import Outputable
+import Id
+import Name
+import CLabel
+import FastString
+import Foreign.Ptr
+import GHC.Fingerprint
+import qualified Data.ByteString.Unsafe as BS
+import System.IO.Unsafe (unsafePerformIO)
+\end{code}
+
+Each module that uses 'static' keyword declares an initialization function of
+the form hs_spt_init_<module>() which is emitted into the _stub.c file and
+annotated with __attribute__((constructor)) so that it gets executed at startup
+time.
+
+The function's purpose is to call hs_spt_insert to insert the static
+pointers of this module in the hashtable of the RTS, and it looks something
+like this:
+
+static void hs_hpc_init_Main(void) __attribute__((constructor));
+static void hs_hpc_init_Main(void)
+{
+ extern StgPtr Main_sptEntryZC0_closure;
+ extern StgPtr Main_sptEntryZC1_closure;
+ hs_spt_insert( (StgWord64[2]){16252233376642134256ULL,7370534374097506082ULL}
+ , &Main_sptEntryZC0_closure
+ );
+ hs_spt_insert( (StgWord64[2]){12545634534567898323ULL,5409674567544156781ULL}
+ , &Main_sptEntryZC1_closure
+ );
+}
+
+where constants are values of a fingerprint of the triplet
+(package_id, module_name, sptEntry:N).
+
+\begin{code}
+sptInitCode :: Module -> [(Id,CoreExpr)] -> SDoc
+sptInitCode _ [] = Outputable.empty
+sptInitCode this_mod entries = vcat
+ [ text "static void hs_spt_init_" <> ppr this_mod
+ <> text "(void) __attribute__((constructor));"
+ , text "static void hs_spt_init_" <> ppr this_mod <> text "(void)"
+ , braces $ vcat $
+ [ ptext (sLit "extern StgPtr ")
+ <> (ppr $ mkClosureLabel (idName n) (idCafInfo n))
+ <> semi
+ | (n, _) <- entries ] ++
+ [ ptext (sLit "hs_spt_insert")
+ <> parens (hcat $ punctuate comma
+ [ pprFingerprint $ fingerprintId n
+ , ptext (sLit "&") <> ppr (mkClosureLabel (idName n) (idCafInfo n))
+ ])
+ <> semi
+ | (n, _) <- entries ]
+ ]
+\end{code}
+
+\begin{code}
+fingerprintId :: Id -> Fingerprint
+fingerprintId n =
+ fingerprintString (unpackFS name)
+ where
+ name = concatFS [ packageKeyFS $ modulePackageKey $ nameModule $ idName n
+ , fsLit ":"
+ , moduleNameFS (moduleName $ nameModule $ idName n)
+ , fsLit "."
+ , occNameFS $ occName $ idName n
+ ]
+
+pprFingerprint :: Fingerprint -> SDoc
+pprFingerprint (Fingerprint w1 w2) =
+ ptext (sLit "(StgWord64[2])")
+ <> (braces $ hcat $ punctuate comma [integer (fromIntegral w1) <> ptext (sLit "ULL")
+ ,integer (fromIntegral w2) <> ptext (sLit "ULL")
+ ])
+\end{code}
+
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 6422eb7ce9..6d167e5dba 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -319,6 +319,7 @@ Library
PlatformConstants
PprTyThing
StaticFlags
+ SPT
SysTools
TidyPgm
Ctype
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 9ad594c698..896bc69622 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -673,6 +673,7 @@ cvtl e = wrapL (cvt e)
cvt (RecUpdE e flds) = do { e' <- cvtl e
; flds' <- mapM cvtFld flds
; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] }
+ cvt (StaticE e) = fmap HsStatic $ cvtl e
{- Note [Dropping constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index eaac719df9..b9547db9b6 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -277,6 +277,10 @@ data HsExpr id
-- always has an empty stack
---------------------------------------
+ -- static pointers extension
+ | HsStatic (LHsExpr id)
+
+ ---------------------------------------
-- The following are commands, not expressions proper
-- They are only used in the parsing stage and are removed
-- immediately in parser.RdrHsSyn.checkCommand
@@ -567,6 +571,9 @@ ppr_expr (HsQuasiQuoteE qq) = ppr qq
ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
= hsep [ptext (sLit "proc"), ppr pat, ptext (sLit "->"), ppr cmd]
+ppr_expr (HsStatic e)
+ = hsep [ptext (sLit "static"), pprParendExpr e]
+
ppr_expr (HsTick tickish exp)
= pprTicks (ppr exp) $
ppr tickish <+> ppr exp
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 043174f3b0..e170b8f72c 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -604,6 +604,7 @@ data ExtensionFlag
| Opt_NegativeLiterals
| Opt_EmptyCase
| Opt_PatternSynonyms
+ | Opt_StaticPointers
deriving (Eq, Enum, Show)
data SigOf = NotSigOf
@@ -2960,7 +2961,8 @@ xFlags = [
( "UndecidableInstances", Opt_UndecidableInstances, nop ),
( "UnicodeSyntax", Opt_UnicodeSyntax, nop ),
( "UnliftedFFITypes", Opt_UnliftedFFITypes, nop ),
- ( "ViewPatterns", Opt_ViewPatterns, nop )
+ ( "ViewPatterns", Opt_ViewPatterns, nop ),
+ ( "StaticPointers", Opt_StaticPointers, nop )
]
defaultFlags :: Settings -> [GeneralFlag]
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 6d05bb9d6d..d2803dbc3f 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -545,6 +545,7 @@ data Token
| ITby
| ITusing
| ITpattern
+ | ITstatic
-- Pragmas
| ITinline_prag InlineSpec RuleMatchInfo
@@ -728,6 +729,7 @@ reservedWordsFM = listToUFM $
( "family", ITfamily, 0 ),
( "role", ITrole, 0 ),
( "pattern", ITpattern, xbit PatternSynonymsBit),
+ ( "static", ITstatic, 0 ),
( "group", ITgroup, xbit TransformComprehensionsBit),
( "by", ITby, xbit TransformComprehensionsBit),
( "using", ITusing, xbit TransformComprehensionsBit),
@@ -1100,6 +1102,11 @@ varid span buf len =
return ITcase
maybe_layout keyword
return $ L span keyword
+ Just (ITstatic, _) -> do
+ flags <- getDynFlags
+ if xopt Opt_StaticPointers flags
+ then return $ L span ITstatic
+ else return $ L span $ ITvarid fs
Just (keyword, 0) -> do
maybe_layout keyword
return $ L span keyword
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 2e1b777bb3..096d1d998b 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -273,6 +273,7 @@ incorrect.
'by' { L _ ITby } -- for list transform extension
'using' { L _ ITusing } -- for list transform extension
'pattern' { L _ ITpattern } -- for pattern synonyms
+ 'static' { L _ ITstatic } -- for static pointers extension
'{-# INLINE' { L _ (ITinline_prag _ _) }
'{-# SPECIALISE' { L _ ITspec_prag }
@@ -1599,6 +1600,7 @@ hpc_annot :: { Located (FastString,(Int,Int),(Int,Int)) }
fexp :: { LHsExpr RdrName }
: fexp aexp { sLL $1 $> $ HsApp $1 $2 }
+ | 'static' aexp { sLL $1 $> $ HsStatic $2 }
| aexp { $1 }
aexp :: { LHsExpr RdrName }
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 6e40546d2c..e7464a2a19 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -452,6 +452,9 @@ gHC_IP = mkBaseModule (fsLit "GHC.IP")
gHC_PARR' :: Module
gHC_PARR' = mkBaseModule (fsLit "GHC.PArr")
+gHC_STATICPTR :: Module
+gHC_STATICPTR = mkBaseModule (fsLit "GHC.StaticPtr")
+
mAIN, rOOT_MAIN :: Module
mAIN = mkMainModule_ mAIN_NAME
rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation
@@ -1483,6 +1486,18 @@ specTyConKey = mkPreludeTyConUnique 177
smallArrayPrimTyConKey = mkPreludeTyConUnique 178
smallMutableArrayPrimTyConKey = mkPreludeTyConUnique 179
+staticPtrTyConKey :: Unique
+staticPtrTyConKey = mkPreludeTyConUnique 180
+
+staticNameTyConKey :: Unique
+staticNameTyConKey = mkPreludeTyConUnique 181
+
+staticSptEntryTyConKey :: Unique
+staticSptEntryTyConKey = mkPreludeTyConUnique 182
+
+staticSptEntryConKey :: Unique
+staticSptEntryConKey = mkPreludeTyConUnique 183
+
---------------- Template Haskell -------------------
-- USES TyConUniques 200-299
-----------------------------------------------------
@@ -1545,6 +1560,16 @@ eqDataConKey = mkPreludeDataConUnique 28
gtDataConKey = mkPreludeDataConUnique 29
coercibleDataConKey = mkPreludeDataConUnique 32
+
+staticPtrDataConKey :: Unique
+staticPtrDataConKey = mkPreludeDataConUnique 33
+
+staticNameDataConKey :: Unique
+staticNameDataConKey = mkPreludeDataConUnique 34
+
+staticSptConKey :: Unique
+staticSptConKey = mkPreludeDataConUnique 35
+
\end{code}
%************************************************************************
diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs
index f4dca9a0de..e7dd7df46c 100644
--- a/compiler/prelude/TysWiredIn.lhs
+++ b/compiler/prelude/TysWiredIn.lhs
@@ -1,4 +1,4 @@
-%
+, alpha%
% (c) The GRASP Project, Glasgow University, 1994-1998
%
\section[TysWiredIn]{Wired-in knowledge about {\em non-primitive} types}
@@ -67,6 +67,12 @@ module TysWiredIn (
parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon,
parrTyCon_RDR, parrTyConName,
+ -- * StaticPtr
+ staticPtrTyCon, staticPtrTyConName,
+ staticPtrDataCon, staticNameDataCon,
+ staticSptEntryTy, staticSptEntryTyCon,
+ staticSptEntryTyConName, staticSptEntryDataCon,
+
-- * Equality predicates
eqTyCon_RDR, eqTyCon, eqTyConName, eqBoxDataCon,
coercibleTyCon, coercibleDataCon, coercibleClass,
@@ -151,6 +157,8 @@ wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because
, wordTyCon
, listTyCon
, parrTyCon
+ , staticPtrTyCon
+ , staticNameTyCon
, eqTyCon
, coercibleTyCon
, typeNatKindCon
@@ -216,6 +224,24 @@ parrTyConName = mkWiredInTyConName BuiltInSyntax
parrDataConName = mkWiredInDataConName UserSyntax
gHC_PARR' (fsLit "PArr") parrDataConKey parrDataCon
+staticPtrTyConName, staticPtrDataConName :: Name
+staticPtrTyConName = mkWiredInTyConName UserSyntax
+ gHC_STATICPTR (fsLit "StaticPtr") staticPtrTyConKey staticPtrTyCon
+staticPtrDataConName = mkWiredInDataConName UserSyntax
+ gHC_STATICPTR (fsLit "StaticPtr") staticPtrDataConKey staticPtrDataCon
+
+staticNameTyConName, staticNameDataConName :: Name
+staticNameTyConName = mkWiredInTyConName UserSyntax
+ gHC_STATICPTR (fsLit "StaticName") staticNameTyConKey staticNameTyCon
+staticNameDataConName = mkWiredInDataConName UserSyntax
+ gHC_STATICPTR (fsLit "StaticName") staticNameDataConKey staticNameDataCon
+
+staticSptEntryTyConName, staticSptEntryDataConName :: Name
+staticSptEntryTyConName = mkWiredInTyConName UserSyntax
+ gHC_STATICPTR (fsLit "SptEntry") staticSptEntryTyConKey staticSptEntryTyCon
+staticSptEntryDataConName = mkWiredInDataConName UserSyntax
+ gHC_STATICPTR (fsLit "SptEntry") staticSptEntryConKey staticNameDataCon
+
boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR,
intDataCon_RDR, listTyCon_RDR, consDataCon_RDR, parrTyCon_RDR, eqTyCon_RDR :: RdrName
boolTyCon_RDR = nameRdrName boolTyConName
@@ -850,6 +876,64 @@ isPArrFakeCon :: DataCon -> Bool
isPArrFakeCon dcon = dcon == parrFakeCon (dataConSourceArity dcon)
\end{code}
+StaticPtr
+
+\begin{code}
+staticPtrTyCon :: TyCon
+staticPtrTyCon =
+ pcNonRecDataTyCon staticPtrTyConName Nothing alpha_tyvar [staticPtrDataCon]
+
+staticPtrDataCon :: DataCon
+staticPtrDataCon =
+ pcDataCon staticPtrDataConName alpha_tyvar [staticNameTy, alphaTy] staticPtrTyCon
+
+staticNameTy :: Type
+staticNameTy = mkTyConTy staticNameTyCon
+
+staticNameTyCon :: TyCon
+staticNameTyCon =
+ pcNonRecDataTyCon staticNameTyConName Nothing [] [staticNameDataCon]
+
+staticNameDataCon :: DataCon
+staticNameDataCon =
+ pcDataCon staticNameDataConName [] (replicate 3 stringTy) staticNameTyCon
+
+staticSptEntryTy :: Type
+staticSptEntryTy = mkTyConTy staticSptEntryTyCon
+
+staticSptEntryTyCon :: TyCon
+staticSptEntryTyCon =
+ pcNonRecDataTyCon staticSptEntryTyConName Nothing [] [staticSptEntryDataCon]
+
+staticSptEntryDataCon :: DataCon
+staticSptEntryDataCon =
+ let dc_name = staticSptEntryDataConName
+ arg_tys = [ staticNameTy, alphaTy ]
+ modu = ASSERT( isExternalName dc_name )
+ nameModule dc_name
+ wrk_key = incrUnique (nameUnique dc_name)
+ wrk_occ = mkDataConWorkerOcc (nameOccName dc_name)
+ wrk_name = mkWiredInName modu wrk_occ wrk_key
+ (AnId (dataConWorkId data_con)) UserSyntax
+ data_con = mkDataCon
+ dc_name
+ False
+ (map (const HsNoBang) arg_tys)
+ [] -- No labelled fields
+ [] -- No univerally quantified type variables
+ [alphaTyVar] -- Existentially quantified type variables
+ [] -- No equality spec
+ [] -- No theta
+ arg_tys -- Argument types
+ staticSptEntryTy -- Result type
+ staticSptEntryTyCon -- Representation type constructor
+ [] -- No stupid theta
+ (mkDataConWorkId wrk_name data_con) -- Worker Id
+ NoDataConRep -- No data constructor representation
+
+ in data_con
+\end{code}
+
Promoted Booleans
\begin{code}
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index b24956c85e..be9d9116d8 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -310,6 +310,39 @@ rnExpr e@(ELazyPat {}) = patSynErr e
%************************************************************************
%* *
+ Static values
+%* *
+%************************************************************************
+
+For the static form we check that the free variables are all top-level
+value bindings. This is done by checking that the name is external or
+wired-in. See the Note about the NameSorts in Name.lhs.
+
+\begin{code}
+rnExpr e@(HsStatic expr) = do
+ (expr',fvExpr) <- rnLExpr expr
+ stage <- getStage
+ case stage of
+ Brack _ _ -> return () -- Don't check names if we are inside brackets.
+ -- We don't want to reject cases like:
+ -- \e -> [| static $(e) |]
+ -- if $(e) turns out to produce a legal expression.
+ _ -> do
+ let isTopLevelName n = isExternalName n || isWiredInName n
+ case nameSetToList $ filterNameSet (not . isTopLevelName) fvExpr of
+ [] -> return ()
+ fvNonGlobal -> addErr $ cat
+ [ ptext $ sLit $ "Only identifiers of top-level bindings can "
+ ++ "appear in the body of the static form:"
+ , nest 2 $ ppr e
+ , ptext $ sLit "but the following identifiers were found instead:"
+ , nest 2 $ vcat $ map ppr fvNonGlobal
+ ]
+ return (HsStatic expr', fvExpr)
+\end{code}
+
+%************************************************************************
+%* *
Arrow notation
%* *
%************************************************************************
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index c2af40703d..26c6e76f3d 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -12,7 +12,7 @@ module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
PragFun, tcSpecPrags, tcVectDecls, mkPragFun,
TcSigInfo(..), TcSigFun,
instTcTySig, instTcTySigFromId, findScopedTyVars,
- badBootDeclErr ) where
+ badBootDeclErr, mkExport ) where
import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
import {-# SOURCE #-} TcExpr ( tcMonoExpr )
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index a242ed77d2..ee73e5dc9f 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -23,6 +23,7 @@ import HsSyn
import TcHsSyn
import TcRnMonad
import TcUnify
+import TcValidity
import BasicTypes
import Inst
import TcBinds
@@ -38,6 +39,9 @@ import DsMonad hiding (Splice)
import Id
import ConLike
import DataCon
+-- import IdInfo
+-- import Module ( HasModule(..), lookupWithDefaultModuleEnv, extendModuleEnv )
+-- import Data.IORef ( atomicModifyIORef )
import PatSyn
import RdrName
import Name
@@ -484,6 +488,32 @@ tcExpr (HsDo do_or_lc stmts _) res_ty
tcExpr (HsProc pat cmd) res_ty
= do { (pat', cmd', coi) <- tcProc pat cmd res_ty
; return $ mkHsWrapCo coi (HsProc pat' cmd') }
+
+tcExpr (HsStatic expr@(L loc _)) res_ty
+ = do { (co, [expr_ty]) <- matchExpectedTyConApp staticPtrTyCon res_ty
+ ; (((expr',errCtx), untch), lie) <- captureConstraints $
+ captureUntouchables $
+ addErrCtxt (hang (ptext (sLit "In the body of a static form:"))
+ 2 (ppr expr)
+ ) $
+ liftM2 (,) (tcPolyExprNC expr expr_ty) getErrCtxt
+ ; lieTcRef <- tcl_lie <$> getLclEnv
+ ; updTcRef lieTcRef (`andWC` lie)
+ -- Keep the name in case it is not used anywhere else.
+ ; case expr of
+ L _ (HsVar n) -> keepAlive n
+ _ -> return ()
+ -- Require the type of the argument to be Typeable.
+ ; (typeableClass, _) <- tcClass typeableClassName
+ ; _ <- instCall StaticOrigin [expr_ty]
+ [ mkTyConApp (classTyCon typeableClass)
+ [liftedTypeKind, expr_ty]
+ ]
+ -- Insert the static form in a global list for later validation.
+ ; stOccsVar <- tcg_static_occs <$> getGblEnv
+ ; updTcRef stOccsVar ((expr_ty, lie, untch, loc, errCtx) :)
+ ; return $ mkHsWrapCo co $ HsStatic expr'
+ }
\end{code}
Note [Rebindable syntax for if]
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 1a91f10e66..23407639f2 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -736,6 +736,10 @@ zonkExpr env (HsProc pat body)
; new_body <- zonkCmdTop env1 body
; return (HsProc new_pat new_body) }
+-- StaticPointers extension
+zonkExpr env (HsStatic expr)
+ = HsStatic <$> zonkLExpr env expr
+
zonkExpr env (HsWrap co_fn expr)
= do (env1, new_co_fn) <- zonkCoFn env co_fn
new_expr <- zonkExpr env1 expr
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index d6f237f64f..c6363c9811 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -15,7 +15,7 @@ module TcHsType (
-- Type checking type and class decls
kcLookupKind, kcTyClTyVars, tcTyClTyVars,
tcHsConArgType, tcDataKindSig,
- tcClassSigType,
+ tcClassSigType, tcClass,
-- Kind-checking types
-- No kind generalisation, no checkValidType
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 893e0290da..730db77c7b 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -37,6 +37,9 @@ import TcHsSyn
import TcExpr
import TcRnMonad
import TcEvidence
+import TcType (Untouchables)
+import TysWiredIn (staticPtrTyCon)
+import TcValidity
import PprTyThing( pprTyThing )
import Coercion( pprCoAxiom )
import FamInst
@@ -473,6 +476,12 @@ tcRnSrcDecls boot_iface decls
simplifyTop lie ;
traceTc "Tc9" empty ;
+ failIfErrsM ;
+
+ ((), lie2) <- captureConstraints checkStaticPointers ;
+ new_ev_binds2 <- {-# SCC "simplifyTop" #-}
+ simplifyTop lie2 ;
+
failIfErrsM ; -- Don't zonk if there have been errors
-- It's a waste of time; and we may get debug warnings
-- about strangely-typed TyCons!
@@ -488,7 +497,8 @@ tcRnSrcDecls boot_iface decls
tcg_rules = rules,
tcg_vects = vects,
tcg_fords = fords } = tcg_env
- ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ;
+ ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds
+ `unionBags` new_ev_binds2 } ;
(bind_ids, ev_binds', binds', fords', imp_specs', rules', vects')
<- {-# SCC "zonkTopDecls" #-}
@@ -1641,8 +1651,11 @@ tcGhciStmts stmts
-- OK, we're ready to typecheck the stmts
traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
((tc_stmts, ids), lie) <- captureConstraints $
- tc_io_stmts $ \ _ ->
- mapM tcLookupId names ;
+ (tc_io_stmts $ \ _ ->
+ mapM tcLookupId names)
+ -- Ignore bindings for static pointers
+ <* checkStaticPointers ;
+
-- Look up the names right in the middle,
-- where they will all be in scope
@@ -1731,6 +1744,8 @@ tcRnExpr hsc_env rdr_expr
captureUntouchables $
tcInferRho rn_expr ;
((qtvs, dicts, _, _), lie_top) <- captureConstraints $
+ -- Ignore bindings for static pointers
+ checkStaticPointers >>
{-# SCC "simplifyInfer" #-}
simplifyInfer untch
False {- No MR for now -}
@@ -1817,8 +1832,13 @@ tcRnDeclsi hsc_env local_decls =
new_ev_binds <- simplifyTop lie
failIfErrsM
- let TcGblEnv { tcg_type_env = type_env,
- tcg_binds = binds,
+ ((), lie2) <- captureConstraints checkStaticPointers
+ new_ev_binds2 <- {-# SCC "simplifyTop" #-}
+ simplifyTop lie2
+
+ failIfErrsM
+ let TcGblEnv { tcg_binds = binds,
+ tcg_type_env = type_env,
tcg_sigs = sig_ns,
tcg_ev_binds = cur_ev_binds,
tcg_imp_specs = imp_specs,
@@ -1826,6 +1846,7 @@ tcRnDeclsi hsc_env local_decls =
tcg_vects = vects,
tcg_fords = fords } = tcg_env
all_ev_binds = cur_ev_binds `unionBags` new_ev_binds
+ `unionBags` new_ev_binds2
(bind_ids, ev_binds', binds', fords', imp_specs', rules', vects')
<- zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords
@@ -2090,3 +2111,37 @@ ppr_tydecls tycons
where
ppr_tycon tycon = vcat [ ppr (tyThingToIfaceDecl (ATyCon tycon)) ]
\end{code}
+
+%************************************************************************
+%* *
+ checkStaticPointers
+%* *
+%************************************************************************
+
+\begin{code}
+-- | Checks that the static forms have valid types when generalized.
+--
+-- The type @StaticPtr tau@ is valid if it is predicative, that is, tau is unqualified
+-- and monomorphic.
+--
+checkStaticPointers :: TcM ()
+checkStaticPointers = do
+ stOccsVar <- tcg_static_occs <$> getGblEnv
+ stOccs <- readTcRef stOccsVar
+ writeTcRef stOccsVar []
+ mapM_ checkStaticPointer stOccs
+ where
+ checkStaticPointer ::
+ (TcType, WantedConstraints, Untouchables, SrcSpan, [ErrCtxt]) -> TcM ()
+ checkStaticPointer (ty, lie, untch, loc, errCtx) =
+ setSrcSpan loc $ setErrCtxt errCtx $ do
+ fresh_name <- newSysName $ mkVarOccFS $ fsLit "static"
+ (_, dicts, _, _) <- simplifyInfer untch
+ False -- No MR
+ [(fresh_name, ty)]
+ lie
+
+ let expr_qty = mkPiTypes dicts ty
+ zty <- zonkTcType $ mkTyConApp staticPtrTyCon [ expr_qty ]
+ void $ tryM $ checkValidType StaticCtxt zty
+\end{code}
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index cd414999af..e2f032fbfe 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -97,6 +97,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
Nothing -> newIORef emptyNameEnv } ;
dependent_files_var <- newIORef [] ;
+ static_occs_var <- newIORef [] ;
+ static_binds_var <- newIORef [] ;
#ifdef GHCI
th_topdecls_var <- newIORef [] ;
th_topnames_var <- newIORef emptyNameSet ;
@@ -162,7 +164,9 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
tcg_hpc = False,
tcg_main = Nothing,
tcg_safeInfer = infer_var,
- tcg_dependent_files = dependent_files_var
+ tcg_dependent_files = dependent_files_var,
+ tcg_static_occs = static_occs_var,
+ tcg_static_binds = static_binds_var
} ;
lcl_env = TcLclEnv {
tcl_errs = errs_var,
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index e1762a8f73..bcaad8925d 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -87,6 +87,7 @@ module TcRnTypes(
#include "HsVersions.h"
import HsSyn
+import CoreSyn
import HscTypes
import TcEvidence
import Type
@@ -283,6 +284,8 @@ data TcGblEnv
-- rule
--
-- * Top-level variables appearing free in a TH bracket
+ --
+ -- * Top-level variables introduced by the static form
tcg_th_used :: TcRef Bool,
-- ^ @True@ <=> Template Haskell syntax used.
@@ -354,9 +357,26 @@ data TcGblEnv
tcg_main :: Maybe Name, -- ^ The Name of the main
-- function, if this module is
-- the main module.
- tcg_safeInfer :: TcRef Bool -- Has the typechecker
+ tcg_safeInfer :: TcRef Bool, -- Has the typechecker
-- inferred this module
-- as -XSafe (Safe Haskell)
+ tcg_static_occs :: TcRef [( TcType
+ , WantedConstraints
+ , Untouchables
+ , SrcSpan
+ , [ErrCtxt]
+ )],
+ -- ^ Occurrences of static forms
+ --
+ -- Each entry holds the type of the body of the static form,
+ -- the constraints the body requires, the location of the static
+ -- form and the error context to use when reporting errors.
+
+ tcg_static_binds :: IORef [(Id,CoreExpr)]
+ -- ^ Bindings resulted from floating static forms
+ --
+ -- The typechecker needs to carry this information when desugaring
+ -- splices that contain static forms.
}
-- Note [Signature parameters in TcGblEnv and DynFlags]
@@ -1875,6 +1895,7 @@ data CtOrigin
| HoleOrigin
| UnboundOccurrenceOf RdrName
| ListOrigin -- An overloaded list
+ | StaticOrigin -- A static form
ctoHerald :: SDoc
ctoHerald = ptext (sLit "arising from")
@@ -1953,5 +1974,6 @@ pprCtO (TypeEqOrigin t1 t2) = ptext (sLit "a type equality") <+> sep [ppr t1, c
pprCtO AnnOrigin = ptext (sLit "an annotation")
pprCtO HoleOrigin = ptext (sLit "a use of") <+> quotes (ptext $ sLit "_")
pprCtO ListOrigin = ptext (sLit "an overloaded list")
+pprCtO StaticOrigin = ptext (sLit "a static form")
pprCtO _ = panic "pprCtOrigin"
\end{code}
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index dba1be8964..cfbbb918a8 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -379,6 +379,7 @@ data UserTypeCtxt
-- e.g. (f e) where f has a higher-rank type
-- We might want to elaborate this
| GhciCtxt -- GHCi command :kind <type>
+ | StaticCtxt -- Static form
| ClassSCCtxt Name -- Superclasses of a class
| SigmaCtxt -- Theta part of a normal for-all type
@@ -534,6 +535,7 @@ pprUserTypeCtxt InstDeclCtxt = ptext (sLit "an instance declaration")
pprUserTypeCtxt SpecInstCtxt = ptext (sLit "a SPECIALISE instance pragma")
pprUserTypeCtxt GenSigCtxt = ptext (sLit "a type expected by the context")
pprUserTypeCtxt GhciCtxt = ptext (sLit "a type in a GHCi command")
+pprUserTypeCtxt StaticCtxt = ptext (sLit "a static form")
pprUserTypeCtxt (ClassSCCtxt c) = ptext (sLit "the super-classes of class") <+> quotes (ppr c)
pprUserTypeCtxt SigmaCtxt = ptext (sLit "the context of a polymorphic type")
pprUserTypeCtxt (DataTyCtxt tc) = ptext (sLit "the context of the data type declaration for") <+> quotes (ppr tc)
diff --git a/compiler/typecheck/TcValidity.lhs b/compiler/typecheck/TcValidity.lhs
index 8381533a28..d7e568b7e9 100644
--- a/compiler/typecheck/TcValidity.lhs
+++ b/compiler/typecheck/TcValidity.lhs
@@ -175,6 +175,7 @@ checkValidType ctxt ty
SpecInstCtxt -> rank1
ThBrackCtxt -> rank1
GhciCtxt -> ArbitraryRank
+ StaticCtxt -> MustBeMonoType
_ -> panic "checkValidType"
-- Can't happen; not used for *user* sigs
View Lorry Controller Status