Commit f01a8e8c authored by partain's avatar partain
Browse files

[project @ 1996-04-30 17:34:02 by partain]

SLPJ 1.3 changes to 960430
parent cc051dd7
...@@ -503,7 +503,7 @@ types/TyLoop.hi : types/TyLoop.lhi ...@@ -503,7 +503,7 @@ types/TyLoop.hi : types/TyLoop.lhi
rename/ParseIface.hs : rename/ParseIface.y rename/ParseIface.hs : rename/ParseIface.y
$(RM) rename/ParseIface.hs rename/ParseIface.hinfo $(RM) rename/ParseIface.hs rename/ParseIface.hinfo
happy -i rename/ParseIface.hinfo rename/ParseIface.y happy -g -i rename/ParseIface.hinfo rename/ParseIface.y
@chmod 444 rename/ParseIface.hs @chmod 444 rename/ParseIface.hs
compile(absCSyn/AbsCUtils,lhs,) compile(absCSyn/AbsCUtils,lhs,)
......
...@@ -81,6 +81,8 @@ module Id {- ( ...@@ -81,6 +81,8 @@ module Id {- (
showId, showId,
pprIdInUnfolding, pprIdInUnfolding,
nmbrId,
-- "Environments" keyed off of Ids, and sets of Ids -- "Environments" keyed off of Ids, and sets of Ids
IdEnv(..), IdEnv(..),
lookupIdEnv, lookupNoFailIdEnv, nullIdEnv, unitIdEnv, mkIdEnv, lookupIdEnv, lookupNoFailIdEnv, nullIdEnv, unitIdEnv, mkIdEnv,
...@@ -104,15 +106,17 @@ import Maybes ( maybeToBool ) ...@@ -104,15 +106,17 @@ import Maybes ( maybeToBool )
import Name ( appendRdr, nameUnique, mkLocalName, isLocalName, import Name ( appendRdr, nameUnique, mkLocalName, isLocalName,
isLocallyDefinedName, isPreludeDefinedName, isLocallyDefinedName, isPreludeDefinedName,
mkTupleDataConName, mkCompoundName, mkTupleDataConName, mkCompoundName,
isLexSym, getLocalName, isLexSym, isLexSpecialSym, getLocalName,
isLocallyDefined, isPreludeDefined, isLocallyDefined, isPreludeDefined,
getOccName, moduleNamePair, origName, nameOf, getOccName, moduleNamePair, origName, nameOf,
isExported, ExportFlag(..), isExported, ExportFlag(..),
RdrName(..), Name RdrName(..), Name
) )
import FieldLabel ( fieldLabelName, FieldLabel{-instances-} ) import FieldLabel ( fieldLabelName, FieldLabel(..){-instances-} )
import PragmaInfo ( PragmaInfo(..) ) import PragmaInfo ( PragmaInfo(..) )
import PprEnv -- ( NmbrM(..), NmbrEnv(..) )
import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix, import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix,
nmbrType, addTyVar,
GenType, GenTyVar GenType, GenTyVar
) )
import PprStyle import PprStyle
...@@ -127,8 +131,8 @@ import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy, ...@@ -127,8 +131,8 @@ import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
import TyVar ( alphaTyVars, isEmptyTyVarSet, TyVarEnv(..) ) import TyVar ( alphaTyVars, isEmptyTyVarSet, TyVarEnv(..) )
import UniqFM import UniqFM
import UniqSet -- practically all of it import UniqSet -- practically all of it
import UniqSupply ( getBuiltinUniques ) import Unique ( getBuiltinUniques, pprUnique, showUnique,
import Unique ( pprUnique, showUnique, incrUnique,
Unique{-instance Ord3-} Unique{-instance Ord3-}
) )
import Util ( mapAccumL, nOfThem, zipEqual, import Util ( mapAccumL, nOfThem, zipEqual,
...@@ -656,7 +660,7 @@ pprIdInUnfolding in_scopes v ...@@ -656,7 +660,7 @@ pprIdInUnfolding in_scopes v
(m_str, n_str) = moduleNamePair v (m_str, n_str) = moduleNamePair v
pp_n = pp_n =
if isLexSym n_str then if isLexSym n_str && not (isLexSpecialSym n_str) then
ppBesides [ppLparen, ppPStr n_str, ppRparen] ppBesides [ppLparen, ppPStr n_str, ppRparen]
else else
ppPStr n_str ppPStr n_str
...@@ -1938,3 +1942,69 @@ minusIdSet = minusUniqSet ...@@ -1938,3 +1942,69 @@ minusIdSet = minusUniqSet
isEmptyIdSet = isEmptyUniqSet isEmptyIdSet = isEmptyUniqSet
mkIdSet = mkUniqSet mkIdSet = mkUniqSet
\end{code} \end{code}
\begin{code}
addId, nmbrId :: Id -> NmbrM Id
addId id@(Id u ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
= case (lookupUFM_Directly idenv u) of
Just xx -> _trace "addId: already in map!" $
(nenv, xx)
Nothing ->
if toplevelishId id then
_trace "addId: can't add toplevelish!" $
(nenv, id)
else -- alloc a new unique for this guy
-- and add an entry in the idenv
-- NB: *** KNOT-TYING ***
let
nenv_plus_id = NmbrEnv (incrUnique ui) ut uu
(addToUFM_Directly idenv u new_id)
tvenv uvenv
(nenv2, new_ty) = nmbrType ty nenv_plus_id
(nenv3, new_det) = nmbr_details det nenv2
new_id = Id ui new_ty new_det prag info
in
(nenv3, new_id)
nmbrId id@(Id u ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
= case (lookupUFM_Directly idenv u) of
Just xx -> (nenv, xx)
Nothing ->
if not (toplevelishId id) then
_trace "nmbrId: lookup failed" $
(nenv, id)
else
let
(nenv2, new_ty) = nmbrType ty nenv
(nenv3, new_det) = nmbr_details det nenv2
new_id = Id u new_ty new_det prag info
in
(nenv3, new_id)
------------
nmbr_details :: IdDetails -> NmbrM IdDetails
nmbr_details (DataConId n tag marks fields tvs theta arg_tys tc)
= mapNmbr addTyVar tvs `thenNmbr` \ new_tvs ->
mapNmbr nmbrField fields `thenNmbr` \ new_fields ->
mapNmbr nmbr_theta theta `thenNmbr` \ new_theta ->
mapNmbr nmbrType arg_tys `thenNmbr` \ new_arg_tys ->
returnNmbr (DataConId n tag marks new_fields new_tvs new_theta new_arg_tys tc)
where
nmbr_theta (c,t)
= --nmbrClass c `thenNmbr` \ new_c ->
nmbrType t `thenNmbr` \ new_t ->
returnNmbr (c, new_t)
-- ToDo:add more cases as needed
nmbr_details other_details = returnNmbr other_details
------------
nmbrField (FieldLabel n ty tag)
= nmbrType ty `thenNmbr` \ new_ty ->
returnNmbr (FieldLabel n new_ty tag)
\end{code}
...@@ -11,7 +11,7 @@ import CoreSyn ( CoreExpr(..), GenCoreExpr, GenCoreArg ) ...@@ -11,7 +11,7 @@ import CoreSyn ( CoreExpr(..), GenCoreExpr, GenCoreArg )
import CoreUnfold ( FormSummary(..), UnfoldingDetails(..), UnfoldingGuidance(..) ) import CoreUnfold ( FormSummary(..), UnfoldingDetails(..), UnfoldingGuidance(..) )
import CoreUtils ( unTagBinders ) import CoreUtils ( unTagBinders )
import Id ( externallyVisibleId, isDataCon, isWorkerId, isWrapperId, import Id ( externallyVisibleId, isDataCon, isWorkerId, isWrapperId,
unfoldingUnfriendlyId, getIdInfo, unfoldingUnfriendlyId, getIdInfo, nmbrId,
nullIdEnv, lookupIdEnv, IdEnv(..), nullIdEnv, lookupIdEnv, IdEnv(..),
Id(..), GenId Id(..), GenId
) )
...@@ -19,6 +19,7 @@ import IdInfo ( IdInfo ) ...@@ -19,6 +19,7 @@ import IdInfo ( IdInfo )
import Literal ( Literal ) import Literal ( Literal )
import MagicUFs ( mkMagicUnfoldingFun, MagicUnfoldingFun ) import MagicUFs ( mkMagicUnfoldingFun, MagicUnfoldingFun )
import Outputable ( Outputable(..) ) import Outputable ( Outputable(..) )
import PprEnv ( NmbrEnv )
import PprStyle ( PprStyle ) import PprStyle ( PprStyle )
import PprType ( pprParendGenType ) import PprType ( pprParendGenType )
import Pretty ( PrettyRep ) import Pretty ( PrettyRep )
...@@ -39,6 +40,7 @@ getIdInfo :: Id -> IdInfo ...@@ -39,6 +40,7 @@ getIdInfo :: Id -> IdInfo
nullIdEnv :: UniqFM a nullIdEnv :: UniqFM a
lookupIdEnv :: UniqFM b -> GenId a -> Maybe b lookupIdEnv :: UniqFM b -> GenId a -> Maybe b
mAX_WORKER_ARGS :: Int mAX_WORKER_ARGS :: Int
nmbrId :: Id -> NmbrEnv -> (NmbrEnv, Id)
pprParendGenType :: (Eq a, Outputable a, Eq b, Outputable b) => PprStyle -> GenType a b -> Int -> Bool -> PrettyRep pprParendGenType :: (Eq a, Outputable a, Eq b, Outputable b) => PprStyle -> GenType a b -> Int -> Bool -> PrettyRep
unTagBinders :: GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), a) b c d -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) b c d unTagBinders :: GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), a) b c d -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) b c d
...@@ -58,6 +60,7 @@ instance Outputable (GenTyVar a) ...@@ -58,6 +60,7 @@ instance Outputable (GenTyVar a)
instance (Outputable a) => Outputable (GenId a) instance (Outputable a) => Outputable (GenId a)
instance (Eq a, Outputable a, Eq b, Outputable b) => Outputable (GenType a b) instance (Eq a, Outputable a, Eq b, Outputable b) => Outputable (GenType a b)
data NmbrEnv
data MagicUnfoldingFun data MagicUnfoldingFun
data FormSummary = WhnfForm | BottomForm | OtherForm data FormSummary = WhnfForm | BottomForm | OtherForm
data UnfoldingDetails data UnfoldingDetails
......
...@@ -43,7 +43,7 @@ primOpId op ...@@ -43,7 +43,7 @@ primOpId op
Compare str ty -> Compare str ty ->
mk_prim_Id op pRELUDE_BUILTIN str [] [ty,ty] (compare_fun_ty ty) 2 mk_prim_Id op pRELUDE_BUILTIN str [] [ty,ty] (compare_fun_ty ty) 2
Coerce str ty1 ty2 -> Coercing str ty1 ty2 ->
mk_prim_Id op pRELUDE_BUILTIN str [] [ty1] (mkFunTys [ty1] ty2) 1 mk_prim_Id op pRELUDE_BUILTIN str [] [ty1] (mkFunTys [ty1] ty2) 1
PrimResult str tyvars arg_tys prim_tycon kind res_tys -> PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
......
...@@ -48,7 +48,7 @@ module Name ( ...@@ -48,7 +48,7 @@ module Name (
getLocalName, ltLexical, getLocalName, ltLexical,
isSymLexeme, pprSym, pprNonSym, isSymLexeme, pprSym, pprNonSym,
isLexCon, isLexVar, isLexId, isLexSym, isLexCon, isLexVar, isLexId, isLexSym, isLexSpecialSym,
isLexConId, isLexConSym, isLexVarId, isLexVarSym isLexConId, isLexConSym, isLexVarId, isLexVarSym
) where ) where
...@@ -123,7 +123,6 @@ instance Outputable RdrName where ...@@ -123,7 +123,6 @@ instance Outputable RdrName where
ppr sty (Unqual n) = pp_name sty n ppr sty (Unqual n) = pp_name sty n
ppr sty (Qual m n) = ppBeside (pp_mod sty m) (pp_name sty n) ppr sty (Qual m n) = ppBeside (pp_mod sty m) (pp_name sty n)
pp_mod PprInterface m = ppNil
pp_mod PprForC m = ppBesides [identToC m, ppPStr cSEP] pp_mod PprForC m = ppBesides [identToC m, ppPStr cSEP]
pp_mod (PprForAsm False _) m = ppBesides [identToC m, ppPStr cSEP] pp_mod (PprForAsm False _) m = ppBesides [identToC m, ppPStr cSEP]
pp_mod (PprForAsm True _) m = ppBesides [ppPStr cSEP, identToC m, ppPStr cSEP] pp_mod (PprForAsm True _) m = ppBesides [ppPStr cSEP, identToC m, ppPStr cSEP]
...@@ -423,7 +422,8 @@ defined in the Haskell report. Normally applied as in e.g. @isCon ...@@ -423,7 +422,8 @@ defined in the Haskell report. Normally applied as in e.g. @isCon
(getLocalName foo)@. (getLocalName foo)@.
\begin{code} \begin{code}
isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FAST_STRING -> Bool isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym,
isLexVarId, isLexVarSym, isLexSpecialSym :: FAST_STRING -> Bool
isLexCon cs = isLexConId cs || isLexConSym cs isLexCon cs = isLexConId cs || isLexConSym cs
isLexVar cs = isLexVarId cs || isLexVarSym cs isLexVar cs = isLexVarId cs || isLexVarSym cs
...@@ -449,10 +449,10 @@ isLexVarId cs ...@@ -449,10 +449,10 @@ isLexVarId cs
isLexConSym cs isLexConSym cs
| _NULL_ cs = False | _NULL_ cs = False
| otherwise = c == ':' | otherwise = c == ':'
|| c == '(' -- (), (,), (,,), ... -- || c == '(' -- (), (,), (,,), ...
|| cs == SLIT("->") || cs == SLIT("->")
|| cs == SLIT("[]") -- || cs == SLIT("[]")
where where
c = _HEAD_ cs c = _HEAD_ cs
...@@ -460,7 +460,14 @@ isLexVarSym cs ...@@ -460,7 +460,14 @@ isLexVarSym cs
| _NULL_ cs = False | _NULL_ cs = False
| otherwise = isSymbolASCII c | otherwise = isSymbolASCII c
|| isSymbolISO c || isSymbolISO c
|| c == '(' -- (), (,), (,,), ... -- || c == '(' -- (), (,), (,,), ...
-- || cs == SLIT("[]")
where
c = _HEAD_ cs
isLexSpecialSym cs
| _NULL_ cs = False
| otherwise = c == '(' -- (), (,), (,,), ...
|| cs == SLIT("[]") || cs == SLIT("[]")
where where
c = _HEAD_ cs c = _HEAD_ cs
...@@ -484,13 +491,16 @@ isSymLexeme v ...@@ -484,13 +491,16 @@ isSymLexeme v
pprSym, pprNonSym :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty pprSym, pprNonSym :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
pprSym sty var pprSym sty var
= if isSymLexeme var = let
str = nameOf (origName var)
in
if isLexSym str && not (isLexSpecialSym str)
then ppr sty var then ppr sty var
else ppBesides [ppChar '`', ppr sty var, ppChar '`'] else ppBesides [ppChar '`', ppr sty var, ppChar '`']
pprNonSym sty var pprNonSym sty var
= if isSymLexeme var = if isSymLexeme var
then ppBesides [ppLparen, ppr sty var, ppRparen] then ppParens (ppr sty var)
else ppr sty var else ppr sty var
#ifdef USE_ATTACK_PRAGMAS #ifdef USE_ATTACK_PRAGMAS
......
...@@ -12,13 +12,22 @@ module PprEnv ( ...@@ -12,13 +12,22 @@ module PprEnv (
initPprEnv, initPprEnv,
pCon, pLit, pMajBndr, pMinBndr, pOcc, pPrim, pSCC, pStyle, pCon, pLit, pMajBndr, pMinBndr, pOcc, pPrim, pSCC, pStyle,
pTy, pTyVar, pUVar, pUse pTy, pTyVar, pUVar, pUse,
NmbrEnv(..),
NmbrM(..), initNmbr,
returnNmbr, thenNmbr,
mapNmbr, mapAndUnzipNmbr
-- nmbr1, nmbr2, nmbr3
-- rnumValVar, rnumTyVar, rnumUVar,
-- lookupValVar, lookupTyVar, lookupUVar
) where ) where
import Ubiq{-uitous-} import Ubiq{-uitous-}
import Id ( DataCon(..) )
import Pretty ( Pretty(..) ) import Pretty ( Pretty(..) )
import Unique ( initRenumberingUniques )
import UniqFM ( emptyUFM )
import Util ( panic ) import Util ( panic )
\end{code} \end{code}
...@@ -32,7 +41,7 @@ data PprEnv tyvar uvar bndr occ ...@@ -32,7 +41,7 @@ data PprEnv tyvar uvar bndr occ
= PE PprStyle -- stored for safe keeping = PE PprStyle -- stored for safe keeping
(Literal -> Pretty) -- Doing these this way saves (Literal -> Pretty) -- Doing these this way saves
(DataCon -> Pretty) -- carrying around a PprStyle (Id -> Pretty) -- carrying around a PprStyle
(PrimOp -> Pretty) (PrimOp -> Pretty)
(CostCentre -> Pretty) (CostCentre -> Pretty)
...@@ -51,7 +60,7 @@ data PprEnv tyvar uvar bndr occ ...@@ -51,7 +60,7 @@ data PprEnv tyvar uvar bndr occ
initPprEnv initPprEnv
:: PprStyle :: PprStyle
-> Maybe (Literal -> Pretty) -> Maybe (Literal -> Pretty)
-> Maybe (DataCon -> Pretty) -> Maybe (Id -> Pretty)
-> Maybe (PrimOp -> Pretty) -> Maybe (PrimOp -> Pretty)
-> Maybe (CostCentre -> Pretty) -> Maybe (CostCentre -> Pretty)
-> Maybe (tyvar -> Pretty) -> Maybe (tyvar -> Pretty)
...@@ -119,3 +128,75 @@ pOcc (PE _ _ _ _ _ _ _ _ _ pp _ _) = pp ...@@ -119,3 +128,75 @@ pOcc (PE _ _ _ _ _ _ _ _ _ pp _ _) = pp
pTy (PE _ _ _ _ _ _ _ _ _ _ pp _) = pp pTy (PE _ _ _ _ _ _ _ _ _ _ pp _) = pp
pUse (PE _ _ _ _ _ _ _ _ _ _ _ pp) = pp pUse (PE _ _ _ _ _ _ _ _ _ _ _ pp) = pp
\end{code} \end{code}
We tend to {\em renumber} everything before printing, so that
we get consistent Uniques on everything from run to run.
\begin{code}
data NmbrEnv
= NmbrEnv Unique -- next "Unique" to give out for a value
Unique -- ... for a tyvar
Unique -- ... for a usage var
(UniqFM Id) -- mapping for value vars we know about
(UniqFM TyVar) -- ... for tyvars
(UniqFM Unique{-UVar-}) -- ... for usage vars
type NmbrM a = NmbrEnv -> (NmbrEnv, a)
initNmbr :: NmbrM a -> a
initNmbr m
= let
(v1,t1,u1) = initRenumberingUniques
init_nmbr_env = NmbrEnv v1 t1 u1 emptyUFM emptyUFM emptyUFM
in
snd (m init_nmbr_env)
returnNmbr x nenv = (nenv, x)
thenNmbr m k nenv
= let
(nenv2, res) = m nenv
in
k res nenv2
mapNmbr f [] = returnNmbr []
mapNmbr f (x:xs)
= f x `thenNmbr` \ r ->
mapNmbr f xs `thenNmbr` \ rs ->
returnNmbr (r:rs)
mapAndUnzipNmbr f [] = returnNmbr ([],[])
mapAndUnzipNmbr f (x:xs)
= f x `thenNmbr` \ (r1, r2) ->
mapAndUnzipNmbr f xs `thenNmbr` \ (rs1, rs2) ->
returnNmbr (r1:rs1, r2:rs2)
{-
nmbr1 nenv thing x1
= let
(nenv1, new_x1) = x1 nenv
in
(nenv1, thing new_x1)
nmbr2 nenv thing x1 x2
= let
(nenv1, new_x1) = x1 nenv
(nenv2, new_x2) = x2 nenv1
in
(nenv2, thing new_x1 new_x2)
nmbr3 nenv thing x1 x2 x3
= let
(nenv1, new_x1) = x1 nenv
(nenv2, new_x2) = x2 nenv1
(nenv3, new_x3) = x3 nenv2
in
(nenv3, thing new_x1 new_x2 new_x3)
-}
rnumValVar = panic "rnumValVar"
rnumTyVar = panic "rnumTyVar"
rnumUVar = panic "rnumUVar"
lookupValVar = panic "lookupValVar"
lookupTyVar = panic "lookupTyVar"
lookupUVar = panic "lookupUVar"
\end{code}
...@@ -18,11 +18,7 @@ module UniqSupply ( ...@@ -18,11 +18,7 @@ module UniqSupply (
thenMaybeUs, mapAccumLUs, thenMaybeUs, mapAccumLUs,
mkSplitUniqSupply, mkSplitUniqSupply,
splitUniqSupply, splitUniqSupply
-- and the access functions for the `builtin' UniqueSupply
getBuiltinUniques, mkBuiltinUnique,
mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3
) where ) where
import Ubiq{-uitous-} import Ubiq{-uitous-}
...@@ -190,28 +186,3 @@ mapAccumLUs f b (x:xs) ...@@ -190,28 +186,3 @@ mapAccumLUs f b (x:xs)
mapAccumLUs f b__2 xs `thenUs` \ (b__3, xs__2) -> mapAccumLUs f b__2 xs `thenUs` \ (b__3, xs__2) ->
returnUs (b__3, x__2:xs__2) returnUs (b__3, x__2:xs__2)
\end{code} \end{code}
%************************************************************************
%* *
\subsubsection[UniqueSupplies-compiler]{@UniqueSupplies@ specific to the compiler}
%* *
%************************************************************************
\begin{code}
mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
mkBuiltinUnique :: Int -> Unique
mkBuiltinUnique i = mkUnique 'B' i
mkPseudoUnique1 i = mkUnique 'C' i -- used for uniqueOf on Regs
mkPseudoUnique2 i = mkUnique 'D' i -- ditto
mkPseudoUnique3 i = mkUnique 'E' i -- ditto
getBuiltinUniques :: Int -> [Unique]
getBuiltinUniques n = map (mkUnique 'B') [1 .. n]
\end{code}
The following runs a uniq monad expression, using builtin uniq values:
\begin{code}
--runBuiltinUs :: UniqSM a -> a
--runBuiltinUs m = snd (initUs uniqSupply_B m)
\end{code}
...@@ -29,6 +29,9 @@ module Unique ( ...@@ -29,6 +29,9 @@ module Unique (
mkUnique, -- Used in UniqSupply mkUnique, -- Used in UniqSupply
mkUniqueGrimily, -- Used in UniqSupply only! mkUniqueGrimily, -- Used in UniqSupply only!
incrUnique, -- Used for renumbering
initRenumberingUniques,
-- now all the built-in Uniques (and functions to make them) -- now all the built-in Uniques (and functions to make them)
-- [the Oh-So-Wonderful Haskell module system wins again...] -- [the Oh-So-Wonderful Haskell module system wins again...]
mkAlphaTyVarUnique, mkAlphaTyVarUnique,
...@@ -36,6 +39,9 @@ module Unique ( ...@@ -36,6 +39,9 @@ module Unique (
mkTupleDataConUnique, mkTupleDataConUnique,
mkTupleTyConUnique, mkTupleTyConUnique,
getBuiltinUniques, mkBuiltinUnique,
mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
absentErrorIdKey, -- alphabetical... absentErrorIdKey, -- alphabetical...
addrDataConKey, addrDataConKey,
addrPrimTyConKey, addrPrimTyConKey,
...@@ -224,25 +230,19 @@ Now come the functions which construct uniques from their pieces, and vice versa ...@@ -224,25 +230,19 @@ Now come the functions which construct uniques from their pieces, and vice versa
The stuff about unique *supplies* is handled further down this module. The stuff about unique *supplies* is handled further down this module.
\begin{code} \begin{code}
mkUnique :: Char -> Int -> Unique -- Builds a unique from pieces mkUnique :: Char -> Int -> Unique -- Builds a unique from pieces
unpkUnique :: Unique -> (Char, Int) -- The reverse unpkUnique :: Unique -> (Char, Int) -- The reverse
mkUnifiableTyVarUnique :: Int -> Unique -- Injects a subst-array index into the Unique type
unpkUnifiableTyVarUnique :: Unique -> Int -- The reverse process
mkUniqueGrimily :: Int# -> Unique -- A trap-door for UniqSupply mkUniqueGrimily :: Int# -> Unique -- A trap-door for UniqSupply
incrUnique :: Unique -> Unique
\end{code} \end{code}
\begin{code} \begin{code}
mkUniqueGrimily x = MkUnique x mkUniqueGrimily x = MkUnique x
mkUnifiableTyVarUnique i = mkUnique '_'{-MAGIC CHAR-} i incrUnique (MkUnique i) = MkUnique (i +# 1#)
unpkUnifiableTyVarUnique uniq
= case (unpkUnique uniq) of { (tag, i) ->
ASSERT(tag == '_'{-MAGIC CHAR-})
i }
-- pop the Char in the top 8 bits of the Unique(Supply) -- pop the Char in the top 8 bits of the Unique(Supply)
...@@ -375,9 +375,10 @@ chars62 ...@@ -375,9 +375,10 @@ chars62
%************************************************************************ %************************************************************************
Allocation of unique supply characters: Allocation of unique supply characters:
a-z: lower case chars for unique supplies (see Main.lhs) v,t,u : for renumbering value-, type- and usage- vars.
B: builtin (see UniqSupply.lhs) other a-z: lower case chars for unique supplies (see Main.lhs)
C-E: pseudo uniques (see UniqSupply.lhs) B: builtin
C-E: pseudo uniques (used in native-code generator)
_: unifiable tyvars (above) _: unifiable tyvars (above)
1-8: prelude things below 1-8: prelude things below
...@@ -393,6 +394,19 @@ mkTupleDataConUnique a = mkUnique '6' a -- ditto (*may* be used in C labels) ...@@ -393,6 +394,19 @@ mkTupleDataConUnique a = mkUnique '6' a -- ditto (*may* be used in C labels)
mkPrimOpIdUnique op = mkUnique '7' op mkPrimOpIdUnique op = mkUnique '7' op
mkPreludeMiscIdUnique i = mkUnique '8' i mkPreludeMiscIdUnique i = mkUnique '8' i
initRenumberingUniques = (mkUnique 'v' 1, mkUnique 't' 1, mkUnique 'u' 1)
mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
mkBuiltinUnique :: Int -> Unique
mkBuiltinUnique i = mkUnique 'B' i
mkPseudoUnique1 i = mkUnique 'C' i -- used for uniqueOf on Regs
mkPseudoUnique2 i = mkUnique 'D' i -- ditto
mkPseudoUnique3 i = mkUnique 'E' i -- ditto
getBuiltinUniques :: Int -> [Unique]
getBuiltinUniques n = map (mkUnique 'B') [1 .. n]
\end{code} \end{code}
%************************************************************************ %************************************************************************
......
...@@ -92,7 +92,7 @@ import PprType ( GenType{-instance Outputable-} ) ...@@ -92,7 +92,7 @@ import PprType ( GenType{-instance Outputable-} )
import PrimRep ( getPrimRepSize, separateByPtrFollowness ) import PrimRep ( getPrimRepSize, separateByPtrFollowness )
import SMRep -- all of it import SMRep -- all of it
import TyCon ( maybeTyConSingleCon, TyCon{-instance NamedThing-} ) import TyCon ( maybeTyConSingleCon, TyCon{-instance NamedThing-} )
import Type ( isPrimType, splitForAllTy, splitFunTy, mkFunTys ) import Type ( isPrimType, splitForAllTy, splitFunTyWithDictsAsArgs, mkFunTys )
import Util ( isIn, mapAccumL, panic, pprPanic, assertPanic )