Commit 9d787ef5 authored by keithw's avatar keithw
Browse files

[project @ 1999-07-15 14:08:03 by keithw]

This commit makes a start at implementing polymorphic usage
annotations.

* The module Type has now been split into TypeRep, containing the
  representation Type(..) and other information for `friends' only,
  and Type, providing the public interface to Type.  Due to a bug in
  the interface-file slurping prior to ghc-4.04, {-# SOURCE #-}
  dependencies must unfortunately still refer to TypeRep even though
  they are not friends.

* Unfoldings in interface files now print as __U instead of __u.
  UpdateInfo now prints as __UA instead of __U.

* A new sort of variables, UVar, in their own namespace, uvName, has
  been introduced for usage variables.

* Usage binders __fuall uv have been introduced.  Usage annotations
  are now __u - ty (used once), __u ! ty (used possibly many times),
  __u uv ty (used uv times), where uv is a UVar.  __o and __m have
  gone.  All this still lives only in a TyNote, *for now* (but not for
  much longer).

* Variance calculation for TyCons has moved from
  typecheck/TcTyClsDecls to types/Variance.

* Usage annotation and inference are now done together in a single
  pass.  Provision has been made for inferring polymorphic usage
  annotations (with __fuall) but this has not yet been implemented.
  Watch this space!
parent 5c60f4ca
......@@ -3,4 +3,4 @@ _exports_
DataCon DataCon dataConType ;
_declarations_
1 data DataCon ;
1 dataConType _:_ DataCon -> Type.Type ;;
1 dataConType _:_ DataCon -> TypeRep.Type ;;
__interface DataCon 1 0 where
__export DataCon DataCon dataConType ;
1 data DataCon ;
1 dataConType :: DataCon -> Type.Type ;
1 dataConType :: DataCon -> TypeRep.Type ;
......@@ -8,7 +8,7 @@ module FieldLabel where
#include "HsVersions.h"
import {-# SOURCE #-} Type( Type ) -- FieldLabel is compiled very early
import {-# SOURCE #-} TypeRep( Type ) -- FieldLabel is compiled very early
import Name ( Name{-instance Eq/Outputable-}, NamedThing(..), nameUnique )
import Outputable
......
......@@ -346,6 +346,7 @@ seqInlinePrag other
= ()
instance Outputable InlinePragInfo where
-- only used for debugging; never parsed. KSW 1999-07
ppr NoInlinePragInfo = empty
ppr IMustBeINLINEd = ptext SLIT("__UU")
ppr IMustNotBeINLINEd = ptext SLIT("__Unot")
......@@ -500,7 +501,8 @@ Text instance so that the update annotations can be read in.
\begin{code}
ppUpdateInfo NoUpdateInfo = empty
ppUpdateInfo (SomeUpdateInfo []) = empty
ppUpdateInfo (SomeUpdateInfo spec) = (<>) (ptext SLIT("__U ")) (hcat (map int spec))
ppUpdateInfo (SomeUpdateInfo spec) = (<>) (ptext SLIT("__UA ")) (hcat (map int spec))
-- was "__U "; changed to avoid conflict with unfoldings. KSW 1999-07.
\end{code}
%************************************************************************
......
......@@ -353,7 +353,7 @@ mkNewTySelId field_label selector_ty = sel_id
[data_id] = mkTemplateLocals [data_ty]
sel_rhs = mkLams tyvars $ Lam data_id $
Note (Coerce rhs_ty data_ty) (Var data_id)
Note (Coerce (unUsgTy rhs_ty) (unUsgTy data_ty)) (Var data_id)
\end{code}
......
......@@ -8,7 +8,7 @@
module OccName (
-- The NameSpace type; abstact
NameSpace, tcName, clsName, tcClsName, dataName, varName, tvName,
nameSpaceString,
uvName, nameSpaceString,
-- The OccName type
OccName, -- Abstract, instance of Outputable
......@@ -19,7 +19,7 @@ module OccName (
mkDictOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc,
mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc,
isTvOcc, isDataOcc, isDataSymOcc, isSymOcc,
isTvOcc, isUvOcc, isDataOcc, isDataSymOcc, isSymOcc,
occNameFS, occNameString, occNameUserString, occNameSpace, occNameFlavour,
setOccNameSpace,
......@@ -84,6 +84,7 @@ pprEncodedFS fs
data NameSpace = VarName -- Variables
| DataName -- Data constructors
| TvName -- Type variables
| UvName -- Usage variables
| TcClsName -- Type constructors and classes; Haskell has them
-- in the same name space for now.
deriving( Eq, Ord )
......@@ -96,6 +97,7 @@ tcClsName = TcClsName -- Not sure which!
dataName = DataName
tvName = TvName
uvName = UvName
varName = VarName
......@@ -103,6 +105,7 @@ nameSpaceString :: NameSpace -> String
nameSpaceString DataName = "Data constructor"
nameSpaceString VarName = "Variable"
nameSpaceString TvName = "Type variable"
nameSpaceString UvName = "Usage variable"
nameSpaceString TcClsName = "Type constructor or class"
\end{code}
......@@ -211,11 +214,14 @@ occNameFlavour (OccName sp _) = nameSpaceString sp
\end{code}
\begin{code}
isTvOcc, isDataSymOcc, isSymOcc :: OccName -> Bool
isTvOcc, isDataSymOcc, isSymOcc, isUvOcc :: OccName -> Bool
isTvOcc (OccName TvName _) = True
isTvOcc other = False
isUvOcc (OccName UvName _) = True
isUvOcc other = False
-- Data constructor operator (starts with ':', or '[]')
-- Pretty inefficient!
isDataSymOcc (OccName DataName s) = isLexConSym (decodeFS s)
......
......@@ -21,7 +21,7 @@ module Var (
-- UVars
UVar,
isUVar,
mkUVar,
mkUVar, mkNamedUVar,
-- Ids
Id, DictId,
......@@ -32,7 +32,7 @@ module Var (
#include "HsVersions.h"
import {-# SOURCE #-} Type( Type, Kind )
import {-# SOURCE #-} TypeRep( Type, Kind )
import {-# SOURCE #-} IdInfo( IdInfo, seqIdInfo )
import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey )
......@@ -232,6 +232,16 @@ mkUVar :: Unique -> UVar
mkUVar unique = Var { varName = mkSysLocalName unique SLIT("u"),
realUnique = getKey unique,
varDetails = UVar }
mkNamedUVar :: Name -> UVar
mkNamedUVar name = Var { varName = name
, realUnique = getKey (nameUnique name)
, varDetails = UVar
#ifdef DEBUG
, varType = pprPanic "looking at Type of a uvar" (ppr name)
, varInfo = pprPanic "looking at IdInfo of a uvar" (ppr name)
#endif
}
\end{code}
\begin{code}
......
......@@ -28,7 +28,7 @@ module VarEnv (
#include "HsVersions.h"
import {-# SOURCE #-} CoreSyn( CoreExpr )
import {-# SOURCE #-} Type( Type )
import {-# SOURCE #-} TypeRep( Type )
import OccName ( TidyOccEnv, emptyTidyOccEnv )
import Var ( Var, Id, IdOrTyVar )
......
......@@ -5,7 +5,7 @@
\begin{code}
module VarSet (
VarSet, IdSet, TyVarSet, IdOrTyVarSet,
VarSet, IdSet, TyVarSet, IdOrTyVarSet, UVarSet,
emptyVarSet, unitVarSet, mkVarSet,
extendVarSet,
elemVarSet, varSetElems, subVarSet,
......@@ -21,7 +21,7 @@ module VarSet (
#include "HsVersions.h"
import CmdLineOpts ( opt_PprStyle_Debug )
import Var ( Var, Id, TyVar, IdOrTyVar, setVarUnique )
import Var ( Var, Id, TyVar, UVar, IdOrTyVar, setVarUnique )
import Unique ( Unique, Uniquable(..), incrUnique, deriveUnique )
import UniqSet
import UniqFM ( delFromUFM_Directly )
......@@ -39,6 +39,7 @@ type VarSet = UniqSet Var
type IdSet = UniqSet Id
type TyVarSet = UniqSet TyVar
type IdOrTyVarSet = UniqSet IdOrTyVar
type UVarSet = UniqSet UVar
emptyVarSet :: VarSet
intersectVarSet :: VarSet -> VarSet -> VarSet
......
......@@ -32,7 +32,7 @@ import ErrUtils ( doIfSet, dumpIfSet, ghcExit, Message,
import PrimRep ( PrimRep(..) )
import SrcLoc ( SrcLoc, noSrcLoc, isNoSrcLoc )
import Type ( Type, Kind, tyVarsOfType,
splitFunTy_maybe, mkPiType, mkTyVarTy,
splitFunTy_maybe, mkPiType, mkTyVarTy, unUsgTy,
splitForAllTy_maybe, splitTyConApp_maybe,
isUnLiftedType, typeKind,
splitAlgTyConApp_maybe,
......@@ -238,7 +238,7 @@ lintCoreExpr (Note (Coerce to_ty from_ty) expr)
= lintCoreExpr expr `thenL` \ expr_ty ->
lintTy to_ty `seqL`
lintTy from_ty `seqL`
checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty) `seqL`
checkTys from_ty (unUsgTy expr_ty) (mkCoerceErr from_ty expr_ty) `seqL`
returnL to_ty
lintCoreExpr (Note other_note expr)
......
......@@ -62,10 +62,11 @@ coreExprType :: CoreExpr -> Type
coreExprType (Var var) = idType var
coreExprType (Let _ body) = coreExprType body
coreExprType (Case _ _ alts) = coreAltsType alts
coreExprType (Note (Coerce ty _) e) = ty
coreExprType (Note (Coerce ty _) e) = ty -- **! should take usage from e
coreExprType (Note (TermUsg u) e) = mkUsgTy u (unUsgTy (coreExprType e))
coreExprType (Note other_note e) = coreExprType e
coreExprType e@(Con con args) = applyTypeToArgs e (conType con) args
coreExprType e@(Con con args) = ASSERT2( all (\ a -> case a of { Type ty -> isNotUsgTy ty; _ -> True }) args, ppr e)
applyTypeToArgs e (conType con) args
coreExprType (Lam binder expr)
| isId binder = (case (lbvarInfo . idInfo) binder of
......@@ -439,7 +440,7 @@ eqExpr e1 e2
eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
eq_note env (SCC cc1) (SCC cc2) = cc1 == cc2
eq_note env (Coerce f1 t1) (Coerce f2 t2) = f1==f2 && t1==t2
eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1==t2 && f1==f2
eq_note env InlineCall InlineCall = True
eq_note env other1 other2 = False
\end{code}
......
......@@ -2,6 +2,6 @@ _interface_ Subst 1
_exports_ Subst Subst mkTyVarSubst substTy ;
_declarations_
1 data Subst;
1 mkTyVarSubst _:_ [Var.TyVar] -> [Type.Type] -> Subst ;;
1 substTy _:_ Subst -> Type.Type -> Type.Type ;;
1 mkTyVarSubst _:_ [Var.TyVar] -> [TypeRep.Type] -> Subst ;;
1 substTy _:_ Subst -> TypeRep.Type -> TypeRep.Type ;;
__interface Subst 1 0 where
__export Subst Subst mkTyVarSubst substTy ;
1 data Subst;
1 mkTyVarSubst :: [Var.TyVar] -> [Type.Type] -> Subst ;
1 substTy :: Subst -> Type.Type -> Type.Type ;
1 mkTyVarSubst :: [Var.TyVar] -> [TypeRep.Type] -> Subst ;
1 substTy :: Subst -> TypeRep.Type -> TypeRep.Type ;
......@@ -36,7 +36,9 @@ import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, CoreBndr,
emptyCoreRules, isEmptyCoreRules, seqRules
)
import CoreFVs ( exprFreeVars )
import Type ( Type(..), ThetaType, TyNote(..),
import TypeRep ( Type(..), TyNote(..),
) -- friend
import Type ( ThetaType,
tyVarsOfType, tyVarsOfTypes, mkAppTy
)
import VarSet
......@@ -218,7 +220,8 @@ subst_ty subst ty
go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2)
go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
go (FunTy arg res) = (FunTy $! (go arg)) $! (go res)
go (NoteTy (UsgNote usg) ty2) = (NoteTy $! UsgNote usg) $! go ty2 -- Keep usage annot
go (NoteTy (UsgNote usg) ty2) = (NoteTy $! UsgNote usg) $! go ty2 -- Keep usage annot
go (NoteTy (UsgForAll uv) ty2) = (NoteTy $! UsgForAll uv) $! go ty2 -- Keep uvar bdr
go (AppTy fun arg) = mkAppTy (go fun) $! (go arg)
go ty@(TyVarTy tv) = case (lookupSubst subst tv) of
Nothing -> ty
......
......@@ -15,7 +15,7 @@ import Var ( Var, Id, TyVar, idType, varName, varType )
import Id ( setIdCprInfo, getIdCprInfo, getIdUnfolding )
import IdInfo ( CprInfo(..) )
import VarEnv
import Type ( Type(..), splitFunTys, splitForAllTys, splitNewType_maybe )
import Type ( Type, splitFunTys, splitForAllTys, splitNewType_maybe )
import TyCon ( isProductTyCon, isNewTyCon, isUnLiftedTyCon )
import DataCon ( dataConTyCon, splitProductType_maybe )
import Const ( Con(DataCon), isWHNFCon )
......@@ -365,8 +365,9 @@ splitTypeToFunArgAndRes ty = (tyvars, argtys, resty)
(argtys, resty) = splitFunTysIgnoringNewTypes funty
-- (argtys, resty) = splitFunTys funty
-- Taken from splitFunTys in Type.lhs. Modified to keep searching through newtypes
-- splitFunTys, modified to keep searching through newtypes.
-- Should move to Type.lhs if it is doing something sensible.
splitFunTysIgnoringNewTypes :: Type -> ([Type], Type)
splitFunTysIgnoringNewTypes ty = split ty
where
......@@ -378,6 +379,7 @@ splitFunTysIgnoringNewTypes ty = split ty
where
(args, res) = splitFunTys ty
-- Is this the constructor for a product type (i.e. algebraic, single constructor)
-- NB: isProductTyCon replies 'False' for unboxed tuples
isConProdType :: Con -> Bool
......
......@@ -30,7 +30,7 @@ import Name ( mkGlobalName, nameModule, nameOccName, getOccString,
NamedThing(..), Provenance(..), ExportFlag(..)
)
import PrelInfo ( deRefStablePtr_NAME, bindIO_NAME, makeStablePtr_NAME, realWorldPrimId )
import Type ( splitAlgTyConApp_maybe,
import Type ( splitAlgTyConApp_maybe, unUsgTy,
splitTyConApp_maybe, splitFunTys, splitForAllTys,
Type, mkFunTys, mkForAllTys, mkTyConApp,
mkTyVarTy, mkFunTy, splitAppTy
......@@ -423,7 +423,7 @@ dsFExportDynamic i ty mod_name ext_name cconv =
let ccall_io_adj =
mkLams [stbl_value] $
bindNonRec x_ccall_adj ccall_adj $
Note (Coerce (mkTyConApp ioTyCon [res_ty]) ccall_adj_ty)
Note (Coerce (mkTyConApp ioTyCon [res_ty]) (unUsgTy ccall_adj_ty))
(Var x_ccall_adj)
in
newSysLocalDs (coreExprType ccall_io_adj) `thenDs` \ x_ccall_io_adj ->
......
......@@ -225,7 +225,7 @@ mkCoAlgCaseMatchResult var match_alts
(con_id, arg_ids, match_result) = head match_alts
arg_id = head arg_ids
coercion_bind = NonRec arg_id
(Note (Coerce (idType arg_id) scrut_ty) (Var var))
(Note (Coerce (unUsgTy (idType arg_id)) (unUsgTy scrut_ty)) (Var var))
newtype_sanity = null (tail match_alts) && null (tail arg_ids)
-- Stuff for data types
......
......@@ -3,16 +3,12 @@
%
\section[HsTypes]{Abstract syntax: user-defined types}
If compiled without \tr{#define COMPILING_GHC}, you get
(part of) a Haskell-abstract-syntax library. With it,
you get part of GHC.
\begin{code}
module HsTypes (
HsType(..), HsTyVar(..),
HsType(..), MonoUsageAnn(..), HsTyVar(..),
Context, ClassAssertion
, mkHsForAllTy
, mkHsForAllTy, mkHsUsForAllTy
, getTyVarName, replaceTyVarName
, pprParendHsType
, pprForAll, pprContext, pprClassAssertion
......@@ -58,12 +54,24 @@ data HsType name
| MonoDictTy name -- Class
[HsType name]
| MonoUsgTy UsageAnn
| MonoUsgTy (MonoUsageAnn name)
(HsType name)
| MonoUsgForAllTy name
(HsType name)
data MonoUsageAnn name
= MonoUsOnce
| MonoUsMany
| MonoUsVar name
mkHsForAllTy [] [] ty = ty
mkHsForAllTy tvs ctxt ty = HsForAllTy (Just tvs) ctxt ty
mkHsUsForAllTy uvs ty = foldr (\ uv ty -> MonoUsgForAllTy uv ty)
ty uvs
data HsTyVar name
= UserTyVar name
| IfaceTyVar name Kind
......@@ -156,9 +164,26 @@ ppr_mono_ty ctxt_prec (MonoTyApp fun_ty arg_ty)
ppr_mono_ty ctxt_prec (MonoDictTy clas tys)
= ppr clas <+> hsep (map (ppr_mono_ty pREC_CON) tys)
ppr_mono_ty ctxt_prec ty@(MonoUsgForAllTy _ _)
= maybeParen (ctxt_prec >= pREC_FUN) $
sep [ ptext SLIT("__fuall") <+> brackets pp_uvars <+> ptext SLIT("=>"),
ppr_mono_ty pREC_TOP sigma
]
where
(uvars,sigma) = split [] ty
pp_uvars = interppSP uvars
split uvs (MonoUsgForAllTy uv ty') = split (uv:uvs) ty'
split uvs ty' = (reverse uvs,ty')
ppr_mono_ty ctxt_prec (MonoUsgTy u ty)
= maybeParen (ctxt_prec >= pREC_CON) $
ppr u <+> ppr_mono_ty pREC_CON ty
ptext SLIT("__u") <+> pp_ua <+> ppr_mono_ty pREC_CON ty
where
pp_ua = case u of
MonoUsOnce -> ptext SLIT("-")
MonoUsMany -> ptext SLIT("!")
MonoUsVar uv -> ppr uv
\end{code}
......@@ -213,7 +238,7 @@ cmpHsType cmp (MonoDictTy c1 tys1) (MonoDictTy c2 tys2)
= cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2
cmpHsType cmp (MonoUsgTy u1 ty1) (MonoUsgTy u2 ty2)
= cmpUsg u1 u2 `thenCmp` cmpHsType cmp ty1 ty2
= cmpUsg cmp u1 u2 `thenCmp` cmpHsType cmp ty1 ty2
cmpHsType cmp ty1 ty2 -- tags must be different
= let tag1 = tag ty1
......@@ -226,9 +251,10 @@ cmpHsType cmp ty1 ty2 -- tags must be different
tag (MonoListTy ty1) = ILIT(3)
tag (MonoTyApp tc1 tys1) = ILIT(4)
tag (MonoFunTy a1 b1) = ILIT(5)
tag (MonoDictTy c1 tys1) = ILIT(7)
tag (MonoUsgTy c1 tys1) = ILIT(6)
tag (HsForAllTy _ _ _) = ILIT(8)
tag (MonoDictTy c1 tys1) = ILIT(6)
tag (MonoUsgTy c1 ty1) = ILIT(7)
tag (MonoUsgForAllTy uv1 ty1) = ILIT(8)
tag (HsForAllTy _ _ _) = ILIT(9)
-------------------
cmpContext cmp a b
......@@ -237,13 +263,19 @@ cmpContext cmp a b
cmp_ctxt (c1, tys1) (c2, tys2)
= cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2
-- Should be in Type, perhaps
cmpUsg UsOnce UsOnce = EQ
cmpUsg UsOnce UsMany = LT
cmpUsg UsMany UsOnce = GT
cmpUsg UsMany UsMany = EQ
cmpUsg u1 u2 = pprPanic "cmpUsg:" $
ppr u1 <+> ppr u2
cmpUsg cmp MonoUsOnce MonoUsOnce = EQ
cmpUsg cmp MonoUsMany MonoUsMany = EQ
cmpUsg cmp (MonoUsVar u1) (MonoUsVar u2) = cmp u1 u2
cmpUsg cmp ua1 ua2 -- tags must be different
= let tag1 = tag ua1
tag2 = tag ua2
in
if tag1 _LT_ tag2 then LT else GT
where
tag MonoUsOnce = (ILIT(1) :: FAST_INT)
tag MonoUsMany = ILIT(2)
tag (MonoUsVar _) = ILIT(3)
-- Should be in Maybes, I guess
cmpMaybe cmp Nothing Nothing = EQ
......
......@@ -295,8 +295,8 @@ src_filename = case argv of
\begin{code}
-- debugging opts
opt_D_dump_all = lookUp SLIT("-ddump-all")
opt_D_dump_most = opt_D_dump_all || lookUp SLIT("-ddump-most")
opt_D_dump_all {- do not -} = lookUp SLIT("-ddump-all")
opt_D_dump_most {- export -} = opt_D_dump_all || lookUp SLIT("-ddump-most")
opt_D_dump_absC = opt_D_dump_all || lookUp SLIT("-ddump-absC")
opt_D_dump_asm = opt_D_dump_all || lookUp SLIT("-ddump-asm")
......@@ -305,7 +305,7 @@ opt_D_dump_deriv = opt_D_dump_most || lookUp SLIT("-ddump-deriv")
opt_D_dump_ds = opt_D_dump_most || lookUp SLIT("-ddump-ds")
opt_D_dump_flatC = opt_D_dump_all || lookUp SLIT("-ddump-flatC")
opt_D_dump_foreign = opt_D_dump_most || lookUp SLIT("-ddump-foreign-stubs")
opt_D_dump_inlinings = opt_D_dump_most || lookUp SLIT("-ddump-inlinings")
opt_D_dump_inlinings = opt_D_dump_all || lookUp SLIT("-ddump-inlinings")
opt_D_dump_occur_anal = opt_D_dump_most || lookUp SLIT("-ddump-occur-anal")
opt_D_dump_parsed = opt_D_dump_most || lookUp SLIT("-ddump-parsed")
opt_D_dump_realC = opt_D_dump_all || lookUp SLIT("-ddump-realC")
......
......@@ -337,7 +337,7 @@ ifaceId get_idinfo needed_ids is_rec id rhs
IAmALoopBreaker -> True
other -> False
unfold_pretty | show_unfold = ptext SLIT("__u") <+> pprIfaceUnfolding rhs
unfold_pretty | show_unfold = ptext SLIT("__U") <+> pprIfaceUnfolding rhs
| otherwise = empty
show_unfold = not has_worker && -- Not unnecessary
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment