Skip to content

GitLab

Commit dabfa71f authored by partain's avatar partain
Browse files

[project @ 1996-05-17 16:02:43 by partain] 

Sansom 1.3 changes through 960507
parent f3998ec1
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 MallocPtrRep
PrimRep -- PtrRep, IntRep, CharRep, StablePtrRep or ForeignObjRep
-- (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 (50, 5, 10, 10, 0) :: CostRes -- GUESS; check it
| primOp `elem` gmpOps = Cost (30, 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 MallocPtrRep is not included -- the only way of
-- creating a MallocPtr is with a ccall or casm.
-- Note that ForeignObjRep 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 defined(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.
MallocPtrRep -> (uppPStr SLIT("StgMallocPtr"),
uppBesides [uppStr "MallocPtr_CLOSURE_DATA(", pp_amode, uppStr")"])
-- for ForeignObj, use FOREIGN_OBJ_DATA to fish out the contents.
ForeignObjRep -> (uppPStr SLIT("StgForeignObj"),
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 MallocPtrRep = uppChar 'p'
pprUnionTag ForeignObjRep = 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,
mallocPtrDataConKey,
mallocPtrPrimTyConKey,
mallocPtrTyConKey,
foreignObjDataConKey,
foreignObjPrimTyConKey,
foreignObjTyConKey,
monadClassKey,
monadZeroClassKey,
monadPlusClassKey,
......@@ -165,8 +165,8 @@ module Unique (
stateAndFloatPrimTyConKey,
stateAndIntPrimDataConKey,
stateAndIntPrimTyConKey,
stateAndMallocPtrPrimDataConKey,
stateAndMallocPtrPrimTyConKey,
stateAndForeignObjPrimDataConKey,
stateAndForeignObjPrimTyConKey,
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
mallocPtrPrimTyConKey = mkPreludeTyConUnique 20
mallocPtrTyConKey = mkPreludeTyConUnique 21
foreignObjPrimTyConKey = mkPreludeTyConUnique 20
foreignObjTyConKey = 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
stateAndMallocPtrPrimTyConKey = mkPreludeTyConUnique 40
stateAndForeignObjPrimTyConKey = 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
mallocPtrDataConKey = mkPreludeDataConUnique 15
foreignObjDataConKey = 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
stateAndMallocPtrPrimDataConKey = mkPreludeDataConUnique 32
stateAndForeignObjPrimDataConKey = 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)