Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
jberryman
GHC
Commits
dabfa71f
Commit
dabfa71f
authored
May 17, 1996
by
partain
Browse files
[project @ 1996-05-17 16:02:43 by partain]
Sansom 1.3 changes through 960507
parent
f3998ec1
Changes
68
Hide whitespace changes
Inline
Side-by-side
ghc/compiler/absCSyn/AbsCSyn.lhs
View file @
dabfa71f
...
...
@@ -31,11 +31,8 @@ module AbsCSyn {- (
-- registers
MagicId(..), node, infoptr,
isVolatileReg, noLiveRegsMask, mkLiveRegsMask
#ifdef GRAN
, CostRes(Cost)
#endif
isVolatileReg, noLiveRegsMask, mkLiveRegsMask,
CostRes(Cost)
)-} where
import Ubiq{-uitous-}
...
...
@@ -224,14 +221,12 @@ data CStmtMacro
| SET_ARITY
| CHK_ARITY
| SET_TAG
#ifdef GRAN
| GRAN_FETCH -- for GrAnSim only -- HWL
| GRAN_RESCHEDULE -- for GrAnSim only -- HWL
| GRAN_FETCH_AND_RESCHEDULE -- for GrAnSim only -- HWL
| THREAD_CONTEXT_SWITCH -- for GrAnSim only -- HWL
#endif
| GRAN_YIELD -- for GrAnSim only -- HWL
deriving Text
\end{code}
\item[@CCallProfCtrMacro@:]
...
...
@@ -440,7 +435,7 @@ data MagicId
-- Argument and return registers
| VanillaReg -- pointers, unboxed ints and chars
PrimRep -- PtrRep, IntRep, CharRep, StablePtrRep or
MallocPtr
Rep
PrimRep -- PtrRep, IntRep, CharRep, StablePtrRep or
ForeignObj
Rep
-- (in case we need to distinguish)
FAST_INT -- its number (1 .. mAX_Vanilla_REG)
...
...
ghc/compiler/absCSyn/CLabel.lhs
View file @
dabfa71f
...
...
@@ -43,10 +43,6 @@ module CLabel (
#if ! OMIT_NATIVE_CODEGEN
, pprCLabel_asm
#endif
#ifdef GRAN
, isSlowEntryCCodeBlock
#endif
) where
import Ubiq{-uitous-}
...
...
@@ -299,20 +295,10 @@ externallyVisibleCLabel (IdLabel (CLabelId id) _)
is_SuperDictSelId id = maybeToBool (isSuperDictSelId_maybe id)
\end{code}
These GRAN functions are needed for spitting out GRAN_FETCH() at the
OLD?:
These GRAN functions are needed for spitting out GRAN_FETCH() at the
right places. It is used to detect when the abstractC statement of an
CCodeBlock actually contains the code for a slow entry point. -- HWL
\begin{code}
#ifdef GRAN
isSlowEntryCCodeBlock :: CLabel -> Bool
isSlowEntryCCodeBlock _ = False
-- Worth keeping? ToDo (WDP)
#endif {-GRAN-}
\end{code}
We need at least @Eq@ for @CLabels@, because we want to avoid
duplicate declarations in generating C (see @labelSeenTE@ in
@PprAbsC@).
...
...
ghc/compiler/absCSyn/Costs.lhs
View file @
dabfa71f
...
...
@@ -60,28 +60,9 @@ module Costs( costs,
import Ubiq{-uitous-}
import AbsCSyn
import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
-- --------------------------------------------------------------------------
#ifndef GRAN
-- a module of "stubs" that don't do anything
data CostRes = Cost (Int, Int, Int, Int, Int)
data Side = Lhs | Rhs
nullCosts = Cost (0, 0, 0, 0, 0) :: CostRes
costs :: AbstractC -> CostRes
addrModeCosts :: CAddrMode -> Side -> CostRes
costs _ = nullCosts
addrModeCosts _ _ = nullCosts
instance Eq CostRes; instance Text CostRes
instance Num CostRes where
x + y = nullCosts
#else {-GRAN-}
-- the real thing
data CostRes = Cost (Int, Int, Int, Int, Int)
deriving (Text)
...
...
@@ -425,10 +406,7 @@ gmpOps =
]
-- Haven't found the .umul .div .rem macros yet
-- If they are not Haskell cde, they are not costed, yet
abs_costs = nullCosts -- NB: This is normal STG code with costs already
abs_costs = nullCosts -- NB: This is normal STG code with costs already
-- included; no need to add costs again.
umul_costs = Cost (21,4,0,0,0) -- due to spy counts
...
...
@@ -439,8 +417,10 @@ primOpCosts :: PrimOp -> CostRes
-- Special cases
primOpCosts (CCallOp _ _ _ _ _) = SAVE_COSTS + CCALL_COSTS_GUESS +
RESTORE_COSTS -- GUESS; check it
primOpCosts (CCallOp _ _ _ _ _) = SAVE_COSTS + RESTORE_COSTS
-- don't guess costs of ccall proper
-- for exact costing use a GRAN_EXEC
-- in the C code
-- Usually 3 mov instructions are needed to get args and res in right place.
...
...
@@ -484,7 +464,7 @@ primOpCosts FloatPowerOp = Cost (2, 1, 4, 4, 3)
primOpCosts primOp
| primOp `elem` floatOps = Cost (0, 0, 0, 0, 1) :: CostRes
| primOp `elem` gmpOps = Cost (
5
0, 5, 10, 10, 0) :: CostRes
-- GUESS; check it
| primOp `elem` gmpOps = Cost (
3
0, 5, 10, 10, 0) :: CostRes
-- GUESS; check it
| otherwise = Cost (1, 0, 0, 0, 0)
-- ---------------------------------------------------------------------------
...
...
@@ -502,8 +482,6 @@ costsByKind FloatRep _ = nullCosts
costsByKind DoubleRep _ = nullCosts
-}
-- ---------------------------------------------------------------------------
#endif {-GRAN-}
\end{code}
This is the data structure of {\tt PrimOp} copied from prelude/PrimOp.lhs.
...
...
@@ -601,8 +579,8 @@ data PrimOp
| IndexOffAddrOp PrimRep
-- PrimRep can be one of {Char,Int,Addr,Float,Double}Kind.
-- This is just a cheesy encoding of a bunch of ops.
-- Note that
MallocPtr
Rep is not included -- the only way of
-- creating a
MallocPtr
is with a ccall or casm.
-- Note that
ForeignObj
Rep is not included -- the only way of
-- creating a
ForeignObj
is with a ccall or casm.
| UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp
...
...
@@ -610,7 +588,11 @@ data PrimOp
\end{pseudocode}
A special ``trap-door'' to use in making calls direct to C functions:
Note: From GrAn point of view, CCall is probably very expensive -- HWL
Note: From GrAn point of view, CCall is probably very expensive
The programmer can specify the costs of the Ccall by inserting
a GRAN_EXEC(a,b,l,s,f) at the end of the C- code, specifing the
number or arithm., branch, load, store and floating point instructions
-- HWL
\begin{pseudocode}
| CCallOp String -- An "unboxed" ccall# to this named function
...
...
ghc/compiler/absCSyn/PprAbsC.lhs
View file @
dabfa71f
...
...
@@ -13,7 +13,7 @@
module PprAbsC (
writeRealC,
dumpRealC
#if
def
ined(
DEBUG
)
#ifdef
DEBUG
, pprAmode -- otherwise, not exported
#endif
) where
...
...
@@ -83,14 +83,11 @@ from a cost 5 tuple. %% HWL
\begin{code}
emitMacro :: CostRes -> Unpretty
#ifndef GRAN
emitMacro _ = uppNil
#else
-- ToDo: Check a compile time flag to decide whether a macro should be emitted
emitMacro (Cost (i,b,l,s,f))
= uppBesides [ uppStr "GRAN_EXEC(",
uppInt i, uppComma, uppInt b, uppComma, uppInt l, uppComma,
uppInt s, uppComma, uppInt f, pp_paren_semi ]
#endif {-GRAN-}
uppInt i, uppComma, uppInt b, uppComma, uppInt l, uppComma,
uppInt s, uppComma, uppInt f, pp_paren_semi ]
\end{code}
\begin{code}
...
...
@@ -577,9 +574,11 @@ Some rough notes on generating code for @CCallOp@:
(This happens after restoration of essential registers because we
might need the @Base@ register to access all the others correctly.)
{- Doesn't apply anymore with ForeignObj, structure create via primop.
makeForeignObj (ForeignObj is not CReturnable)
7) If returning Malloc Pointer, build a closure containing the
appropriate value.
-}
Otherwise, copy local variable into result register.
8) If ccall (not casm), declare the function being called as extern so
...
...
@@ -593,11 +592,7 @@ Some rough notes on generating code for @CCallOp@:
basic_restores;
restores;
#if MallocPtr
constructMallocPtr(liveness, return_reg, _ccall_result);
#else
return_reg = _ccall_result;
#end
return_reg = _ccall_result;
}
\end{pseudocode}
...
...
@@ -607,7 +602,7 @@ Amendment to the above: if we can GC, we have to:
can get at them.
* be sure that there are no live registers or we're in trouble.
(This can cause problems if you try something foolish like passing
an array or
mallocptr
to a _ccall_GC_ thing.)
an array or
foreign obj
to a _ccall_GC_ thing.)
* increment/decrement the @inCCallGC@ counter before/after the call so
that the runtime check that PerformGC is being used sensibly will work.
...
...
@@ -675,7 +670,7 @@ pprCCall sty op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vo
If the argument is a heap object, we need to reach inside and pull out
the bit the C world wants to see. The only heap objects which can be
passed are @Array@s, @ByteArray@s and @
MallocPtr
@s.
passed are @Array@s, @ByteArray@s and @
ForeignObj
@s.
\begin{code}
ppr_casm_arg :: PprStyle -> CAddrMode -> Int -> (Unpretty, Unpretty)
...
...
@@ -699,9 +694,9 @@ ppr_casm_arg sty amode a_num
ByteArrayRep -> (pp_kind,
uppBesides [uppStr "BYTE_ARR_CTS(", pp_amode, uppRparen])
-- for
Malloc Pointers, use MALLOC_PTR
_DATA to fish out the contents.
MallocPtr
Rep -> (uppPStr SLIT("Stg
MallocPtr
"),
uppBesides [uppStr "
MallocPtr
_CLOSURE_DATA(", pp_amode, uppStr")"])
-- for
ForeignObj, use FOREIGN_OBJ
_DATA to fish out the contents.
ForeignObj
Rep -> (uppPStr SLIT("Stg
ForeignObj
"),
uppBesides [uppStr "
ForeignObj
_CLOSURE_DATA(", pp_amode, uppStr")"])
other -> (pp_kind, pp_amode)
declare_local_var
...
...
@@ -716,10 +711,11 @@ For l-values, the critical questions are:
We only allow zero or one results.
2) Is the result is a mallocptr?
{- With the introduction of ForeignObj (MallocPtr++), no longer necess.
2) Is the result is a foreign obj?
The mallocptr must be encapsulated immediately in a heap object.
-}
\begin{code}
ppr_casm_results ::
PprStyle -- style
...
...
@@ -742,13 +738,20 @@ ppr_casm_results sty [r] liveness
(result_type, assign_result)
= case r_kind of
MallocPtrRep ->
(uppPStr SLIT("StgMallocPtr"),
uppBesides [ uppStr "constructMallocPtr(",
{- @ForeignObj@s replaces MallocPtrs and are *not* CReturnable.
Instead, external references have to be turned into ForeignObjs
using the primop makeForeignObj#. Benefit: Multiple finalisation
routines can be accommodated and the below special case is not needed.
Price is, of course, that you have to explicitly wrap `foreign objects'
with makeForeignObj#.
+
ForeignObjRep ->
(uppPStr SLIT("StgForeignObj"),
uppBesides [ uppStr "constructForeignObj(",
liveness, uppComma,
result_reg, uppComma,
local_var,
pp_paren_semi ])
pp_paren_semi ])
-}
_ ->
(pprPrimKind sty r_kind,
uppBesides [ result_reg, uppEquals, local_var, uppSemi ])
...
...
@@ -825,14 +828,6 @@ of the source addressing mode.) If the kind of the assignment is of
pprAssign :: PprStyle -> PrimRep -> CAddrMode -> CAddrMode -> Unpretty
pprAssign sty VoidRep dest src = uppNil
#if 0
pprAssign sty kind dest src
| (kind /= getAmodeRep dest) || (kind /= getAmodeRep src)
= uppCat [uppStr "Bad kind:", pprPrimKind sty kind,
pprPrimKind sty (getAmodeRep dest), pprAmode sty dest,
pprPrimKind sty (getAmodeRep src), pprAmode sty src]
#endif
\end{code}
Special treatment for floats and doubles, to avoid unwanted conversions.
...
...
@@ -1089,7 +1084,7 @@ pprUnionTag FloatRep = uppChar 'f'
pprUnionTag DoubleRep = panic "pprUnionTag:Double?"
pprUnionTag StablePtrRep = uppChar 'i'
pprUnionTag
MallocPtr
Rep = uppChar 'p'
pprUnionTag
ForeignObj
Rep = uppChar 'p'
pprUnionTag ArrayRep = uppChar 'p'
pprUnionTag ByteArrayRep = uppChar 'b'
...
...
ghc/compiler/basicTypes/Id.lhs
View file @
dabfa71f
...
...
@@ -1122,10 +1122,10 @@ no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty)
mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b
mkSysLocal str uniq ty loc
= Id uniq (mkLocalName uniq str loc) ty (SysLocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
= Id uniq (mkLocalName uniq str
True{-emph uniq-}
loc) ty (SysLocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
mkUserLocal str uniq ty loc
= Id uniq (mkLocalName uniq str loc) ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
= Id uniq (mkLocalName uniq str
False{-emph name-}
loc) ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
-- mkUserId builds a local or top-level Id, depending on the name given
mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b
...
...
ghc/compiler/basicTypes/Name.lhs
View file @
dabfa71f
...
...
@@ -147,21 +147,23 @@ showRdr sty rdr = ppShow 100 (ppr sty rdr)
data Name
= Local Unique
FAST_STRING
Bool -- True <=> emphasize Unique when
-- printing; this is just an esthetic thing...
SrcLoc
| Global Unique
RdrName
-- original name; Unqual => prelude
Provenance
-- where it came from
ExportFlag
-- is it exported?
[RdrName]
-- ordered occurrence names (usually just one);
-- first may be *un*qual.
RdrName
-- original name; Unqual => prelude
Provenance -- where it came from
ExportFlag -- is it exported?
[RdrName] -- ordered occurrence names (usually just one);
-- first may be *un*qual.
data Provenance
= LocalDef SrcLoc
-- locally defined; give its source location
| Imported ExportFlag
-- how it was imported
SrcLoc
-- *original* source location
[SrcLoc]
-- any import source location(s)
= LocalDef SrcLoc -- locally defined; give its source location
| Imported ExportFlag -- how it was imported
SrcLoc -- *original* source location
[SrcLoc] -- any import source location(s)
| Implicit
| Builtin
...
...
@@ -177,7 +179,8 @@ mkImplicitName :: Unique -> RdrName -> Name
mkImplicitName u o = Global u o Implicit NotExported []
mkBuiltinName :: Unique -> Module -> FAST_STRING -> Name
mkBuiltinName u m{-NB: unused(?)-} n = Global u (Unqual n) Builtin NotExported []
mkBuiltinName u m n
= Global u (if fromPrelude m then Unqual n else Qual m n) Builtin NotExported []
mkCompoundName :: Unique
-> FAST_STRING -- indicates what kind of compound thing it is (e.g., "sdsel")
...
...
@@ -185,7 +188,7 @@ mkCompoundName :: Unique
-> Name -- from which we get provenance, etc....
-> Name -- result!
mkCompoundName u str ns (Local _ _ _) = panic "mkCompoundName:Local?"
mkCompoundName u str ns (Local _ _
_
_) = panic "mkCompoundName:Local?"
mkCompoundName u str ns (Global _ _ prov exp _)
= Global u (Unqual{-???-} (_CONCAT_ (glue ns [str]))) prov exp []
...
...
@@ -226,8 +229,8 @@ mkTupNameStr n
-- ToDo: what about module ???
-- ToDo: exported when compiling builtin ???
isLocalName (Local _ _ _) = True
isLocalName _ = False
isLocalName (Local _ _
_
_) = True
isLocalName _
= False
isImplicitName (Global _ _ Implicit _ _) = True
isImplicitName _ = False
...
...
@@ -247,7 +250,7 @@ isBuiltinName _ = False
\begin{code}
cmpName n1 n2 = c n1 n2
where
c (Local u1 _ _
)
(Local u2 _ _
)
= cmp u1 u2
c (Local u1 _ _
_)
(Local u2 _ _
_)
= cmp u1 u2
c (Global u1 _ _ _ _) (Global u2 _ _ _ _) = cmp u1 u2
c other_1 other_2 -- the tags *must* be different
...
...
@@ -256,8 +259,8 @@ cmpName n1 n2 = c n1 n2
in
if tag1 _LT_ tag2 then LT_ else GT_
tag_Name (Local
_ _ _)
= (ILIT(1) :: FAST_INT)
tag_Name (Global
_ _ _ _ _) = ILIT(2)
tag_Name (Local
_
_ _ _) = (ILIT(1) :: FAST_INT)
tag_Name (Global _ _ _ _ _) = ILIT(2)
\end{code}
\begin{code}
...
...
@@ -282,31 +285,31 @@ instance NamedThing Name where
\end{code}
\begin{code}
nameUnique (Local
u _ _
)
= u
nameUnique (Global
u _ _ _ _) = u
nameUnique (Local u _ _
_)
= u
nameUnique (Global u _ _ _ _) = u
-- when we renumber/rename things, we need to be
-- able to change a Name's Unique to match the cached
-- one in the thing it's the name of. If you know what I mean.
changeUnique (Local _ n l)
u = Local u n l
changeUnique (Local _ n
b
l) u = Local u n
b
l
changeUnique n@(Global _ o p e os) u = ASSERT(not (isBuiltinName n))
Global u o p e os
nameOrigName (Local
_ n _
)
= Unqual n
nameOrigName (Global
_ orig _ _ _) = orig
nameOrigName (Local _ n _
_)
= Unqual n
nameOrigName (Global _ orig _ _ _) = orig
nameModuleNamePair (Local
_ n _) = (panic "nameModuleNamePair", n)
nameModuleNamePair (Global
_ (Unqual n) _ _ _) = (pRELUDE, n)
nameModuleNamePair (Global
_ (Qual m n) _ _ _) = (m, n)
nameModuleNamePair (Local _ n
_
_) = (panic "nameModuleNamePair", n)
nameModuleNamePair (Global _ (Unqual n) _ _ _) = (pRELUDE, n)
nameModuleNamePair (Global _ (Qual m n) _ _ _) = (m, n)
nameOccName (Local
_ n _)
= Unqual n
nameOccName (Global
_ orig _ _ [] ) = orig
nameOccName (Global
_ orig _ _ occs) = head occs
nameOccName (Local _ n _
_
) = Unqual n
nameOccName (Global _ orig _ _ [] ) = orig
nameOccName (Global _ orig _ _ occs) = head occs
nameExportFlag (Local
_ _ _)
= NotExported
nameExportFlag (Global
_ _ _ exp _) = exp
nameExportFlag (Local
_
_ _ _) = NotExported
nameExportFlag (Global _ _ _ exp _) = exp
nameSrcLoc (Local _ _ loc) = loc
nameSrcLoc (Local _ _
_
loc) = loc
nameSrcLoc (Global _ _ (LocalDef loc) _ _) = loc
nameSrcLoc (Global _ _ (Imported _ loc _) _ _) = loc
nameSrcLoc (Global _ _ Implicit _ _) = mkUnknownSrcLoc
...
...
@@ -315,27 +318,28 @@ nameSrcLoc (Global _ _ Builtin _ _) = mkBuiltinSrcLoc
nameImpLocs (Global _ _ (Imported _ _ locs) _ _) = locs
nameImpLocs _ = []
nameImportFlag (Local _ _ _)
= NotExported
nameImportFlag (Local
_
_ _ _) = NotExported
nameImportFlag (Global _ _ (LocalDef _) _ _) = ExportAll
nameImportFlag (Global _ _ (Imported exp _ _) _ _) = exp
nameImportFlag (Global _ _ Implicit _ _) = ExportAll
nameImportFlag (Global _ _ Builtin _ _) = ExportAll
isLocallyDefinedName (Local _ _ _) = True
isLocallyDefinedName (Local _ _
_
_) = True
isLocallyDefinedName (Global _ _ (LocalDef _) _ _) = True
isLocallyDefinedName (Global _ _ (Imported _ _ _) _ _) = False
isLocallyDefinedName (Global _ _ Implicit _ _) = False
isLocallyDefinedName (Global _ _ Builtin _ _) = False
isPreludeDefinedName (Local
_ n _
)
= False
isPreludeDefinedName (Global
_ orig _ _ _) = isUnqual orig
isPreludeDefinedName (Local _ n _
_)
= False
isPreludeDefinedName (Global _ orig _ _ _) = isUnqual orig
\end{code}
\begin{code}
instance Outputable Name where
ppr sty (Local u n _)
ppr sty (Local u n
emph_uniq
_)
| codeStyle sty = pprUnique u
| otherwise = ppBesides [pprUnique u, ppStr "{-", ppPStr n, ppStr "-}"]
| emph_uniq = ppBesides [pprUnique u, ppStr "{-", ppPStr n, ppStr "-}"]
| otherwise = ppBesides [ppPStr n, ppStr "{-", pprUnique u, ppStr "-}"]
ppr PprDebug (Global u o _ _ _) = ppBesides [ppr PprDebug o, ppStr "{-", pprUnique u, ppStr "-}"]
ppr PprForUser (Global u o _ _ [] ) = ppr PprForUser o
...
...
ghc/compiler/basicTypes/Unique.lhs
View file @
dabfa71f
...
...
@@ -107,9 +107,9 @@ module Unique (
ltDataConKey,
mainIdKey,
mainPrimIOIdKey,
mallocPtr
DataConKey,
mallocPtr
PrimTyConKey,
mallocPtr
TyConKey,
foreignObj
DataConKey,
foreignObj
PrimTyConKey,
foreignObj
TyConKey,
monadClassKey,
monadZeroClassKey,
monadPlusClassKey,
...
...
@@ -165,8 +165,8 @@ module Unique (
stateAndFloatPrimTyConKey,
stateAndIntPrimDataConKey,
stateAndIntPrimTyConKey,
stateAnd
MallocPtr
PrimDataConKey,
stateAnd
MallocPtr
PrimTyConKey,
stateAnd
ForeignObj
PrimDataConKey,
stateAnd
ForeignObj
PrimTyConKey,
stateAndMutableArrayPrimDataConKey,
stateAndMutableArrayPrimTyConKey,
stateAndMutableByteArrayPrimDataConKey,
...
...
@@ -195,13 +195,14 @@ module Unique (
wordDataConKey,
wordPrimTyConKey,
wordTyConKey
#ifdef GRAN
, copyableIdKey
, noFollowIdKey
, parAtAbsIdKey
, parAtForNowIdKey
, parAtIdKey
, parAtRelIdKey
, parGlobalIdKey
, parLocalIdKey
#endif
-- to make interface self-sufficient
) where
import PreludeGlaST
...
...
@@ -468,8 +469,8 @@ intTyConKey = mkPreludeTyConUnique 16
integerTyConKey = mkPreludeTyConUnique 17
liftTyConKey = mkPreludeTyConUnique 18
listTyConKey = mkPreludeTyConUnique 19
mallocPtr
PrimTyConKey = mkPreludeTyConUnique 20
mallocPtr
TyConKey = mkPreludeTyConUnique 21
foreignObj
PrimTyConKey = mkPreludeTyConUnique 20
foreignObj
TyConKey = mkPreludeTyConUnique 21
mutableArrayPrimTyConKey = mkPreludeTyConUnique 22
mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 23
orderingTyConKey = mkPreludeTyConUnique 24
...
...
@@ -488,7 +489,7 @@ stateAndCharPrimTyConKey = mkPreludeTyConUnique 36
stateAndDoublePrimTyConKey = mkPreludeTyConUnique 37
stateAndFloatPrimTyConKey = mkPreludeTyConUnique 38
stateAndIntPrimTyConKey = mkPreludeTyConUnique 39
stateAnd
MallocPtr
PrimTyConKey = mkPreludeTyConUnique 40
stateAnd
ForeignObj
PrimTyConKey = mkPreludeTyConUnique 40
stateAndMutableArrayPrimTyConKey = mkPreludeTyConUnique 41
stateAndMutableByteArrayPrimTyConKey = mkPreludeTyConUnique 42
stateAndSynchVarPrimTyConKey = mkPreludeTyConUnique 43
...
...
@@ -526,7 +527,7 @@ intDataConKey = mkPreludeDataConUnique 11
integerDataConKey = mkPreludeDataConUnique 12
liftDataConKey = mkPreludeDataConUnique 13
ltDataConKey = mkPreludeDataConUnique 14
mallocPtr
DataConKey = mkPreludeDataConUnique 15
foreignObj
DataConKey = mkPreludeDataConUnique 15
nilDataConKey = mkPreludeDataConUnique 18
ratioDataConKey = mkPreludeDataConUnique 21
return2GMPsDataConKey = mkPreludeDataConUnique 22
...
...
@@ -539,7 +540,7 @@ stateAndCharPrimDataConKey = mkPreludeDataConUnique 28
stateAndDoublePrimDataConKey = mkPreludeDataConUnique 29
stateAndFloatPrimDataConKey = mkPreludeDataConUnique 30
stateAndIntPrimDataConKey = mkPreludeDataConUnique 31
stateAnd
MallocPtr
PrimDataConKey = mkPreludeDataConUnique 32
stateAnd
ForeignObj
PrimDataConKey = mkPreludeDataConUnique 32
stateAndMutableArrayPrimDataConKey = mkPreludeDataConUnique 33
stateAndMutableByteArrayPrimDataConKey = mkPreludeDataConUnique 34
stateAndSynchVarPrimDataConKey = mkPreludeDataConUnique 35
...
...
@@ -593,12 +594,14 @@ nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 32
noDefaultMethodErrorIdKey = mkPreludeMiscIdUnique 33
nonExplicitMethodErrorIdKey = mkPreludeMiscIdUnique 34
#ifdef GRAN
parLocalIdKey = mkPreludeMiscIdUnique 35
parGlobalIdKey = mkPreludeMiscIdUnique 36
noFollowIdKey = mkPreludeMiscIdUnique 37
copyableIdKey = mkPreludeMiscIdUnique 38
#endif
copyableIdKey = mkPreludeMiscIdUnique 35
noFollowIdKey = mkPreludeMiscIdUnique 36
parAtAbsIdKey = mkPreludeMiscIdUnique 37
parAtForNowIdKey = mkPreludeMiscIdUnique 38
parAtIdKey = mkPreludeMiscIdUnique 39
parAtRelIdKey = mkPreludeMiscIdUnique 40
parGlobalIdKey = mkPreludeMiscIdUnique 41
parLocalIdKey = mkPreludeMiscIdUnique 42
\end{code}
Certain class operations from Prelude classes. They get
...
...
ghc/compiler/codeGen/CgCase.lhs
View file @
dabfa71f
...
...
@@ -30,21 +30,21 @@ import CgBindery ( getVolatileRegs, getArgAmode, getArgAmodes,
idInfoToAmode
)
import CgCon ( buildDynCon, bindConArgs )
import CgHeapery ( heapCheck )
import CgHeapery ( heapCheck
, yield
)
import CgRetConv ( dataReturnConvAlg, dataReturnConvPrim,
ctrlReturnConvAlg,
DataReturnConvention(..), CtrlReturnConvention(..),
assignPrimOpResultRegs,
makePrimOpArgsRobust
)
import CgStackery ( allocAStack, allocBStack )
import CgStackery ( allocAStack, allocBStack
, allocAStackTop, allocBStackTop
)
import CgTailCall ( tailCallBusiness, performReturn )
import CgUsages ( getSpARelOffset, getSpBRelOffset, freeBStkSlot )
import CLabel ( mkVecTblLabel, mkReturnPtLabel, mkDefaultLabel,
mkAltLabel, mkClosureLabel
)
import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynCon )
import CmdLineOpts ( opt_SccProfilingOn )
import CmdLineOpts ( opt_SccProfilingOn
, opt_GranMacros
)
import CostCentre ( useCurrentCostCentre )
import HeapOffs ( VirtualSpBOffset(..), VirtualHeapOffset(..) )
import Id ( idPrimRep, toplevelishId,
...
...
@@ -55,7 +55,9 @@ import Id ( idPrimRep, toplevelishId,
import Maybes ( catMaybes )
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instance Outputable-} )
import PrimOp ( primOpCanTriggerGC, PrimOp(..) )
import PrimOp ( primOpCanTriggerGC, PrimOp(..),
primOpStackRequired, StackRequirement(..)
)
import PrimRep ( getPrimRepSize, isFollowableRep, retPrimRepSize,
PrimRep(..)
)
...
...
@@ -173,10 +175,6 @@ cgCase scrut@(StgPrim op args _) live_in_whole_case live_in_alts uniq
panic "cgCase: case on PrimOp with default *and* alts\n"
-- For now, die if alts are non-empty
else
#if 0
pprTrace "cgCase:prim app returning alg data type: bad code!" (ppr PprDebug scrut) $
-- See above TO DO TO DO
#endif
cgExpr (StgLet (StgNonRec id scrut_rhs) deflt_rhs)
where
scrut_rhs = StgRhsClosure useCurrentCostCentre stgArgOcc{-safe-} scrut_free_vars
...
...
@@ -199,6 +197,8 @@ cgCase (StgPrim op args _) live_in_whole_case live_in_alts uniq alts
-- Perform the operation
getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
-- seq cannot happen here => no additional B Stack alloc
absC (COpStmt result_amodes op
arg_amodes -- note: no liveness arg
liveness_mask vol_regs) `thenC`
...
...
@@ -231,9 +231,29 @@ cgCase (StgPrim op args _) live_in_whole_case live_in_alts uniq alts
nukeDeadBindings live_in_whole_case `thenC`
saveVolatileVars live_in_alts `thenFC` \ volatile_var_save_assts ->
getEndOfBlockInfo `thenFC` \ eob_info ->
forkEval eob_info nopC
(getAbsC (cgInlineAlts GCMayHappen uniq alts) `thenFC` \ abs_c ->
-- Allocate stack words for the prim-op itself,
-- these are guaranteed to be ON TOP OF the stack.
-- Currently this is used *only* by the seq# primitive op.
let
(a_req,b_req) = case (primOpStackRequired op) of
NoStackRequired -> (0, 0)