-- registers
MagicId(..), node, infoptr,
- isVolatileReg, noLiveRegsMask, mkLiveRegsMask
-
-#ifdef GRAN
- , CostRes(Cost)
-#endif
+ isVolatileReg, noLiveRegsMask, mkLiveRegsMask,
+ CostRes(Cost)
)-} where
import Ubiq{-uitous-}
| 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@:]
-- 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)
#if ! OMIT_NATIVE_CODEGEN
, pprCLabel_asm
#endif
-
-#ifdef GRAN
- , isSlowEntryCCodeBlock
-#endif
) where
import Ubiq{-uitous-}
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@).
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)
]
--- 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
-- 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.
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)
-- ---------------------------------------------------------------------------
costsByKind DoubleRep _ = nullCosts
-}
-- ---------------------------------------------------------------------------
-
-#endif {-GRAN-}
\end{code}
This is the data structure of {\tt PrimOp} copied from prelude/PrimOp.lhs.
| 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
\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
module PprAbsC (
writeRealC,
dumpRealC
-#if defined(DEBUG)
+#ifdef DEBUG
, pprAmode -- otherwise, not exported
#endif
) where
\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}
(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
basic_restores;
restores;
- #if MallocPtr
- constructMallocPtr(liveness, return_reg, _ccall_result);
- #else
- return_reg = _ccall_result;
- #end
+ return_reg = _ccall_result;
}
\end{pseudocode}
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.
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)
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
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
(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 ])
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.
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'
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
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
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")
-> 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 []
-- 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
\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
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}
\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
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
ltDataConKey,
mainIdKey,
mainPrimIOIdKey,
- mallocPtrDataConKey,
- mallocPtrPrimTyConKey,
- mallocPtrTyConKey,
+ foreignObjDataConKey,
+ foreignObjPrimTyConKey,
+ foreignObjTyConKey,
monadClassKey,
monadZeroClassKey,
monadPlusClassKey,
stateAndFloatPrimTyConKey,
stateAndIntPrimDataConKey,
stateAndIntPrimTyConKey,
- stateAndMallocPtrPrimDataConKey,
- stateAndMallocPtrPrimTyConKey,
+ stateAndForeignObjPrimDataConKey,
+ stateAndForeignObjPrimTyConKey,
stateAndMutableArrayPrimDataConKey,
stateAndMutableArrayPrimTyConKey,
stateAndMutableByteArrayPrimDataConKey,
wordDataConKey,
wordPrimTyConKey,
wordTyConKey
-#ifdef GRAN
, copyableIdKey
, noFollowIdKey
+ , parAtAbsIdKey
+ , parAtForNowIdKey
+ , parAtIdKey
+ , parAtRelIdKey
, parGlobalIdKey
, parLocalIdKey
-#endif
- -- to make interface self-sufficient
) where
import PreludeGlaST
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
stateAndDoublePrimTyConKey = mkPreludeTyConUnique 37
stateAndFloatPrimTyConKey = mkPreludeTyConUnique 38
stateAndIntPrimTyConKey = mkPreludeTyConUnique 39
-stateAndMallocPtrPrimTyConKey = mkPreludeTyConUnique 40
+stateAndForeignObjPrimTyConKey = mkPreludeTyConUnique 40
stateAndMutableArrayPrimTyConKey = mkPreludeTyConUnique 41
stateAndMutableByteArrayPrimTyConKey = mkPreludeTyConUnique 42
stateAndSynchVarPrimTyConKey = mkPreludeTyConUnique 43
integerDataConKey = mkPreludeDataConUnique 12
liftDataConKey = mkPreludeDataConUnique 13
ltDataConKey = mkPreludeDataConUnique 14
-mallocPtrDataConKey = mkPreludeDataConUnique 15
+foreignObjDataConKey = mkPreludeDataConUnique 15
nilDataConKey = mkPreludeDataConUnique 18
ratioDataConKey = mkPreludeDataConUnique 21
return2GMPsDataConKey = mkPreludeDataConUnique 22
stateAndDoublePrimDataConKey = mkPreludeDataConUnique 29
stateAndFloatPrimDataConKey = mkPreludeDataConUnique 30
stateAndIntPrimDataConKey = mkPreludeDataConUnique 31
-stateAndMallocPtrPrimDataConKey = mkPreludeDataConUnique 32
+stateAndForeignObjPrimDataConKey = mkPreludeDataConUnique 32
stateAndMutableArrayPrimDataConKey = mkPreludeDataConUnique 33
stateAndMutableByteArrayPrimDataConKey = mkPreludeDataConUnique 34
stateAndSynchVarPrimDataConKey = mkPreludeDataConUnique 35
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
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,
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(..)
)
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
-- 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`
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)
+ FixedStackRequired a b -> (a, b)
+ VariableStackRequired -> (0, 0) -- i.e. don't care
+ in
+ allocAStackTop a_req `thenFC` \ a_slot ->
+ allocBStackTop b_req `thenFC` \ b_slot ->
+
+ getEndOfBlockInfo `thenFC` \ eob_info@(EndOfBlockInfo args_spa args_spb sequel) ->
+ -- a_req and b_req allocate stack space that is taken care of by the
+ -- macros generated for the primops; thus, we there is no need to adjust
+ -- this part of the stacks later on (=> +a_req in EndOfBlockInfo)
+ -- currently all this is only used for SeqOp
+ forkEval (if True {- a_req==0 && b_req==0 -}
+ then eob_info
+ else (EndOfBlockInfo (args_spa+a_req)
+ (args_spb+b_req) sequel)) nopC
+ (
+ getAbsC (cgInlineAlts GCMayHappen uniq alts) `thenFC` \ abs_c ->
absC (CRetUnVector vtbl_label (CLabelledCode return_label abs_c))
`thenC`
returnFC (CaseAlts (CUnVecLbl return_label vtbl_label)
else
cgSemiTaggedAlts uniq alts deflt -- Just <something>
in
- cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts ty alts deflt
+ cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts ty alts deflt True
`thenFC` \ (tagged_alt_absCs, deflt_absC) ->
mkReturnVector uniq ty tagged_alt_absCs deflt_absC `thenFC` \ return_vec ->
-> Code
\end{code}
+HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): If
+we do an inlining of the case no separate functions for returning are
+created, so we don't have to generate a GRAN_YIELD in that case. This info
+must be propagated to cgAlgAltRhs (where the GRAN_YIELD macro might be
+emitted). Hence, the new Bool arg to cgAlgAltRhs.
+
First case: algebraic case, exactly one alternative, no default.
In this case the primitive op will not have set a temporary to the
tag, so we shouldn't generate a switch statment. Instead we just
\begin{code}
cgInlineAlts gc_flag uniq (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
- = cgAlgAltRhs gc_flag con args use_mask rhs
+ = cgAlgAltRhs gc_flag con args use_mask rhs False{-no yield macro if alt gets inlined-}
\end{code}
Second case: algebraic case, several alternatives.
\begin{code}
cgInlineAlts gc_flag uniq (StgAlgAlts ty alts deflt)
= cgAlgAlts gc_flag uniq AbsCNop{-restore_cc-} False{-no semi-tagging-}
- ty alts deflt `thenFC` \ (tagged_alts, deflt_c) ->
+ ty alts deflt
+ False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) ->
-- Do the switch
absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
In @cgAlgAlts@, none of the binders in the alternatives are
assumed to be yet bound.
+HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): The
+last arg of cgAlgAlts indicates if we want a context switch at the
+beginning of each alternative. Normally we want that. The only exception
+are inlined alternatives.
+
\begin{code}
cgAlgAlts :: GCFlag
-> Unique
-> Type -- From the case statement
-> [(Id, [Id], [Bool], StgExpr)] -- The alternatives
-> StgCaseDefault -- The default
+ -> Bool -- Context switch at alts?
-> FCode ([(ConTag, AbstractC)], -- The branches
AbstractC -- The default case
)
\begin{code}
cgAlgAlts gc_flag uniq restore_cc semi_tagging
ty alts deflt@(StgBindDefault binder True{-used-} _)
+ emit_yield{-should a yield macro be emitted?-}
= let
extra_branches :: [FCode (ConTag, AbstractC)]
extra_branches = catMaybes (map mk_extra_branch default_cons)
must_label_default = semi_tagging || not (null extra_branches)
in
- forkAlts (map (cgAlgAlt gc_flag uniq restore_cc semi_tagging) alts)
+ forkAlts (map (cgAlgAlt gc_flag uniq restore_cc semi_tagging emit_yield) alts)
extra_branches
- (cgAlgDefault gc_flag uniq restore_cc must_label_default deflt)
+ (cgAlgDefault gc_flag uniq restore_cc must_label_default deflt emit_yield)
where
default_join_lbl = mkDefaultLabel uniq
\begin{code}
cgAlgAlts gc_flag uniq restore_cc must_label_branches ty alts deflt
{- The deflt is either StgNoDefault or a BindDefault which doesn't use the binder -}
- = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches) alts)
+ emit_yield{-should a yield macro be emitted?-}
+
+ = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)
[{- No "extra branches" -}]
- (cgAlgDefault gc_flag uniq restore_cc must_label_branches deflt)
+ (cgAlgDefault gc_flag uniq restore_cc must_label_branches deflt emit_yield)
\end{code}
\begin{code}
cgAlgDefault :: GCFlag
-> Unique -> AbstractC -> Bool -- turgid state...
-> StgCaseDefault -- input
- -> FCode AbstractC -- output
+ -> Bool
+ -> FCode AbstractC -- output
cgAlgDefault gc_flag uniq restore_cc must_label_branch
- StgNoDefault
+ StgNoDefault _
= returnFC AbsCNop
cgAlgDefault gc_flag uniq restore_cc must_label_branch
(StgBindDefault _ False{-binder not used-} rhs)
+ emit_yield{-should a yield macro be emitted?-}
= getAbsC (absC restore_cc `thenC`
+ let
+ emit_gran_macros = opt_GranMacros
+ in
+ (if emit_gran_macros && emit_yield
+ then yield [] False
+ else absC AbsCNop) `thenC`
+ -- liveness same as in possibleHeapCheck below
possibleHeapCheck gc_flag [] False (cgExpr rhs)) `thenFC` \ abs_c ->
let
final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
cgAlgDefault gc_flag uniq restore_cc must_label_branch
(StgBindDefault binder True{-binder used-} rhs)
+ emit_yield{-should a yield macro be emitted?-}
= -- We have arranged that Node points to the thing, even
-- even if we return in registers
bindNewToReg binder node mkLFArgument `thenC`
getAbsC (absC restore_cc `thenC`
+ let
+ emit_gran_macros = opt_GranMacros
+ in
+ (if emit_gran_macros && emit_yield
+ then yield [node] False
+ else absC AbsCNop) `thenC`
+ -- liveness same as in possibleHeapCheck below
possibleHeapCheck gc_flag [node] False (cgExpr rhs)
-- Node is live, but doesn't need to point at the thing itself;
-- it's ok for Node to point to an indirection or FETCH_ME
where
lbl = mkDefaultLabel uniq
+-- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs
cgAlgAlt :: GCFlag
-> Unique -> AbstractC -> Bool -- turgid state
+ -> Bool -- Context switch at alts?
-> (Id, [Id], [Bool], StgExpr)
-> FCode (ConTag, AbstractC)
-cgAlgAlt gc_flag uniq restore_cc must_label_branch (con, args, use_mask, rhs)
+cgAlgAlt gc_flag uniq restore_cc must_label_branch
+ emit_yield{-should a yield macro be emitted?-}
+ (con, args, use_mask, rhs)
= getAbsC (absC restore_cc `thenC`
- cgAlgAltRhs gc_flag con args use_mask rhs) `thenFC` \ abs_c ->
+ cgAlgAltRhs gc_flag con args use_mask rhs
+ emit_yield
+ ) `thenFC` \ abs_c ->
let
final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
| otherwise = abs_c
tag = dataConTag con
lbl = mkAltLabel uniq tag
-cgAlgAltRhs :: GCFlag -> Id -> [Id] -> [Bool] -> StgExpr -> Code
-
-cgAlgAltRhs gc_flag con args use_mask rhs
+cgAlgAltRhs :: GCFlag
+ -> Id
+ -> [Id]
+ -> [Bool]
+ -> StgExpr
+ -> Bool -- context switch?
+ -> Code
+cgAlgAltRhs gc_flag con args use_mask rhs emit_yield
= let
(live_regs, node_reqd)
= case (dataReturnConvAlg con) of
-- enabled only the live registers will have valid
-- pointers in them.
in
+ let
+ emit_gran_macros = opt_GranMacros
+ in
+ (if emit_gran_macros && emit_yield
+ then yield live_regs node_reqd
+ else absC AbsCNop) `thenC`
+ -- liveness same as in possibleHeapCheck below
possibleHeapCheck gc_flag live_regs node_reqd (
(case gc_flag of
NoGC -> mapFCs bindNewToTemp args `thenFC` \ _ ->
import CgCompInfo ( spARelToInt, spBRelToInt )
import CgUpdate ( pushUpdateFrame )
import CgHeapery ( allocDynClosure, heapCheck
-#ifdef GRAN
- , fetchAndReschedule -- HWL
-#endif
+ , heapCheckOnly, fetchAndReschedule, yield -- HWL
)
import CgRetConv ( mkLiveRegsMask,
ctrlReturnConvAlg, dataReturnConvAlg,
mkErrorStdEntryLabel, mkRednCountsLabel
)
import ClosureInfo -- lots and lots of stuff
-import CmdLineOpts ( opt_EmitArityChecks, opt_ForConcurrent )
+import CmdLineOpts ( opt_ForConcurrent, opt_GranMacros )
import CostCentre ( useCurrentCostCentre, currentOrSubsumedCosts,
noCostCentreAttached, costsAreSubsumed,
isCafCC, overheadCostCentre
= getEntryConvention id lf_info
(map idPrimRep all_args) `thenFC` \ entry_conv ->
let
- do_arity_chks = opt_EmitArityChecks
is_concurrent = opt_ForConcurrent
stg_arity = length all_args
-- Now adjust real stack pointers
adjustRealSps spA_stk_args spB_stk_args `thenC`
- -- set the arity checker, if asked
- absC (
- if do_arity_chks
- then CMacroStmt SET_ARITY [mkIntCLit stg_arity]
- else AbsCNop
- ) `thenC`
absC (CFallThrough (CLbl fast_label CodePtrRep))
assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
CString (_PK_ (show_wrapper_name wrapper_maybe)),
CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
] `thenC`
- absC (
- if do_arity_chks
- then CMacroStmt CHK_ARITY [mkIntCLit stg_arity]
- else AbsCNop
- ) `thenC`
-- Bind args to regs/stack as appropriate, and
-- record expected position of sps
nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
-#ifdef GRAN
- -- HWL:
+ let
+ emit_gran_macros = opt_GranMacros
+ in
+
+ -- HWL ngo' ngoq:
-- absC (CMacroStmt GRAN_FETCH []) `thenC`
- -- forceHeapCheck [] node_points (absC AbsCNop) `thenC`
- (if node_points
- then fetchAndReschedule [] node_points
- else absC AbsCNop) `thenC`
-#endif {- GRAN -}
+ -- forceHeapCheck [] node_points (absC AbsCNop) `thenC`
+ (if emit_gran_macros
+ then if node_points
+ then fetchAndReschedule [] node_points
+ else yield [] node_points
+ else absC AbsCNop) `thenC`
getCAddrMode (last args) `thenFC` \ last_amode ->
if (isFollowableRep (getAmodeRep last_amode)) then
getSpARelOffset 0 `thenFC` \ (SpARel spA off) ->
let
- lit = mkIntCLit (spARelToInt spA off)
+ a_rel_int = spARelToInt spA off
+ a_rel_arg = mkIntCLit a_rel_int
in
+ ASSERT(a_rel_int /= 0)
if node_points then
- absC (CMacroStmt ARGS_CHK_A [lit])
+ absC (CMacroStmt ARGS_CHK_A [a_rel_arg])
else
- absC (CMacroStmt ARGS_CHK_A_LOAD_NODE [lit, set_Node_to_this])
+ absC (CMacroStmt ARGS_CHK_A_LOAD_NODE [a_rel_arg, set_Node_to_this])
else
getSpBRelOffset 0 `thenFC` \ (SpBRel spB off) ->
let
- lit = mkIntCLit (spBRelToInt spB off)
+ b_rel_int = spBRelToInt spB off
+ b_rel_arg = mkIntCLit b_rel_int
in
+ ASSERT(b_rel_int /= 0)
if node_points then
- absC (CMacroStmt ARGS_CHK_B [lit])
+ absC (CMacroStmt ARGS_CHK_B [b_rel_arg])
else
- absC (CMacroStmt ARGS_CHK_B_LOAD_NODE [lit, set_Node_to_this])
+ absC (CMacroStmt ARGS_CHK_B_LOAD_NODE [b_rel_arg, set_Node_to_this])
where
-- We must tell the arg-satis macro whether Node is pointing to
-- the closure or not. If it isn't so pointing, then we give to
= -- Stack and heap overflow checks
nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
-#ifdef GRAN
- -- HWL insert macros for GrAnSim if node is live here
- (if node_points
- then fetchAndReschedule [] node_points
- else absC AbsCNop) `thenC`
-#endif {- GRAN -}
+ let
+ emit_gran_macros = opt_GranMacros
+ in
+ -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
+ -- (we prefer fetchAndReschedule-style context switches to yield ones)
+ (if emit_gran_macros
+ then if node_points
+ then fetchAndReschedule [] node_points
+ else yield [] node_points
+ else absC AbsCNop) `thenC`
stackCheck closure_info [] node_points ( -- stackCheck *encloses* the rest
funWrapper closure_info arg_regs fun_body
= -- Stack overflow check
nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
+ let
+ emit_gran_macros = opt_GranMacros
+ in
+ -- HWL chu' ngoq:
+ (if emit_gran_macros
+ then yield arg_regs node_points
+ else absC AbsCNop) `thenC`
+
stackCheck closure_info arg_regs node_points ( -- stackCheck *encloses* the rest
-- Heap overflow check
closure_label = mkClosureLabel data_con
\end{code}
+The entry code for a constructor now loads the info ptr by indirecting
+node. The alternative is to load the info ptr in the enter-via-node
+sequence. There's is a trade-off here:
+
+ * If the architecture can perform an indirect jump through a
+ register in one instruction, or if the info ptr is not a
+ real register, then *not* loading the info ptr on an enter
+ is a win.
+
+ * If the enter-via-node code is identical whether we load the
+ info ptr or not, then doing it is a win (it means we don't
+ have to do it here).
+
+However, the gratuitous load here is miniscule compared to the
+gratuitous loads of the info ptr on each enter, so we go for the first
+option.
+
+-- Simon M. (6/5/96)
+
\begin{code}
mkConCodeAndInfo :: Id -- Data constructor
-> (ClosureInfo, Code) -- The info table
body_code
= profCtrC SLIT("RET_OLD_IN_REGS") [mkIntCLit (length regs_w_offsets)] `thenC`
- performReturn (mkAbstractCs (map move_to_reg regs_w_offsets))
+ performReturn (mkAbstractCs (load_infoptr : map move_to_reg regs_w_offsets))
(mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-})
emptyIdSet{-no live vars-}
in
= -- NB: We don't set CC when entering data (WDP 94/06)
profCtrC SLIT("RET_OLD_IN_HEAP") [mkIntCLit (length arg_things)] `thenC`
- performReturn AbsCNop -- Ptr to thing already in Node
+ performReturn (mkAbstractCs [load_infoptr]) -- Ptr to thing already in Node
(mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-})
emptyIdSet{-no live vars-}
in
move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC
move_to_reg (reg, offset)
= CAssign (CReg reg) (CVal (NodeRel offset) (magicIdPrimRep reg))
+
+ load_infoptr
+ = CAssign (CReg infoptr) (CMacroExpr DataPtrRep INFO_PTR [CReg node])
\end{code}
%************************************************************************
)
import PrimRep ( getPrimRepSize, PrimRep(..) )
import TyCon ( tyConDataCons )
-import Util ( panic, pprPanic )
+import Util ( panic, pprPanic, assertPanic )
\end{code}
This module provides the support code for @StgToAbstractC@ to deal
\begin{code}
cgExpr x@(StgPrim op args live_vars)
- = getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
+ = ASSERT(op /= SeqOp) -- can't handle SeqOp
+ getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
let
result_regs = assignPrimOpResultRegs op
result_amodes = map CReg result_regs
heapCheck,
allocHeap, allocDynClosure
-#ifdef GRAN
- -- new for GrAnSim HWL
- , heapCheckOnly, fetchAndReschedule
-#endif {- GRAN -}
+ -- new functions, basically inserting macro calls into Code -- HWL
+ , heapCheckOnly, fetchAndReschedule, yield
) where
import Ubiq{-uitous-}
%* *
%************************************************************************
-This is std code we replaced by the bits below for GrAnSim. -- HWL
+The new code for heapChecks. For GrAnSim the code for doing a heap check
+and doing a context switch has been separated. Especially, the HEAP_CHK
+macro only performs a heap check. THREAD_CONTEXT_SWITCH should be used for
+doing a context switch. GRAN_FETCH_AND_RESCHEDULE must be put at the
+beginning of every slow entry code in order to simulate the fetching of
+closures. If fetching is necessary (i.e. current closure is not local) then
+an automatic context switch is done.
\begin{code}
-#ifndef GRAN
-
-heapCheck :: [MagicId] -- Live registers
- -> Bool -- Node reqd after GC?
- -> Code
- -> Code
-
-heapCheck regs node_reqd code
- = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
- where
-
- do_heap_chk :: HeapOffset -> Code
- do_heap_chk words_required
- = absC (if isZeroOff(words_required) then AbsCNop else checking_code) `thenC`
- -- The test is *inside* the absC, to avoid black holes!
-
- -- Now we have set up the real heap pointer and checked there is
- -- enough space. It remains only to reflect this in the environment
-
- setRealHp words_required
-
- -- The "word_required" here is a fudge.
- -- *** IT DEPENDS ON THE DIRECTION ***, and on
- -- whether the Hp is moved the whole way all
- -- at once or not.
- where
- all_regs = if node_reqd then node:regs else regs
- liveness_mask = mkLiveRegsMask all_regs
-
- checking_code = CMacroStmt HEAP_CHK [
- mkIntCLit liveness_mask,
- COffset words_required,
- mkIntCLit (if node_reqd then 1 else 0)]
-#endif {- GRAN -}
-\end{code}
-
-The GrAnSim code for heapChecks. The code for doing a heap check and
-doing a context switch has been separated. Especially, the HEAP_CHK
-macro only performs a heap check. THREAD_CONTEXT_SWITCH should be used
-for doing a context switch. GRAN_FETCH_AND_RESCHEDULE must be put at
-the beginning of every slow entry code in order to simulate the
-fetching of closures. If fetching is necessary (i.e. current closure
-is not local) then an automatic context switch is done.
-
-\begin{code}
-#ifdef GRAN
-
heapCheck :: [MagicId] -- Live registers
-> Bool -- Node reqd after GC?
-> Code
-- Emit macro for simulating a fetch and then reschedule
fetchAndReschedule :: [MagicId] -- Live registers
- -> Bool -- Node reqd
+ -> Bool -- Node reqd?
-> Code
-fetchAndReschedule regs node_reqd =
+fetchAndReschedule regs node_reqd =
if (node `elem` regs || node_reqd)
then fetch_code `thenC` reschedule_code
else absC AbsCNop
--HWL: generate GRAN_FETCH macro for GrAnSim
-- currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai
fetch_code = absC (CMacroStmt GRAN_FETCH [])
+\end{code}
+
+The @GRAN_YIELD@ macro is taken from JSM's code for Concurrent Haskell. It
+allows to context-switch at places where @node@ is not alive (it uses the
+@Continue@ rather than the @EnterNodeCode@ function in the RTS). We emit
+this kind of macro at the beginning of the following kinds of basic bocks:
+\begin{itemize}
+ \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally
+ we use @fetchAndReschedule@ at a slow entry code.
+ \item Fast entry code (see @CgClosure.lhs@).
+ \item Alternatives in case expressions (@CLabelledCode@ structures), provided
+ that they are not inlined (see @CgCases.lhs@). These alternatives will
+ be turned into separate functions.
+\end{itemize}
+
+\begin{code}
+yield :: [MagicId] -- Live registers
+ -> Bool -- Node reqd?
+ -> Code
+
+yield regs node_reqd =
+ -- NB: node is not alive; that's why we use DO_YIELD rather than
+ -- GRAN_RESCHEDULE
+ yield_code
+ where
+ all_regs = if node_reqd then node:regs else regs
+ liveness_mask = mkLiveRegsMask all_regs
-#endif {- GRAN -}
+ yield_code = absC (CMacroStmt GRAN_YIELD [mkIntCLit liveness_mask])
\end{code}
%************************************************************************
import Maybes ( catMaybes )
import PprStyle ( PprStyle(..) )
import PprType ( TyCon{-instance Outputable-} )
-import PrelInfo ( integerDataCon )
import PrimOp ( primOpCanTriggerGC,
getPrimOpResultInfo, PrimOpResultInfo(..),
PrimOp{-instance Outputable-}
(reg_assignment, leftover_kinds)
= assignRegs [node, infoptr] -- taken...
(map typePrimRep arg_tys)
-
- is_prim_result_ty = data_con == integerDataCon -- ***HACK***! (WDP 95/11)
\end{code}
%************************************************************************
dataReturnConvPrim ByteArrayRep = VanillaReg ByteArrayRep ILIT(1)
dataReturnConvPrim StablePtrRep = VanillaReg StablePtrRep ILIT(1)
-dataReturnConvPrim MallocPtrRep = VanillaReg MallocPtrRep ILIT(1)
+dataReturnConvPrim ForeignObjRep = VanillaReg ForeignObjRep ILIT(1)
#ifdef DEBUG
dataReturnConvPrim PtrRep = panic "dataReturnConvPrim: PtrRep"
Bug: it is assumed that robust amodes cannot contain pointers. This
seems reasonable but isn't true. For example, \tr{Array#}'s
-\tr{MallocPtr#}'s are pointers. (This is only known to bite on
-\tr{_ccall_GC_} with a MallocPtr argument.)
+\tr{ForeignObj#}'s are pointers. (This is only known to bite on
+\tr{_ccall_GC_} with a ForeignObj argument.)
See after for some ADR comments...
#include "HsVersions.h"
module CgStackery (
- allocAStack, allocBStack, allocUpdateFrame,
+ allocAStack, allocBStack, allocAStackTop, allocBStackTop,
+ allocUpdateFrame,
adjustRealSps, getFinalStackHW,
mkVirtStkOffsets, mkStkAmodes
) where
(last_SpA_offset, last_SpB_offset, boxd_w_offsets, ubxd_w_offsets)
where
computeOffset offset thing
- = (offset + (getPrimRepSize . kind_fun) thing, (thing, offset+(1::Int)))
+ = (offset + (max 1 . getPrimRepSize . kind_fun) thing, (thing, offset+(1::Int)))
+ -- The "max 1" bit is ULTRA important
+ -- Why? mkVirtStkOffsets is the unique function that lays out function
+ -- arguments on the stack. The "max 1" ensures that every argument takes
+ -- at least one stack slot, even if it's of kind VoidKind that actually
+ -- takes no space at all.
+ -- This is important to make sure that argument satisfaction checks work
+ -- properly. Consider
+ -- f a b s# = (a,b)
+ -- where s# is a VoidKind. f's argument satisfaction check will check
+ -- that s# is on the B stack above SuB; but if s# takes zero space, the
+ -- check will be ARGS_B_CHK(0), which always succeeds. As a result, even
+ -- if a,b aren't available either, the PAP update won't trigger and
+ -- we are throughly hosed. (SLPJ 96/05)
\end{code}
@mkStackAmodes@ is a higher-level version of @mkStackOffsets@.
delete_block free_b slot = [s | s <- free_b, (s<slot) || (s>=slot+size)]
-- Retain slots which are not in the range
-- slot..slot+size-1
+
+-- Allocate a chunk ON TOP OF the stack
+allocAStackTop :: Int -> FCode VirtualSpAOffset
+allocAStackTop size info_down (MkCgState absC binds
+ ((virt_a, free_a, real_a, hw_a), b_usage, h_usage))
+ = (chosen_slot, MkCgState absC binds (new_a_usage, b_usage, h_usage))
+ where
+ push_virt_a = virt_a + size
+ chosen_slot = virt_a + 1
+ new_a_usage = (push_virt_a, free_a, real_a, hw_a `max` push_virt_a)
+ -- Adjust high water mark
+
+-- Allocate a chunk ON TOP OF the stack
+allocBStackTop :: Int -> FCode VirtualSpBOffset
+allocBStackTop size info_down (MkCgState absC binds
+ (a_usage, (virt_b, free_b, real_b, hw_b), h_usage))
+ = (chosen_slot, MkCgState absC binds (a_usage, new_b_usage, h_usage))
+ where
+ push_virt_b = virt_b + size
+ chosen_slot = virt_b+1
+ new_b_usage = (push_virt_b, free_b, real_b, hw_b `max` push_virt_b)
+ -- Adjust high water mark
\end{code}
@allocUpdateFrame@ allocates enough space for an update frame
import ClosureInfo ( nodeMustPointToIt,
getEntryConvention, EntryConvention(..)
)
-import CmdLineOpts ( opt_EmitArityChecks, opt_DoSemiTagging )
+import CmdLineOpts ( opt_DoSemiTagging )
import HeapOffs ( zeroOff, VirtualSpAOffset(..) )
import Id ( idType, dataConTyCon, dataConTag,
fIRST_TAG
-> Code
tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
- = let
- do_arity_chks = opt_EmitArityChecks
- in
- nodeMustPointToIt lf_info `thenFC` \ node_points ->
+ = nodeMustPointToIt lf_info `thenFC` \ node_points ->
getEntryConvention fun lf_info
(map getAmodeRep arg_amodes) `thenFC` \ entry_conv ->
`mkAbsCStmts`
CJump (CLbl lbl CodePtrRep))
DirectEntry lbl arity regs ->
- (regs, (if do_arity_chks
- then CMacroStmt SET_ARITY [mkIntCLit arity]
- else AbsCNop)
- `mkAbsCStmts` CJump (CLbl lbl CodePtrRep))
+ (regs, CJump (CLbl lbl CodePtrRep))
no_of_args = length arg_amodes
GenId{-instances-}
)
import Name ( isLocallyDefined, getSrcLoc )
-import PrelInfo ( liftDataCon, mkLiftTy, statePrimTyCon )
import TyCon ( isBoxedTyCon, TyCon{-instance-} )
import Type ( maybeAppDataTyConExpandingDicts, eqTy )
+import TysPrim ( statePrimTyCon )
+import TysWiredIn ( liftDataCon, mkLiftTy )
import UniqSupply ( getUnique, getUniques, splitUniqSupply, UniqSupply )
import Util ( zipEqual, zipWithEqual, assertPanic, panic )
maybeAppDataTyConExpandingDicts, eqTy
-- ,expandTy -- ToDo:rm
)
-import TyCon ( isPrimTyCon, tyConFamilySize )
+import TyCon ( isPrimTyCon )
import TyVar ( tyVarKind, GenTyVar{-instances-} )
import UniqSet ( emptyUniqSet, mkUniqSet, intersectUniqSets,
unionUniqSets, elementOfUniqSet, UniqSet(..)
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instances-} )
import Pretty ( ppAboves )
-import PrelInfo ( trueDataCon, falseDataCon,
- augmentId, buildId
- )
+import PrelVals ( augmentId, buildId )
import PrimOp ( primOpType, fragilePrimOp, PrimOp(..) )
import SrcLoc ( mkUnknownSrcLoc )
import TyVar ( isNullTyVarEnv, TyVarEnv(..) )
getFunTy_maybe, applyTy, isPrimType,
splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy
)
+import TysWiredIn ( trueDataCon, falseDataCon )
import UniqSupply ( initUs, returnUs, thenUs,
mapUs, mapAndUnzipUs, getUnique,
UniqSM(..), UniqSupply
import Maybes ( maybeToBool )
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instances-} )
-import PrelInfo ( byteArrayPrimTy, getStatePairingConInfo,
- packStringForCId, realWorldStatePrimTy,
- realWorldStateTy, realWorldTy, stateDataCon,
- stringTy )
import Pretty
+import PrelVals ( packStringForCId )
import PrimOp ( PrimOp(..) )
import Type ( isPrimType, maybeAppDataTyConExpandingDicts, eqTy )
+import TysPrim ( byteArrayPrimTy, realWorldTy, realWorldStatePrimTy )
+import TysWiredIn ( getStatePairingConInfo,
+ realWorldStateTy, stateDataCon,
+ stringTy
+ )
import Util ( pprPanic, pprError, panic )
maybeBoxedPrimType = panic "DsCCall.maybeBoxedPrimType"
\ body -> Case arg (AlgAlts [(box_data_con,[prim_arg],body)]
NoDefault)
)
- -- ... continued below ....
-\end{code}
-
-As an experiment, I'm going to unpack any "acceptably small"
-enumeration. This code will never get used in the main version
-because enumerations would have triggered type errors but I've
-disabled type-checking in my version. ADR
-
-To Will: It might be worth leaving this in (but commented out) until
-we decide what's happening with enumerations. ADR
-
-\begin{code}
-#if 0
- -- MAYBE LATER:
- -- Data types with a nullary constructors (enumeration)
- | isEnumerationType arg_ty && -- enumeration
- (length data_cons) <= 5 -- "acceptably short"
- = newSysLocalDs the_prim_arg_ty `thenDs` \ prim_arg ->
- let
- alts = [ (con, [], mkMachInt i) | (con,i) <- data_cons `zip` [0..] ]
- arg_tag = Case arg (AlgAlts alts) NoDefault
- in
-
- returnDs (Var prim_arg,
- \ body -> Case arg_tag (PrimAlts [(prim_arg, body)] NoDefault)
- )
-#endif
-\end{code}
-
-\begin{code}
- -- ... continued from above ....
| otherwise
= pprPanic "unboxArg: " (ppr PprDebug arg_ty)
where
\prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
)
-#if 0
- -- MAYBE LATER???
-
- -- Data types with several nullary constructors (Enumerated types)
- | isEnumerationType result_ty && -- Enumeration
- (length data_cons) <= 5 -- fairly short
- =
- newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
- newSysLocalDs intPrimTy `thenDs` \ prim_result_id ->
-
- mkConDs stateDataCon [realWorldTy] [Var prim_state_id] `thenDs` \ new_state ->
-
- let
- alts = [ (mkMachInt i, con) | (i, con) <- [0..] `zip` data_cons ]
- the_result = Case prim_result_id (PrimAlts alts) NoDefault
- in
-
- mkConDs (mkTupleCon 2)
- [result_ty, realWorldStateTy]
- [the_result, new_state] `thenDs` \ the_pair ->
- let
- the_alt = (state_and_prim_datacon, [prim_state_id, prim_result_id], the_pair)
- in
- returnDs (state_and_prim_ty,
- \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
- )
-#endif
-
| otherwise
= pprPanic "boxResult: " (ppr PprDebug result_ty)
import Name ( Name{--O only-} )
import PprStyle ( PprStyle(..) )
import PprType ( GenType )
-import PrelInfo ( mkTupleTy, unitTy, nilDataCon, consDataCon,
- charDataCon, charTy, rEC_CON_ERROR_ID,
- rEC_UPD_ERROR_ID
- )
+import PrelVals ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID )
import Pretty ( ppShow, ppBesides, ppPStr, ppStr )
import TyCon ( isDataTyCon, isNewTyCon )
import Type ( splitSigmaTy, splitFunTy, typePrimRep,
getAppDataTyConExpandingDicts, getAppTyCon, applyTy
)
+import TysWiredIn ( mkTupleTy, unitTy, nilDataCon, consDataCon,
+ charDataCon, charTy
+ )
import TyVar ( nullTyVarEnv, addOneToTyVarEnv, GenTyVar{-instance Eq-} )
import Usage ( UVar(..) )
import Util ( zipEqual, pprError, panic, assertPanic )
import DsUtils
import CoreUtils ( mkCoreIfThenElse )
-import PrelInfo ( stringTy, nON_EXHAUSTIVE_GUARDS_ERROR_ID )
+import PrelVals ( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
import PprStyle ( PprStyle(..) )
import Pretty ( ppShow )
import SrcLoc ( SrcLoc{-instance-} )
TypecheckedMonoBinds(..) )
import Id ( idType )
-import PrelInfo ( mkListTy, mkTupleTy, unitTy )
+import TysWiredIn ( mkListTy, mkTupleTy, unitTy )
import Util ( panic )
\end{code}
import CmdLineOpts ( opt_FoldrBuildOn )
import CoreUtils ( coreExprType, mkCoreIfThenElse )
-import PrelInfo ( nilDataCon, consDataCon, listTyCon,
- mkBuild, foldrId )
+import PrelVals ( mkBuild, foldrId )
import Type ( mkTyVarTy, mkForAllTy, mkFunTys )
import TysPrim ( alphaTy )
+import TysWiredIn ( nilDataCon, consDataCon, listTyCon )
import TyVar ( alphaTyVar )
import Match ( matchSimply )
import Util ( panic )
import CoreUtils ( coreExprType, mkCoreIfThenElse )
import PprStyle ( PprStyle(..) )
-import PrelInfo ( stringTy, iRREFUT_PAT_ERROR_ID )
+import PrelVals ( iRREFUT_PAT_ERROR_ID )
import Pretty ( ppShow )
import Id ( idType, dataConArgTys, mkTupleCon,
pprId{-ToDo:rm-},
)
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instance-}, GenTyVar{-ditto-} )
-import PrelInfo ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
- charTy, charDataCon, intTy, intDataCon,
- floatTy, floatDataCon, doubleTy, doubleDataCon,
- integerTy, intPrimTy, charPrimTy,
- floatPrimTy, doublePrimTy, stringTy,
- addrTy, addrPrimTy, addrDataCon,
- wordTy, wordPrimTy, wordDataCon,
- pAT_ERROR_ID
- )
+import PrelVals ( pAT_ERROR_ID )
import Type ( isPrimType, eqTy, getAppDataTyConExpandingDicts,
instantiateTauTy
)
import TyVar ( GenTyVar{-instance Eq-} )
+import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy,
+ addrPrimTy, wordPrimTy
+ )
+import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
+ charTy, charDataCon, intTy, intDataCon,
+ floatTy, floatDataCon, doubleTy,
+ doubleDataCon, integerTy, stringTy, addrTy,
+ addrDataCon, wordTy, wordDataCon
+ )
import Unique ( Unique{-instance Eq-} )
import Util ( panic, pprPanic, assertPanic )
\end{code}
opt_AutoSccsOnAllToplevs = lookup SLIT("-fauto-sccs-on-all-toplevs")
opt_AutoSccsOnExportedToplevs = lookup SLIT("-fauto-sccs-on-exported-toplevs")
opt_AutoSccsOnIndividualCafs = lookup SLIT("-fauto-sccs-on-individual-cafs")
-opt_CompilingPrelude = lookup SLIT("-prelude")
+opt_CompilingPrelude = lookup SLIT("-fcompiling-prelude")
opt_D_dump_absC = lookup SLIT("-ddump-absC")
opt_D_dump_asm = lookup SLIT("-ddump-asm")
opt_D_dump_deforest = lookup SLIT("-ddump-deforest")
opt_DoCoreLinting = lookup SLIT("-dcore-lint")
opt_DoSemiTagging = lookup SLIT("-fsemi-tagging")
opt_DoTickyProfiling = lookup SLIT("-fticky-ticky")
-opt_EmitArityChecks = lookup SLIT("-darity-checks")
opt_FoldrBuildOn = lookup SLIT("-ffoldr-build-on")
opt_FoldrBuildTrace = lookup SLIT("-ffoldr-build-trace")
opt_ForConcurrent = lookup SLIT("-fconcurrent")
+opt_GranMacros = lookup SLIT("-fgransim")
opt_GlasgowExts = lookup SLIT("-fglasgow-exts")
opt_Haskell_1_3 = lookup SLIT("-fhaskell-1.3")
opt_HideBuiltinNames = lookup SLIT("-fhide-builtin-names")
opt_OmitBlackHoling = lookup SLIT("-dno-black-holing")
opt_OmitDefaultInstanceMethods = lookup SLIT("-fomit-default-instance-methods")
opt_OmitInterfacePragmas = lookup SLIT("-fomit-interface-pragmas")
-opt_OmitReexportedInstances = lookup SLIT("-fomit-reexported-instances")
opt_PprStyle_All = lookup SLIT("-dppr-all")
opt_PprStyle_Debug = lookup SLIT("-dppr-debug")
opt_PprStyle_User = lookup SLIT("-dppr-user")
usages_list = fmToList usages
upp_uses (m, (mv, versions))
- = uppBesides [uppPStr m, uppSP, uppPStr SLIT(" :: "),
+ = uppBesides [uppPStr m, uppSP, uppInt mv, uppPStr SLIT(" :: "),
upp_versions (fmToList versions), uppSemi]
upp_versions nvs
- = uppIntersperse upp'SP{-'-} [ uppCat [uppPStr n, uppInt v] | (n,v) <- nvs ]
+ = uppIntersperse upp'SP{-'-} [ uppCat [(if isLexSym n then uppParens else id) (uppPStr n), uppInt v] | (n,v) <- nvs ]
\end{code}
\begin{code}
version_list = fmToList version_info
upp_versions nvs
- = uppAboves [ uppPStr n | (n,v) <- nvs ]
+ = uppAboves [ (if isLexSym n then uppParens else id) (uppPStr n) | (n,v) <- nvs ]
\end{code}
\begin{code}
ifaceDecls (Just if_hdl) (vals, tycons, classes, _)
= let
--- exported_classes = filter isExported classes
--- exported_tycons = filter isExported tycons
- exported_vals = filter isExported vals
+ togo_classes = [ c | c <- classes, isLocallyDefined c ]
+ togo_tycons = [ t | t <- tycons, isLocallyDefined t ]
+ togo_vals = [ v | v <- vals, isLocallyDefined v ]
- sorted_classes = sortLt ltLexical classes
- sorted_tycons = sortLt ltLexical tycons
- sorted_vals = sortLt ltLexical exported_vals
+ sorted_classes = sortLt ltLexical togo_classes
+ sorted_tycons = sortLt ltLexical togo_tycons
+ sorted_vals = sortLt ltLexical togo_vals
in
if (null sorted_classes && null sorted_tycons && null sorted_vals) then
-- You could have a module with just instances in it
ifaceInstances (Just if_hdl) (_, _, _, insts)
= let
- exported_insts = filter is_exported_inst (bagToList insts)
+ togo_insts = filter is_togo_inst (bagToList insts)
- sorted_insts = sortLt lt_inst exported_insts
+ sorted_insts = sortLt lt_inst togo_insts
in
- if null exported_insts then
+ if null togo_insts then
return ()
else
hPutStr if_hdl "\n__instances__\n" >>
hPutStr if_hdl (uppShow 0 (uppAboves (map pp_inst sorted_insts)))
where
- is_exported_inst (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _)
+ is_togo_inst (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _)
= from_here -- && ...
-------
primRepToSize ArrayRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,)))
primRepToSize ByteArrayRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,)))
primRepToSize StablePtrRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,)))
-primRepToSize MallocPtrRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,)))
+primRepToSize ForeignObjRep = IF_ARCH_alpha( Q, IF_ARCH_i386( L, IF_ARCH_sparc( W ,)))
\end{code}
%************************************************************************
Usually, this compiles to an assignment, but when the left-hand side
is empty, we just perform the call and ignore the result.
-ToDo ADR: modify this to handle Malloc Ptrs.
+ToDo ADR: modify this to handle ForeignObjs.
btw Why not let programmer use casm to provide assembly code instead
of C code? ADR
case getAmodeRep x of
ArrayRep -> StIndex PtrRep base mutHS
ByteArrayRep -> StIndex IntRep base dataHS
- MallocPtrRep -> error "ERROR: native-code generator can't handle Malloc Ptrs (yet): use -fvia-C!"
+ ForeignObjRep -> error "ERROR: native-code generator can't handle ForeignObjs (yet): use -fvia-C!"
_ -> base
\end{code}
module PrelInfo (
- pRELUDE, pRELUDE_BUILTIN, pRELUDE_CORE, pRELUDE_RATIO,
- pRELUDE_LIST, pRELUDE_TEXT,
- pRELUDE_PRIMIO, pRELUDE_IO, pRELUDE_PS,
- gLASGOW_ST, gLASGOW_MISC,
-
-- finite maps for built-in things (for the renamer and typechecker):
builtinNameInfo, BuiltinNames(..),
BuiltinKeys(..), BuiltinIdInfos(..),
- -- *odd* values that need to be reached out and grabbed:
- eRROR_ID,
- pAT_ERROR_ID,
- rEC_CON_ERROR_ID,
- rEC_UPD_ERROR_ID,
- iRREFUT_PAT_ERROR_ID,
- nON_EXHAUSTIVE_GUARDS_ERROR_ID,
- aBSENT_ERROR_ID,
- packStringForCId,
- unpackCStringId, unpackCString2Id,
- unpackCStringAppendId, unpackCStringFoldrId,
- integerZeroId, integerPlusOneId,
- integerPlusTwoId, integerMinusOneId,
-
- -----------------------------------------------------
- -- the rest of the export list is organised by *type*
- -----------------------------------------------------
-
- -- type: Bool
- boolTyCon, boolTy, falseDataCon, trueDataCon,
-
- -- types: Char#, Char, String (= [Char])
- charPrimTy, charTy, stringTy,
- charPrimTyCon, charTyCon, charDataCon,
-
- -- type: Ordering (used in deriving)
- orderingTy, ltDataCon, eqDataCon, gtDataCon,
-
- -- types: Double#, Double
- doublePrimTy, doubleTy,
- doublePrimTyCon, doubleTyCon, doubleDataCon,
-
- -- types: Float#, Float
- floatPrimTy, floatTy,
- floatPrimTyCon, floatTyCon, floatDataCon,
-
- -- types: Glasgow *primitive* arrays, sequencing and I/O
- mkPrimIoTy, -- to typecheck "mainPrimIO" & for _ccall_s
- realWorldStatePrimTy, realWorldStateTy{-boxed-},
- realWorldTy, realWorldTyCon, realWorldPrimId,
- statePrimTyCon, stateDataCon, getStatePairingConInfo,
-
- byteArrayPrimTy,
-
- -- types: Void# (only used within the compiler)
- voidPrimTy, voidPrimId,
-
- -- types: Addr#, Int#, Word#, Int
- intPrimTy, intTy, intPrimTyCon, intTyCon, intDataCon,
- wordPrimTyCon, wordPrimTy, wordTy, wordTyCon, wordDataCon,
- addrPrimTyCon, addrPrimTy, addrTy, addrTyCon, addrDataCon,
- maybeIntLikeTyCon, maybeCharLikeTyCon,
-
- -- types: Integer, Rational (= Ratio Integer)
- integerTy, rationalTy,
- integerTyCon, integerDataCon,
- rationalTyCon, ratioDataCon,
-
- -- type: Lift
- liftTyCon, liftDataCon, mkLiftTy,
-
- -- type: List
- listTyCon, mkListTy, nilDataCon, consDataCon,
-
- -- type: tuples
- mkTupleTy, unitTy,
-
- -- for compilation of List Comprehensions and foldr
- foldlId, foldrId,
- mkBuild, buildId, augmentId, appendId
-
- -- and, finally, we must put in some (abstract) data types,
- -- to make the interface self-sufficient
+ maybeCharLikeTyCon, maybeIntLikeTyCon
) where
import Ubiq
, doublePrimTyCon
, floatPrimTyCon
, intPrimTyCon
- , mallocPtrPrimTyCon
+ , foreignObjPrimTyCon
, mutableArrayPrimTyCon
, mutableByteArrayPrimTyCon
, synchVarPrimTyCon
, intTyCon
, integerTyCon
, liftTyCon
- , mallocPtrTyCon
+ , foreignObjTyCon
, ratioTyCon
, return2GMPsTyCon
, returnIntAndGMPTyCon
, stateAndDoublePrimTyCon
, stateAndFloatPrimTyCon
, stateAndIntPrimTyCon
- , stateAndMallocPtrPrimTyCon
+ , stateAndForeignObjPrimTyCon
, stateAndMutableArrayPrimTyCon
, stateAndMutableByteArrayPrimTyCon
, stateAndSynchVarPrimTyCon
else
[ parId
, forkId
-#ifdef GRAN
- , parLocalId
+ , copyableId
+ , noFollowId
+ , parAtAbsId
+ , parAtForNowId
+ , parAtId
+ , parAtRelId
, parGlobalId
- -- Add later:
- -- ,parAtId
- -- ,parAtForNowId
- -- ,copyableId
- -- ,noFollowId
-#endif {-GRAN-}
+ , parLocalId
]
pcIdWiredInInfo :: Id -> (FAST_STRING, RnName)
class_keys
= [ (s, (k, RnImplicitClass)) | (s,k) <-
[ (SLIT("Eq"), eqClassKey) -- mentioned, derivable
+ , (SLIT("Eval"), evalClassKey) -- mentioned
, (SLIT("Ord"), ordClassKey) -- derivable
, (SLIT("Num"), numClassKey) -- mentioned, numeric
, (SLIT("Real"), realClassKey) -- numeric
, (SLIT("RealFrac"), realFracClassKey) -- numeric
, (SLIT("RealFloat"), realFloatClassKey) -- numeric
-- , (SLIT("Ix"), ixClassKey) -- derivable (but it isn't Prelude.Ix; hmmm)
+ -- see *hack* in Rename
, (SLIT("Bounded"), boundedClassKey) -- derivable
, (SLIT("Enum"), enumClassKey) -- derivable
, (SLIT("Show"), showClassKey) -- derivable
#include "HsVersions.h"
module PrelMods (
- pRELUDE, pRELUDE_BUILTIN, pRELUDE_CORE, pRELUDE_RATIO,
+ pRELUDE, pRELUDE_BUILTIN,
pRELUDE_LIST, pRELUDE_TEXT,
pRELUDE_PRIMIO, pRELUDE_IO, pRELUDE_PS,
gLASGOW_ST, gLASGOW_MISC,
- pRELUDE_FB, fromPrelude
+ pRELUDE_FB,
+ rATIO,
+
+ fromPrelude
) where
CHK_Ubiq() -- debugging consistency check
gLASGOW_ST = SLIT("PreludeGlaST")
pRELUDE = SLIT("Prelude")
pRELUDE_BUILTIN = SLIT("PreludeBuiltin")
-pRELUDE_CORE = SLIT("PreludeCore")
pRELUDE_FB = SLIT("PreludeFoldrBuild")
pRELUDE_IO = SLIT("PreludeIO")
pRELUDE_LIST = SLIT("PreludeList")
pRELUDE_PRIMIO = SLIT("PreludePrimIO")
pRELUDE_PS = SLIT("PreludePS")
-pRELUDE_RATIO = SLIT("PreludeRatio")
pRELUDE_TEXT = SLIT("PreludeText")
+rATIO = SLIT("Ratio")
+
fromPrelude :: FAST_STRING -> Bool
fromPrelude s = (_SUBSTR_ s 0 6 == SLIT("Prelude"))
\end{code}
import Literal ( mkMachInt )
import PrimOp ( PrimOp(..) )
import SpecEnv ( SpecEnv(..), nullSpecEnv )
-import TyVar ( alphaTyVar, betaTyVar )
+import TyVar ( alphaTyVar, betaTyVar, gammaTyVar )
import Unique -- lots of *Keys
import Util ( panic )
\end{code}
+1, +2, and -1 (go ahead, fire me):
\begin{code}
integerZeroId
- = pcMiscPrelId integerZeroIdKey pRELUDE_CORE SLIT("__integer0") integerTy noIdInfo
+ = pcMiscPrelId integerZeroIdKey pRELUDE SLIT("__integer0") integerTy noIdInfo
integerPlusOneId
- = pcMiscPrelId integerPlusOneIdKey pRELUDE_CORE SLIT("__integer1") integerTy noIdInfo
+ = pcMiscPrelId integerPlusOneIdKey pRELUDE SLIT("__integer1") integerTy noIdInfo
integerPlusTwoId
- = pcMiscPrelId integerPlusTwoIdKey pRELUDE_CORE SLIT("__integer2") integerTy noIdInfo
+ = pcMiscPrelId integerPlusTwoIdKey pRELUDE SLIT("__integer2") integerTy noIdInfo
integerMinusOneId
- = pcMiscPrelId integerMinusOneIdKey pRELUDE_CORE SLIT("__integerm1") integerTy noIdInfo
+ = pcMiscPrelId integerMinusOneIdKey pRELUDE SLIT("__integerm1") integerTy noIdInfo
\end{code}
%************************************************************************
\end{code}
+GranSim ones:
\begin{code}
-#ifdef GRAN
-
parLocalId = pcMiscPrelId parLocalIdKey pRELUDE_BUILTIN SLIT("_parLocal_")
(mkSigmaTy [alphaTyVar, betaTyVar] []
- (mkFunTys [intPrimTy, alphaTy, betaTy] betaTy))
+ (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
(noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parLocal_template))
where
- [w, x, y, z]
+ -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
+ [w, g, s, p, x, y, z]
= mkTemplateLocals [
{-w-} intPrimTy,
+ {-g-} intPrimTy,
+ {-s-} intPrimTy,
+ {-p-} intPrimTy,
{-x-} alphaTy,
{-y-} betaTy,
- {-z-} betaTy
+ {-z-} intPrimTy
]
parLocal_template
- = mkLam [alphaTyVar, betaTyVar] [w, x, y] (
- Case (Prim ParLocalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg y]) (
- AlgAlts
- [(liftDataCon, [z], Var z)]
- (NoDefault)))
+ = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, x, y] (
+ Case (Prim ParLocalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
+ PrimAlts
+ [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
+ (BindDefault z (Var y))))
parGlobalId = pcMiscPrelId parGlobalIdKey pRELUDE_BUILTIN SLIT("_parGlobal_")
(mkSigmaTy [alphaTyVar, betaTyVar] []
- (mkFunTys [intPrimTy,alphaTy,betaTy] betaTy))
+ (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
(noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parGlobal_template))
where
- [w, x, y, z]
+ -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
+ [w, g, s, p, x, y, z]
= mkTemplateLocals [
{-w-} intPrimTy,
+ {-g-} intPrimTy,
+ {-s-} intPrimTy,
+ {-p-} intPrimTy,
{-x-} alphaTy,
{-y-} betaTy,
- {-z-} betaTy
+ {-z-} intPrimTy
]
parGlobal_template
- = mkLam [alphaTyVar, betaTyVar] [w, x, y] (
- Case (Prim ParGlobalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg y]) (
- AlgAlts
- [(liftDataCon, [z], Var z)]
- (NoDefault)))
+ = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, x, y] (
+ Case (Prim ParGlobalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
+ PrimAlts
+ [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
+ (BindDefault z (Var y))))
+
+
+parAtId = pcMiscPrelId parAtIdKey pRELUDE_BUILTIN SLIT("_parAt_")
+ (mkSigmaTy [alphaTyVar, betaTyVar] []
+ (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
+ alphaTy, betaTy, gammaTy] gammaTy))
+ (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAt_template))
+ where
+ -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
+ [w, g, s, p, v, x, y, z]
+ = mkTemplateLocals [
+ {-w-} intPrimTy,
+ {-g-} intPrimTy,
+ {-s-} intPrimTy,
+ {-p-} intPrimTy,
+ {-v-} alphaTy,
+ {-x-} betaTy,
+ {-y-} gammaTy,
+ {-z-} intPrimTy
+ ]
+
+ parAt_template
+ = mkLam [alphaTyVar, betaTyVar, gammaTyVar] [w, g, s, p, v, x, y] (
+ Case (Prim ParAtOp [TyArg alphaTy, TyArg betaTy, TyArg gammaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
+ PrimAlts
+ [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
+ (BindDefault z (Var y))))
+
+parAtAbsId = pcMiscPrelId parAtAbsIdKey pRELUDE_BUILTIN SLIT("_parAtAbs_")
+ (mkSigmaTy [alphaTyVar, betaTyVar] []
+ (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
+ (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtAbs_template))
+ where
+ -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
+ [w, g, s, p, v, x, y, z]
+ = mkTemplateLocals [
+ {-w-} intPrimTy,
+ {-g-} intPrimTy,
+ {-s-} intPrimTy,
+ {-p-} intPrimTy,
+ {-v-} intPrimTy,
+ {-x-} alphaTy,
+ {-y-} betaTy,
+ {-z-} intPrimTy
+ ]
+
+ parAtAbs_template
+ = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, v, x, y] (
+ Case (Prim ParAtAbsOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
+ PrimAlts
+ [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
+ (BindDefault z (Var y))))
+
+parAtRelId = pcMiscPrelId parAtRelIdKey pRELUDE_BUILTIN SLIT("_parAtRel_")
+ (mkSigmaTy [alphaTyVar, betaTyVar] []
+ (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
+ (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtRel_template))
+ where
+ -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
+ [w, g, s, p, v, x, y, z]
+ = mkTemplateLocals [
+ {-w-} intPrimTy,
+ {-g-} intPrimTy,
+ {-s-} intPrimTy,
+ {-p-} intPrimTy,
+ {-v-} intPrimTy,
+ {-x-} alphaTy,
+ {-y-} betaTy,
+ {-z-} intPrimTy
+ ]
+
+ parAtRel_template
+ = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, v, x, y] (
+ Case (Prim ParAtRelOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
+ PrimAlts
+ [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
+ (BindDefault z (Var y))))
+
+parAtForNowId = pcMiscPrelId parAtForNowIdKey pRELUDE_BUILTIN SLIT("_parAtForNow_")
+ (mkSigmaTy [alphaTyVar, betaTyVar] []
+ (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
+ alphaTy, betaTy, gammaTy] gammaTy))
+ (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtForNow_template))
+ where
+ -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
+ [w, g, s, p, v, x, y, z]
+ = mkTemplateLocals [
+ {-w-} intPrimTy,
+ {-g-} intPrimTy,
+ {-s-} intPrimTy,
+ {-p-} intPrimTy,
+ {-v-} alphaTy,
+ {-x-} betaTy,
+ {-y-} gammaTy,
+ {-z-} intPrimTy
+ ]
+
+ parAtForNow_template
+ = mkLam [alphaTyVar, betaTyVar, gammaTyVar] [w, g, s, p, v, x, y] (
+ Case (Prim ParAtForNowOp [TyArg alphaTy, TyArg betaTy, TyArg gammaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) (
+ PrimAlts
+ [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
+ (BindDefault z (Var y))))
+
+-- copyable and noFollow are currently merely hooks: they are translated into
+-- calls to the macros COPYABLE and NOFOLLOW -- HWL
+
+copyableId = pcMiscPrelId copyableIdKey pRELUDE_BUILTIN SLIT("_copyable_")
+ (mkSigmaTy [alphaTyVar] []
+ alphaTy)
+ (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding copyable_template))
+ where
+ -- Annotations: x: closure that's tagged to by copyable
+ [x, z]
+ = mkTemplateLocals [
+ {-x-} alphaTy,
+ {-z-} alphaTy
+ ]
+
+ copyable_template
+ = mkLam [alphaTyVar] [x] ( Prim CopyableOp [TyArg alphaTy, VarArg x] )
+
+noFollowId = pcMiscPrelId noFollowIdKey pRELUDE_BUILTIN SLIT("_noFollow_")
+ (mkSigmaTy [alphaTyVar] []
+ alphaTy)
+ (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding noFollow_template))
+ where
+ -- Annotations: x: closure that's tagged to not follow
+ [x, z]
+ = mkTemplateLocals [
+ {-x-} alphaTy,
+ {-z-} alphaTy
+ ]
-#endif {-GRAN-}
+ noFollow_template
+ = mkLam [alphaTyVar] [x] ( Prim NoFollowOp [TyArg alphaTy, VarArg x] )
\end{code}
%************************************************************************
\begin{code}
buildId
- = pcMiscPrelId buildIdKey pRELUDE_CORE SLIT("_build") buildTy
+ = pcMiscPrelId buildIdKey pRELUDE_BUILTIN SLIT("_build") buildTy
((((noIdInfo
{-LATER:`addInfo_UF` mkMagicUnfolding buildIdKey-})
`addInfo` mkStrictnessInfo [WwStrict] Nothing)
\begin{code}
augmentId
- = pcMiscPrelId augmentIdKey pRELUDE_CORE SLIT("_augment") augmentTy
+ = pcMiscPrelId augmentIdKey pRELUDE_BUILTIN SLIT("_augment") augmentTy
(((noIdInfo
{-LATER:`addInfo_UF` mkMagicUnfolding augmentIdKey-})
`addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
primOpOkForSpeculation, primOpIsCheap,
fragilePrimOp,
HeapRequirement(..), primOpHeapReq,
+ StackRequirement(..), primOpStackRequired,
-- export for the Native Code Generator
primOpInfo, -- needed for primOpNameInfo
import Type ( getAppDataTyConExpandingDicts, maybeAppDataTyConExpandingDicts,
mkForAllTys, mkFunTys, applyTyCon, typePrimRep
)
-import TyVar ( alphaTyVar, betaTyVar, GenTyVar{-instance Eq-} )
+import TyVar ( alphaTyVar, betaTyVar, gammaTyVar, GenTyVar{-instance Eq-} )
import Unique ( Unique{-instance Eq-} )
import Util ( panic#, assoc, panic{-ToDo:rm-} )
\end{code}
| 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
| TakeMVarOp | PutMVarOp
| ReadIVarOp | WriteIVarOp
+ | MakeForeignObjOp -- foreign objects (malloc pointers or any old URL)
| MakeStablePtrOp | DeRefStablePtrOp
\end{code}
| ParOp
| ForkOp
- -- two for concurrency
+ -- three for concurrency
| DelayOp
- | WaitOp
+ | WaitReadOp
+ | WaitWriteOp
-#ifdef GRAN
| ParGlobalOp -- named global par
| ParLocalOp -- named local par
| ParAtOp -- specifies destination of local par
+ | ParAtAbsOp -- specifies destination of local par (abs processor)
+ | ParAtRelOp -- specifies destination of local par (rel processor)
| ParAtForNowOp -- specifies initial destination of global par
| CopyableOp -- marks copyable code
| NoFollowOp -- marks non-followup expression
-#endif {-GRAN-}
\end{code}
Deriving Ix is what we really want! ToDo
tagOf_PrimOp PutMVarOp = ILIT(152)
tagOf_PrimOp ReadIVarOp = ILIT(153)
tagOf_PrimOp WriteIVarOp = ILIT(154)
-tagOf_PrimOp MakeStablePtrOp = ILIT(155)
-tagOf_PrimOp DeRefStablePtrOp = ILIT(156)
-tagOf_PrimOp (CCallOp _ _ _ _ _) = ILIT(157)
-tagOf_PrimOp ErrorIOPrimOp = ILIT(158)
-tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(159)
-tagOf_PrimOp SeqOp = ILIT(160)
-tagOf_PrimOp ParOp = ILIT(161)
-tagOf_PrimOp ForkOp = ILIT(162)
-tagOf_PrimOp DelayOp = ILIT(163)
-tagOf_PrimOp WaitOp = ILIT(164)
-
-#ifdef GRAN
-tagOf_PrimOp ParGlobalOp = ILIT(165)
-tagOf_PrimOp ParLocalOp = ILIT(166)
-tagOf_PrimOp ParAtOp = ILIT(167)
-tagOf_PrimOp ParAtForNowOp = ILIT(168)
-tagOf_PrimOp CopyableOp = ILIT(169)
-tagOf_PrimOp NoFollowOp = ILIT(170)
-#endif {-GRAN-}
+tagOf_PrimOp MakeForeignObjOp = ILIT(155)
+tagOf_PrimOp MakeStablePtrOp = ILIT(156)
+tagOf_PrimOp DeRefStablePtrOp = ILIT(157)
+tagOf_PrimOp (CCallOp _ _ _ _ _) = ILIT(158)
+tagOf_PrimOp ErrorIOPrimOp = ILIT(159)
+tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(160)
+tagOf_PrimOp SeqOp = ILIT(161)
+tagOf_PrimOp ParOp = ILIT(162)
+tagOf_PrimOp ForkOp = ILIT(163)
+tagOf_PrimOp DelayOp = ILIT(164)
+tagOf_PrimOp WaitReadOp = ILIT(165)
+tagOf_PrimOp WaitWriteOp = ILIT(166)
+
+tagOf_PrimOp ParGlobalOp = ILIT(167)
+tagOf_PrimOp ParLocalOp = ILIT(168)
+tagOf_PrimOp ParAtOp = ILIT(169)
+tagOf_PrimOp ParAtAbsOp = ILIT(170)
+tagOf_PrimOp ParAtRelOp = ILIT(171)
+tagOf_PrimOp ParAtForNowOp = ILIT(172)
+tagOf_PrimOp CopyableOp = ILIT(173)
+tagOf_PrimOp NoFollowOp = ILIT(174)
tagOf_PrimOp _ = panic# "tagOf_PrimOp: pattern-match"
PutMVarOp,
ReadIVarOp,
WriteIVarOp,
+ MakeForeignObjOp,
MakeStablePtrOp,
DeRefStablePtrOp,
ReallyUnsafePtrEqualityOp,
ErrorIOPrimOp,
-#ifdef GRAN
ParGlobalOp,
ParLocalOp,
-#endif {-GRAN-}
+ ParAtOp,
+ ParAtAbsOp,
+ ParAtRelOp,
+ ParAtForNowOp,
+ CopyableOp,
+ NoFollowOp,
SeqOp,
ParOp,
ForkOp,
DelayOp,
- WaitOp
+ WaitReadOp,
+ WaitWriteOp
]
\end{code}
[intPrimTy, mkStatePrimTy s]
statePrimTyCon VoidRep [s]
-primOpInfo WaitOp
+primOpInfo WaitReadOp
= let {
s = alphaTy; s_tv = alphaTyVar
} in
- PrimResult SLIT("wait#") [s_tv]
+ PrimResult SLIT("waitRead#") [s_tv]
[intPrimTy, mkStatePrimTy s]
statePrimTyCon VoidRep [s]
+primOpInfo WaitWriteOp
+ = let {
+ s = alphaTy; s_tv = alphaTyVar
+ } in
+ PrimResult SLIT("waitWrite#") [s_tv]
+ [intPrimTy, mkStatePrimTy s]
+ statePrimTyCon VoidRep [s]
\end{code}
+%************************************************************************
+%* *
+\subsubsection[PrimOps-makeForeignObj]{PrimOpInfo for Foreign Objects}
+%* *
+%************************************************************************
+
+Not everything should/can be in the Haskell heap. As an example, in an
+image processing application written in Haskell, you really would like
+to avoid heaving huge images between different space or generations of
+a garbage collector. Instead use @ForeignObj@ (formerly known as @MallocPtr@),
+which refer to some externally allocated structure/value. Using @ForeignObj@,
+just a reference to an image is present in the heap, the image could then
+be stored outside the Haskell heap, i.e., as a malloc'ed structure or in
+a completely separate address space alltogether.
+
+When a @ForeignObj@ becomes garbage, a user-defined finalisation routine
+associated with the object is invoked (currently, each ForeignObj has a
+direct reference to its finaliser). -- SOF
+
+The only function defined over @ForeignObj@s is:
+
+\begin{pseudocode}
+makeForeignObj# :: Addr# -- foreign object
+ -> Addr# -- ptr to its finaliser routine
+ -> StateAndForeignObj# _RealWorld# ForeignObj#
+\end{pseudocode}
+
+\begin{code}
+primOpInfo MakeForeignObjOp
+ = AlgResult SLIT("makeForeignObj#") []
+ [addrPrimTy, addrPrimTy, realWorldStatePrimTy]
+ stateAndForeignObjPrimTyCon [realWorldTy]
+\end{code}
%************************************************************************
%* *
\end{code}
\begin{code}
-#ifdef GRAN
-
-primOpInfo ParGlobalOp -- parGlobal# :: Int -> a -> b -> b
- = AlgResult SLIT("parGlobal#") [alphaTyVar,betaTyVar] [intPrimTy,alphaTy,betaTy] liftTyCon [betaTy]
+-- HWL: The first 4 Int# in all par... annotations denote:
+-- name, granularity info, size of result, degree of parallelism
-primOpInfo ParLocalOp -- parLocal# :: Int -> a -> b -> b
- = AlgResult SLIT("parLocal#") [alphaTyVar,betaTyVar] [intPrimTy,alphaTy,betaTy] liftTyCon [betaTy]
+primOpInfo ParGlobalOp -- parGlobal# :: Int# -> Int# -> Int# -> Int# -> a -> b -> b
+ = AlgResult SLIT("parGlobal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] liftTyCon [betaTy]
-primOpInfo ParAtOp -- parAt# :: Int -> a -> b -> c -> c
- = AlgResult SLIT("parAt#") [alphaTyVar,betaTyVar,gammaTyVar] [intPrimTy,alphaTy,betaTy,gammaTy] liftTyCon [gammaTy]
+primOpInfo ParLocalOp -- parLocal# :: Int# -> Int# -> Int# -> Int# -> a -> b -> b
+ = AlgResult SLIT("parLocal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] liftTyCon [betaTy]
-primOpInfo ParAtForNowOp -- parAtForNow# :: Int -> a -> b -> c -> c
- = AlgResult SLIT("parAtForNow#") [alphaTyVar,betaTyVar,gammaTyVar] [intPrimTy,alphaTy,betaTy,gammaTy] liftTyCon [gammaTy]
+primOpInfo ParAtOp -- parAt# :: Int# -> Int# -> Int# -> Int# -> a -> b -> c -> c
+ = AlgResult SLIT("parAt#") [alphaTyVar,betaTyVar,gammaTyVar] [alphaTy,betaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] liftTyCon [gammaTy]
-primOpInfo CopyableOp -- copyable# :: a -> a
- = AlgResult SLIT("copyable#") [alphaTyVar] [alphaTy] liftTyCon [alphaTy]
+primOpInfo ParAtAbsOp -- parAtAbs# :: Int# -> Int# -> Int# -> Int# -> Int# -> a -> b -> b
+ = AlgResult SLIT("parAtAbs#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] liftTyCon [betaTy]
-primOpInfo NoFollowOp -- noFollow# :: a -> a
- = AlgResult SLIT("noFollow#") [alphaTyVar] [alphaTy] liftTyCon [alphaTy]
+primOpInfo ParAtRelOp -- parAtRel# :: Int# -> Int# -> Int# -> Int# -> Int# -> a -> b -> b
+ = AlgResult SLIT("parAtRel#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] liftTyCon [betaTy]
-#endif {-GRAN-}
+primOpInfo ParAtForNowOp -- parAtForNow# :: Int# -> Int# -> Int# -> Int# -> a -> b -> c -> c
+ = AlgResult SLIT("parAtForNow#") [alphaTyVar,betaTyVar,gammaTyVar] [alphaTy,betaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] liftTyCon [gammaTy]
\end{code}
%************************************************************************
(intOff mIN_MP_INT_SIZE)))
-- ccall may allocate heap if it is explicitly allowed to (_ccall_gc_)
--- or if it returns a MallocPtr.
+-- or if it returns a ForeignObj.
-primOpHeapReq (CCallOp _ _ mayGC@True _ _) = VariableHeapRequired
-primOpHeapReq (CCallOp _ _ mayGC@False _ return_ty)
- = if returnsMallocPtr
- then VariableHeapRequired
- else NoHeapRequired
- where
- returnsMallocPtr
- = case (maybeAppDataTyConExpandingDicts return_ty) of
- Nothing -> False
- Just (tycon, _, _) -> tycon == stateAndMallocPtrPrimTyCon
+primOpHeapReq (CCallOp _ _ mayGC@True _ _) = VariableHeapRequired
+primOpHeapReq (CCallOp _ _ mayGC@False _ _) = NoHeapRequired
+
+primOpHeapReq MakeForeignObjOp = VariableHeapRequired
-- this occasionally has to expand the Stable Pointer table
primOpHeapReq MakeStablePtrOp = VariableHeapRequired
-- A SeqOp requires unknown space to evaluate its argument
primOpHeapReq SeqOp = VariableHeapRequired
-#ifdef GRAN
-
--- a ParGlobalOp creates a single 4-tuple in the heap. ToDo: verify this!
-primOpHeapReq ParGlobalOp = trace "primOpHeapReq:ParGlobalOp:verify!" (
- FixedHeapRequired
- (addOff (totHdrSize (MuTupleRep 4)) (intOff 4))
- )
+-- GranSim sparks are stgMalloced i.e. no heap required
+primOpHeapReq ParGlobalOp = NoHeapRequired
+primOpHeapReq ParLocalOp = NoHeapRequired
+primOpHeapReq ParAtOp = NoHeapRequired
+primOpHeapReq ParAtAbsOp = NoHeapRequired
+primOpHeapReq ParAtRelOp = NoHeapRequired
+primOpHeapReq ParAtForNowOp = NoHeapRequired
+-- CopyableOp and NoFolowOp don't require heap; don't rely on default
+primOpHeapReq CopyableOp = NoHeapRequired
+primOpHeapReq NoFollowOp = NoHeapRequired
--- a ParLocalOp creates a single 4-tuple in the heap. ToDo: verify this!
-primOpHeapReq ParLocalOp = trace "primOpHeapReq:ParLocalOp:verify!" (
- FixedHeapRequired
- (addOff (totHdrSize (MuTupleRep 4)) (intOff 4))
- )
+primOpHeapReq other_op = NoHeapRequired
+\end{code}
--- ToDo: parAt, parAtForNow, copyable, noFollow !! (HWL)
-#endif {-GRAN-}
+The amount of stack required by primops.
-primOpHeapReq other_op = NoHeapRequired
+\begin{code}
+data StackRequirement
+ = NoStackRequired
+ | FixedStackRequired Int {-AStack-} Int {-BStack-}
+ | VariableStackRequired
+
+primOpStackRequired SeqOp = FixedStackRequired 0 {-AStack-} 2 {-BStack-}
+primOpStackRequired _ = VariableStackRequired
+-- ToDo: be more specific for certain primops (currently only used for seq)
\end{code}
Primops which can trigger GC have to be called carefully.
TakeMVarOp -> True
ReadIVarOp -> True
DelayOp -> True
- WaitOp -> True
+ WaitReadOp -> True
+ WaitWriteOp -> True
_ ->
case primOpHeapReq op of
VariableHeapRequired -> True
primOpOkForSpeculation ForkOp = False -- Likewise
primOpOkForSpeculation SeqOp = False -- Likewise
-#ifdef GRAN
primOpOkForSpeculation ParGlobalOp = False -- Could be expensive!
primOpOkForSpeculation ParLocalOp = False -- Could be expensive!
-#endif {-GRAN-}
+primOpOkForSpeculation ParAtOp = False -- Could be expensive!
+primOpOkForSpeculation ParAtAbsOp = False -- Could be expensive!
+primOpOkForSpeculation ParAtRelOp = False -- Could be expensive!
+primOpOkForSpeculation ParAtForNowOp = False -- Could be expensive!
+primOpOkForSpeculation CopyableOp = False -- only tags closure
+primOpOkForSpeculation NoFollowOp = False -- only tags closure
-- The default is "yes it's ok for speculation"
primOpOkForSpeculation other_op = True
fragilePrimOp ParOp = True
fragilePrimOp ForkOp = True
fragilePrimOp SeqOp = True
-fragilePrimOp MakeStablePtrOp = True
+fragilePrimOp MakeForeignObjOp = True -- SOF
+fragilePrimOp MakeStablePtrOp = True
fragilePrimOp DeRefStablePtrOp = True -- ??? JSM & ADR
-#ifdef GRAN
fragilePrimOp ParGlobalOp = True
fragilePrimOp ParLocalOp = True
-fragilePrimOp CopyableOp = trace "fragilePrimOp:CopyableOp" True -- Possibly not. ASP
-fragilePrimOp NoFollowOp = trace "fragilePrimOp:NoFollowOp" True -- Possibly not. ASP
-#endif {-GRAN-}
+fragilePrimOp ParAtOp = True
+fragilePrimOp ParAtAbsOp = True
+fragilePrimOp ParAtRelOp = True
+fragilePrimOp ParAtForNowOp = True
+fragilePrimOp CopyableOp = True -- Possibly not. ASP
+fragilePrimOp NoFollowOp = True -- Possibly not. ASP
fragilePrimOp other = False
\end{code}
primOpNeedsWrapper DoubleEncodeOp = True
primOpNeedsWrapper DoubleDecodeOp = True
+primOpNeedsWrapper MakeForeignObjOp = True
primOpNeedsWrapper MakeStablePtrOp = True
primOpNeedsWrapper DeRefStablePtrOp = True
primOpNeedsWrapper ReadIVarOp = True
primOpNeedsWrapper DelayOp = True
-primOpNeedsWrapper WaitOp = True
+primOpNeedsWrapper WaitReadOp = True
+primOpNeedsWrapper WaitWriteOp = True
primOpNeedsWrapper other_op = False
\end{code}
| FloatRep -- floats
| DoubleRep -- doubles
- | MallocPtrRep -- This has to be a special kind because ccall
+ | ForeignObjRep -- This has to be a special kind because ccall
-- generates special code when passing/returning
-- one of these. [ADR]
isFollowableRep PtrRep = True
isFollowableRep ArrayRep = True
isFollowableRep ByteArrayRep = True
-isFollowableRep MallocPtrRep = True
+-- why is a MallocPtr followable? 4/96 SOF
+-- isFollowableRep ForeignObjRep = True
isFollowableRep StablePtrRep = False
-- StablePtrs aren't followable because they are just indices into a
showPrimRep ArrayRep = "StgArray" -- see comment below
showPrimRep ByteArrayRep = "StgByteArray"
showPrimRep StablePtrRep = "StgStablePtr"
-showPrimRep MallocPtrRep = "StgPtr" -- see comment below
+showPrimRep ForeignObjRep = "StgPtr" -- see comment below
showPrimRep VoidRep = "!!VOID_KIND!!"
guessPrimRep "D_" = DataPtrRep
@StgArray@. The coercion to a more precise C type is done just before
indexing (by the relevant C primitive-op macro).
-Nota Bene. There are three types associated with Malloc Pointers:
+Nota Bene. There are three types associated with @ForeignObj@ (MallocPtr++):
\begin{itemize}
\item
-@StgMallocClosure@ is the type of the thing the C world gives us.
+@StgForeignObjClosure@ is the type of the thing the prim. op @mkForeignObj@ returns.
+{- old comment for MallocPtr
(This typename is hardwired into @ppr_casm_results@ in
@PprAbsC.lhs@.)
+-}
\item
-@StgMallocPtr@ is the type of the thing we give the C world.
+@StgForeignObj@ is the type of the thing we give the C world.
\item
@StgPtr@ is the type of the (pointer to the) heap object which we
%************************************************************************
%* *
-\subsection[TysPrim-malloc-ptrs]{The ``malloc''-pointer type}
+\subsection[TysPrim-foreign-objs]{The ``foreign object'' type}
%* *
%************************************************************************
-``Malloc'' pointers provide a mechanism which will let Haskell's
-garbage collector communicate with a {\em simple\/} garbage collector
-in the IO world (probably \tr{malloc}, hence the name).We want Haskell
-to be able to hold onto references to objects in the IO world and for
-Haskell's garbage collector to tell the IO world when these references
-become garbage. We are not aiming to provide a mechanism that could
+Foreign objects (formerly ``Malloc'' pointers) provide a mechanism which
+will let Haskell's garbage collector communicate with a {\em simple\/}
+garbage collector in the IO world. We want Haskell to be able to hold
+onto references to objects in the IO world and for Haskell's garbage
+collector to tell the IO world when these references become garbage.
+We are not aiming to provide a mechanism that could
talk to a sophisticated garbage collector such as that provided by a
LISP system (with a correspondingly complex interface); in particular,
we shall ignore the danger of circular structures spread across the
two systems.
-There are no primitive operations on @CHeapPtr#@s (although equality
+There are no primitive operations on @ForeignObj#@s (although equality
could possibly be added?)
\begin{code}
-mallocPtrPrimTyCon = pcPrimTyCon mallocPtrPrimTyConKey SLIT("MallocPtr#") 0
- (\ [] -> MallocPtrRep)
+foreignObjPrimTy = applyTyCon foreignObjPrimTyCon []
+foreignObjPrimTyCon = pcPrimTyCon foreignObjPrimTyConKey SLIT("ForeignObj#") 0
+ (\ [] -> ForeignObjRep)
\end{code}
liftTyCon,
listTyCon,
ltDataCon,
- mallocPtrTyCon,
+ foreignObjTyCon,
mkLiftTy,
mkListTy,
mkPrimIoTy,
stateAndDoublePrimTyCon,
stateAndFloatPrimTyCon,
stateAndIntPrimTyCon,
- stateAndMallocPtrPrimTyCon,
+ stateAndForeignObjPrimTyCon,
stateAndMutableArrayPrimTyCon,
stateAndMutableByteArrayPrimTyCon,
stateAndPtrPrimTyCon,
where
stablePtrDataCon
= pcDataCon stablePtrDataConKey gLASGOW_MISC SLIT("_StablePtr")
- [alphaTyVar] [] [applyTyCon stablePtrPrimTyCon [alphaTy]] stablePtrTyCon nullSpecEnv
+ [alphaTyVar] [] [mkStablePtrPrimTy alphaTy] stablePtrTyCon nullSpecEnv
\end{code}
\begin{code}
-mallocPtrTyCon
- = pcDataTyCon mallocPtrTyConKey gLASGOW_MISC SLIT("_MallocPtr")
- [] [mallocPtrDataCon]
+foreignObjTyCon
+ = pcDataTyCon foreignObjTyConKey gLASGOW_MISC SLIT("_ForeignObj")
+ [] [foreignObjDataCon]
where
- mallocPtrDataCon
- = pcDataCon mallocPtrDataConKey gLASGOW_MISC SLIT("_MallocPtr")
- [] [] [applyTyCon mallocPtrPrimTyCon []] mallocPtrTyCon nullSpecEnv
+ foreignObjDataCon
+ = pcDataCon foreignObjDataConKey gLASGOW_MISC SLIT("_ForeignObj")
+ [] [] [foreignObjPrimTy] foreignObjTyCon nullSpecEnv
\end{code}
%************************************************************************
[mkStatePrimTy alphaTy, applyTyCon stablePtrPrimTyCon [betaTy]]
stateAndStablePtrPrimTyCon nullSpecEnv
-stateAndMallocPtrPrimTyCon
- = pcDataTyCon stateAndMallocPtrPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndMallocPtr#")
- [alphaTyVar] [stateAndMallocPtrPrimDataCon]
-stateAndMallocPtrPrimDataCon
- = pcDataCon stateAndMallocPtrPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndMallocPtr#")
+stateAndForeignObjPrimTyCon
+ = pcDataTyCon stateAndForeignObjPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndForeignObj#")
+ [alphaTyVar] [stateAndForeignObjPrimDataCon]
+stateAndForeignObjPrimDataCon
+ = pcDataCon stateAndForeignObjPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndForeignObj#")
[alphaTyVar] []
- [mkStatePrimTy alphaTy, applyTyCon mallocPtrPrimTyCon []]
- stateAndMallocPtrPrimTyCon nullSpecEnv
+ [mkStatePrimTy alphaTy, applyTyCon foreignObjPrimTyCon []]
+ stateAndForeignObjPrimTyCon nullSpecEnv
stateAndFloatPrimTyCon
= pcDataTyCon stateAndFloatPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndFloat#")
(wordPrimTyCon, (stateAndWordPrimDataCon, stateAndWordPrimTyCon, 0)),
(addrPrimTyCon, (stateAndAddrPrimDataCon, stateAndAddrPrimTyCon, 0)),
(stablePtrPrimTyCon, (stateAndStablePtrPrimDataCon, stateAndStablePtrPrimTyCon, 0)),
- (mallocPtrPrimTyCon, (stateAndMallocPtrPrimDataCon, stateAndMallocPtrPrimTyCon, 0)),
+ (foreignObjPrimTyCon, (stateAndForeignObjPrimDataCon, stateAndForeignObjPrimTyCon, 0)),
(floatPrimTyCon, (stateAndFloatPrimDataCon, stateAndFloatPrimTyCon, 0)),
(doublePrimTyCon, (stateAndDoublePrimDataCon, stateAndDoublePrimTyCon, 0)),
(arrayPrimTyCon, (stateAndArrayPrimDataCon, stateAndArrayPrimTyCon, 0)),
\begin{code}
boolTy = mkTyConTy boolTyCon
-boolTyCon = pcDataTyCon boolTyConKey pRELUDE_CORE SLIT("Bool") [] [falseDataCon, trueDataCon]
+boolTyCon = pcDataTyCon boolTyConKey pRELUDE SLIT("Bool") [] [falseDataCon, trueDataCon]
-falseDataCon = pcDataCon falseDataConKey pRELUDE_CORE SLIT("False") [] [] [] boolTyCon nullSpecEnv
-trueDataCon = pcDataCon trueDataConKey pRELUDE_CORE SLIT("True") [] [] [] boolTyCon nullSpecEnv
+falseDataCon = pcDataCon falseDataConKey pRELUDE SLIT("False") [] [] [] boolTyCon nullSpecEnv
+trueDataCon = pcDataCon trueDataConKey pRELUDE SLIT("True") [] [] [] boolTyCon nullSpecEnv
\end{code}
%************************************************************************
mkRatioTy ty = applyTyCon ratioTyCon [ty]
rationalTy = mkRatioTy integerTy
-ratioTyCon = pcDataTyCon ratioTyConKey pRELUDE_RATIO SLIT("Ratio") [alphaTyVar] [ratioDataCon]
+ratioTyCon = pcDataTyCon ratioTyConKey rATIO SLIT("Ratio") [alphaTyVar] [ratioDataCon]
-ratioDataCon = pcDataCon ratioDataConKey pRELUDE_RATIO SLIT(":%")
+ratioDataCon = pcDataCon ratioDataConKey rATIO SLIT(":%")
[alphaTyVar] [{-(integralClass,alphaTy)-}] [alphaTy, alphaTy] ratioTyCon nullSpecEnv
-- context omitted to match lib/prelude/ defn of "data Ratio ..."
rationalTyCon
= mkSynTyCon
- (mkBuiltinName rationalTyConKey pRELUDE_RATIO SLIT("Rational"))
+ (mkBuiltinName rationalTyConKey rATIO SLIT("Rational"))
mkBoxedTypeKind
0 [] rationalTy -- == mkRatioTy integerTy
\end{code}
stringTyCon
= mkSynTyCon
- (mkBuiltinName stringTyConKey pRELUDE_CORE SLIT("String"))
+ (mkBuiltinName stringTyConKey pRELUDE SLIT("String"))
mkBoxedTypeKind
0 [] stringTy
\end{code}
-- be set? setToAbleCostCentre is allowed to panic on
-- "nonsense" cases, too...
-#if DEBUG
+#ifdef DEBUG
setToAbleCostCentre NoCostCentre = panic "setToAbleCC:NoCostCentre"
setToAbleCostCentre SubsumedCosts = panic "setToAbleCC:SubsumedCosts"
setToAbleCostCentre CurrentCC = panic "setToAbleCC:CurrentCC"
name_version_pairs :: { Bag (FAST_STRING, Int) }
name_version_pairs : name_version_pair
{ unitBag $1 }
- | name_version_pairs COMMA name_version_pair
- { $1 `snocBag` $3 }
+ | name_version_pairs name_version_pair
+ { $1 `snocBag` $2 }
name_version_pair :: { (FAST_STRING, Int) }
name_version_pair : iname INTEGER
import HsSyn
import RdrHsSyn ( RdrNameHsModule(..), RdrNameImportDecl(..) )
-import RnHsSyn ( RnName, RenamedHsModule(..), isRnTyConOrClass, isRnWired )
+import RnHsSyn ( RnName(..){-.. is for Ix hack only-}, RenamedHsModule(..), isRnTyConOrClass, isRnWired )
--ToDo:rm: all for debugging only
import Maybes
import Name ( isLocallyDefined, mkBuiltinName, Name, RdrName(..) )
import PrelInfo ( builtinNameInfo, BuiltinNames(..), BuiltinKeys(..) )
import PrelMods ( pRELUDE )
+import Unique ( ixClassKey )
import UniqFM ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM )
import UniqSupply ( splitUniqSupply )
import Util ( panic, assertPanic )
-- we must ensure that the definitions of things in the BuiltinKey
-- table which may be *required* by the typechecker etc are read.
+ -- We *hack* in a requirement for Ix.Ix here
+ -- (it's the one thing that doesn't come from Prelude.<blah>)
must_haves
- = [ name_fn (mkBuiltinName u pRELUDE str)
+ = (RnImplicitClass (mkBuiltinName ixClassKey SLIT("Ix") SLIT("Ix")))
+ : [ name_fn (mkBuiltinName u pRELUDE str)
| (str, (u, name_fn)) <- fmToList b_keys,
str `notElem` [ SLIT("main"), SLIT("mainPrimIO")] ]
in
- ASSERT (isEmptyBag orig_occ_dups)
+-- ASSERT (isEmptyBag orig_occ_dups)
+ (if (isEmptyBag orig_occ_dups) then \x->x
+ else pprTrace "orig_occ_dups:" (ppAboves [ ppCat [ppr PprDebug m, ppr PprDebug n, ppr PprDebug o] | (m,n,o) <- bagToList orig_occ_dups])) $
ASSERT (isEmptyBag orig_def_dups)
rnIfaces iface_cache imp_mods us3 orig_def_env orig_occ_env
isRnUnbound (RnUnbound _) = True
isRnUnbound _ = False
-isRnDecl (RnName _) = True
-isRnDecl (RnSyn _) = True
-isRnDecl (RnData _ _ _) = True
-isRnDecl (RnClass _ _) = True
-isRnDecl _ = False
-
-- Very general NamedThing comparison, used when comparing
-- Uniquable things with different types
getName (RnImplicitClass n) = n
getName (RnUnbound occ) = pprTrace "getRnName:RnUnbound: " (ppr PprDebug occ)
(case occ of
- Unqual n -> mkLocalName bottom n bottom2
- Qual m n -> mkLocalName bottom n bottom2)
+ Unqual n -> mkLocalName bottom n False bottom2
+ Qual m n -> mkLocalName bottom n False bottom2)
where bottom = mkAlphaTyVarUnique 0 -- anything; just something that will print
bottom2 = panic "getRnName: srcloc"
returnRn (zipWithEqual "mkLocalNames" new_local uniqs names_w_locs)
where
new_local uniq (Unqual str, srcloc)
- = mkRnName (mkLocalName uniq str srcloc)
+ = mkRnName (mkLocalName uniq str False{-emph names-} srcloc)
\end{code}
import RnMonad
import RnIfaces ( IfaceCache(..), cachedIface, cachedDecl )
import RnUtils ( RnEnv(..), emptyRnEnv, extendGlobalRnEnv,
- lubExportFlag, qualNameErr, dupNamesErr, negateNameWarn
+ lubExportFlag, qualNameErr, dupNamesErr
)
import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst )
n = mkTopLevName uniq orig locn exp (occ_fn n) -- NB: two "n"s
in
- addWarnIfRn (rdr == Unqual SLIT("negate")) (negateNameWarn (rdr, locn)) `thenRn_`
addErrIfRn (isQual rdr) (qualNameErr "name in definition" (rdr, locn)) `thenRn_`
returnRn n
\end{code}
Nothing -> (all_vals, all_tcs, Nothing)
Just (True, ies) -> -- hiding does not work for builtin names
+ trace "getBuiltins: import Prelude hiding ( ... )" $
(all_vals, all_tcs, maybe_spec)
Just (False, ies) -> let
do_builtin (ie:ies)
= let str = unqual_str (ie_name ie)
in
- case (lookupFM b_tc_names str) of -- NB: we favour the tycon/class FM...
+ case (lookupFM b_tc_names str) of -- NB: we favour the tycon/class FM...
Just rn -> case (ie,rn) of
(IEThingAbs _, WiredInTyCon tc)
-> (vals, (str, rn) `consBag` tcs, ies_left)
(tyConDataCons tc))
`unionBags` vals,
(str,rn) `consBag` tcs, ies_left)
+ (IEThingWith _ _, WiredInTyCon tc) -- No checking of With...
+ -> (listToBag (map (\ id -> (getLocalName id, WiredInId id))
+ (tyConDataCons tc))
+ `unionBags` vals,
+ (str,rn) `consBag` tcs, ies_left)
_ -> panic "importing builtin names (1)"
Nothing ->
nameImportFlag, RdrName, pprNonSym )
import Outputable -- ToDo:rm
import PprStyle -- ToDo:rm
-import PrelInfo ( consDataCon )
import Pretty
import SrcLoc ( SrcLoc )
import Unique ( Unique )
-import UniqFM ( emptyUFM, addListToUFM_C, listToUFM, lookupUFM, eltsUFM )
+import UniqFM ( emptyUFM, addListToUFM_C, listToUFM, plusUFM, lookupUFM, eltsUFM )
import UniqSet ( UniqSet(..) )
-import Util ( isIn, isn'tIn, sortLt, removeDups, cmpPString, assertPanic, pprTrace{-ToDo:rm-} )
+import Util ( isIn, isn'tIn, sortLt, removeDups, mapAndUnzip3, cmpPString,
+ assertPanic, pprTrace{-ToDo:rm-} )
\end{code}
rnSource `renames' the source module and export list.
rnExports mods unqual_imps (Just exps)
= mapAndUnzipRn (rnIE mods) exps `thenRn` \ (mod_maybes, exp_bags) ->
let
- exp_names = bagToList (unionManyBags exp_bags)
+ (tc_bags, val_bags) = unzip exp_bags
+ tc_names = bagToList (unionManyBags tc_bags)
+ val_names = bagToList (unionManyBags val_bags)
exp_mods = catMaybes mod_maybes
-- Warn for duplicate names and modules
- (uniq_exp_names, dup_names) = removeDups cmp_fst exp_names
- (uniq_exp_mods, dup_mods) = removeDups cmpPString exp_mods
+ (_, dup_tc_names) = removeDups cmp_fst tc_names
+ (_, dup_val_names) = removeDups cmp_fst val_names
cmp_fst (x,_) (y,_) = x `cmp` y
+ (uniq_mods, dup_mods) = removeDups cmpPString exp_mods
+
+ -- Get names for exported modules
+
+ (mod_tcs, mod_vals, empty_mods)
+ = case mapAndUnzip3 get_mod_names uniq_mods of
+ (tcs, vals, emptys) -> (concat tcs, concat vals, catMaybes emptys)
+
+ (unqual_tcs, unqual_vals) = partition (isRnTyConOrClass.snd) (bagToList unqual_imps)
+
+ get_mod_names mod
+ = (tcs, vals, empty_mod)
+ where
+ tcs = [(getName rn, nameImportFlag (getName rn))
+ | (mod',rn) <- unqual_tcs, mod == mod']
+ vals = [(getName rn, nameImportFlag (getName rn))
+ | (mod',rn) <- unqual_vals, mod == mod']
+ empty_mod = if null tcs && null vals
+ then Just mod
+ else Nothing
+
-- Build finite map of exported names to export flag
- exp_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst uniq_exp_names)
- (exp_map1, empty_mods) = foldl add_mod_names (exp_map0, []) uniq_exp_mods
-
- mod_fm = addListToFM_C unionBags emptyFM
- [(mod, unitBag (getName rn, nameImportFlag (getName rn)))
- | (mod,rn) <- bagToList unqual_imps, isRnDecl rn]
-
- add_mod_names (exp_map, empty) mod
- = case lookupFM mod_fm mod of
- Nothing -> (exp_map, mod:empty)
- Just mod_names -> (addListToUFM_C lub_expflag exp_map (map pair_fst (bagToList mod_names)), empty)
+ tc_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst tc_names)
+ tc_map = addListToUFM_C lub_expflag tc_map0 (map pair_fst mod_tcs)
+
+ val_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst val_names)
+ val_map = addListToUFM_C lub_expflag val_map0 (map pair_fst mod_vals)
pair_fst p@(f,_) = (f,p)
lub_expflag (n, flag1) (_, flag2) = (n, lubExportFlag flag1 flag2)
-- Check for exporting of duplicate local names
- exp_locals = [(getLocalName n, n) | (n,_) <- eltsUFM exp_map1]
- (_, dup_locals) = removeDups cmp_local exp_locals
+ tc_locals = [(getLocalName n, n) | (n,_) <- eltsUFM tc_map]
+ val_locals = [(getLocalName n, n) | (n,_) <- eltsUFM val_map]
+ (_, dup_tc_locals) = removeDups cmp_local tc_locals
+ (_, dup_val_locals) = removeDups cmp_local val_locals
cmp_local (x,_) (y,_) = x `cmpPString` y
-- Build export flag function
- exp_fn n = case lookupUFM exp_map1 n of
+ final_exp_map = plusUFM tc_map val_map
+ exp_fn n = case lookupUFM final_exp_map n of
Nothing -> NotExported
Just (_,flag) -> flag
in
- getSrcLocRn `thenRn` \ src_loc ->
- mapRn (addWarnRn . dupNameExportWarn src_loc) dup_names `thenRn_`
- mapRn (addWarnRn . dupModExportWarn src_loc) dup_mods `thenRn_`
- mapRn (addWarnRn . emptyModExportWarn src_loc) empty_mods `thenRn_`
- mapRn (addErrRn . dupLocalsExportErr src_loc) dup_locals `thenRn_`
+ getSrcLocRn `thenRn` \ src_loc ->
+ mapRn (addWarnRn . dupNameExportWarn src_loc) dup_tc_names `thenRn_`
+ mapRn (addWarnRn . dupNameExportWarn src_loc) dup_val_names `thenRn_`
+ mapRn (addWarnRn . dupModExportWarn src_loc) dup_mods `thenRn_`
+ mapRn (addWarnRn . emptyModExportWarn src_loc) empty_mods `thenRn_`
+ mapRn (addErrRn . dupLocalsExportErr src_loc) dup_tc_locals `thenRn_`
+ mapRn (addErrRn . dupLocalsExportErr src_loc) dup_val_locals `thenRn_`
returnRn exp_fn
checkIEVar rn `thenRn` \ exps ->
returnRn (Nothing, exps)
where
- checkIEVar (RnName n) = returnRn (unitBag (n,ExportAll))
+ checkIEVar (RnName n) = returnRn (emptyBag, unitBag (n,ExportAll))
checkIEVar rn@(RnClassOp _ _) = getSrcLocRn `thenRn` \ src_loc ->
- failButContinueRn emptyBag (classOpExportErr rn src_loc)
- checkIEVar rn = returnRn emptyBag
+ failButContinueRn (emptyBag, emptyBag) (classOpExportErr rn src_loc)
+ checkIEVar rn = returnRn (emptyBag, emptyBag)
rnIE mods (IEThingAbs name)
= lookupTyConOrClass name `thenRn` \ rn ->
checkIEAbs rn `thenRn` \ exps ->
returnRn (Nothing, exps)
where
- checkIEAbs (RnSyn n) = returnRn (unitBag (n,ExportAbs))
- checkIEAbs (RnData n _ _) = returnRn (unitBag (n,ExportAbs))
- checkIEAbs (RnClass n _) = returnRn (unitBag (n,ExportAbs))
- checkIEAbs rn = returnRn emptyBag
+ checkIEAbs (RnSyn n) = returnRn (unitBag (n,ExportAbs), emptyBag)
+ checkIEAbs (RnData n _ _) = returnRn (unitBag (n,ExportAbs), emptyBag)
+ checkIEAbs (RnClass n _) = returnRn (unitBag (n,ExportAbs), emptyBag)
+ checkIEAbs rn = returnRn (emptyBag, emptyBag)
rnIE mods (IEThingAll name)
= lookupTyConOrClass name `thenRn` \ rn ->
checkImportAll rn `thenRn_`
returnRn (Nothing, exps)
where
- checkIEAll (RnData n cons fields) = returnRn (exp_all n `consBag` listToBag (map exp_all cons)
- `unionBags` listToBag (map exp_all fields))
- checkIEAll (RnClass n ops) = returnRn (exp_all n `consBag` listToBag (map exp_all ops))
+ checkIEAll (RnData n cons fields) = returnRn (unitBag (exp_all n), listToBag (map exp_all cons)
+ `unionBags`
+ listToBag (map exp_all fields))
+ checkIEAll (RnClass n ops) = returnRn (unitBag (exp_all n), listToBag (map exp_all ops))
checkIEAll rn@(RnSyn n) = getSrcLocRn `thenRn` \ src_loc ->
- warnAndContinueRn (unitBag (n, ExportAbs))
+ warnAndContinueRn (unitBag (n, ExportAbs), emptyBag)
(synAllExportErr False{-warning-} rn src_loc)
- checkIEAll rn = returnRn emptyBag
+ checkIEAll rn = returnRn (emptyBag, emptyBag)
exp_all n = (n, ExportAll)
where
checkIEWith rn@(RnData n cons fields) rns
| same_names (cons++fields) rns
- = returnRn (consBag (exp_all n) (listToBag (map exp_all cons)))
+ = returnRn (unitBag (exp_all n), listToBag (map exp_all cons)
+ `unionBags`
+ listToBag (map exp_all fields))
| otherwise
= rnWithErr "constructrs (and fields)" rn (cons++fields) rns
checkIEWith rn@(RnClass n ops) rns
| same_names ops rns
- = returnRn (consBag (exp_all n) (listToBag (map exp_all ops)))
+ = returnRn (unitBag (exp_all n), listToBag (map exp_all ops))
| otherwise
= rnWithErr "class ops" rn ops rns
checkIEWith rn@(RnSyn _) rns
= getSrcLocRn `thenRn` \ src_loc ->
- failButContinueRn emptyBag (synAllExportErr True{-error-} rn src_loc)
+ failButContinueRn (emptyBag, emptyBag) (synAllExportErr True{-error-} rn src_loc)
checkIEWith rn rns
- = returnRn emptyBag
+ = returnRn (emptyBag, emptyBag)
exp_all n = (n, ExportAll)
rnWithErr str rn has rns
= getSrcLocRn `thenRn` \ src_loc ->
- failButContinueRn emptyBag (withExportErr str rn has rns src_loc)
+ failButContinueRn (emptyBag, emptyBag) (withExportErr str rn has rns src_loc)
rnIE mods (IEModuleContents mod)
| isIn "rnIE:IEModule" mod mods
- = returnRn (Just mod, emptyBag)
+ = returnRn (Just mod, (emptyBag, emptyBag))
| otherwise
= getSrcLocRn `thenRn` \ src_loc ->
- failButContinueRn (Nothing,emptyBag) (badModExportErr mod src_loc)
+ failButContinueRn (Nothing, (emptyBag, emptyBag)) (badModExportErr mod src_loc)
checkImportAll rn
rn_deriv tycon2 locn clas
= lookupClass clas `thenRn` \ clas_name ->
addErrIfRn (uniqueOf clas_name `not_elem` derivableClassKeys)
- (derivingNonStdClassErr clas locn)
+ (derivingNonStdClassErr clas_name locn)
`thenRn_`
returnRn clas_name
where
import Id ( idType )
import Literal ( mkMachInt, mkMachWord, Literal(..) )
import MagicUFs ( MagicUnfoldingFun )
-import PrelInfo ( trueDataCon, falseDataCon )
import PrimOp ( PrimOp(..) )
import SimplEnv
import SimplMonad
+import TysWiredIn ( trueDataCon, falseDataCon )
\end{code}
\begin{code}
import IdLoop -- paranoia checking
import CoreSyn
-import PrelInfo ( mkListTy )
import SimplEnv ( SimplEnv )
import SimplMonad ( SmplM(..), SimplCount )
import Type ( mkFunTys )
+import TysWiredIn ( mkListTy )
import Unique ( Unique{-instances-} )
import Util ( assoc, zipWith3Equal, nOfThem, panic )
\end{code}
import IdInfo ( willBeDemanded, DemandInfo )
import Literal ( isNoRepLit, Literal{-instance Eq-} )
import Maybes ( maybeToBool )
-import PrelInfo ( voidPrimTy, voidPrimId )
+import PrelVals ( voidPrimId )
import PrimOp ( primOpOkForSpeculation, PrimOp{-instance Eq-} )
import SimplEnv
import SimplMonad
import SimplUtils ( mkValLamTryingEta )
import Type ( isPrimType, maybeAppDataTyConExpandingDicts, mkFunTys, eqTy )
+import TysPrim ( voidPrimTy )
import Unique ( Unique{-instance Eq-} )
import Usage ( GenUsage{-instance Eq-} )
import Util ( isIn, isSingleton, zipEqual, panic, assertPanic )
(_, ty_args, _) = getAppDataTyConExpandingDicts scrut_ty
in
extendUnfoldEnvGivenFormDetails
- env var (ConForm con (map VarArg args))
+ env var (ConForm con (map TyArg ty_args ++ map VarArg args))
\end{code}
)
import IdInfo ( arityMaybe )
import Maybes ( maybeToBool )
-import PrelInfo ( augmentId, buildId, realWorldStateTy )
+import PrelVals ( augmentId, buildId )
import PrimOp ( primOpIsCheap )
import SimplEnv
import SimplMonad
import Type ( eqTy, isPrimType, maybeAppDataTyConExpandingDicts, getTyVar_maybe )
+import TysWiredIn ( realWorldStateTy )
import TyVar ( GenTyVar{-instance Eq-} )
import Util ( isIn, panic )
import Name ( isLocallyDefined )
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instance Outputable-} )
-import PrelInfo ( realWorldStateTy )
import Pretty ( ppAbove )
import PrimOp ( primOpOkForSpeculation, PrimOp(..) )
import SimplCase ( simplCase, bindLargeRhs )
import Type ( mkTyVarTy, mkTyVarTys, mkAppTy,
splitFunTy, getFunTy_maybe, eqTy
)
+import TysWiredIn ( realWorldStateTy )
import Util ( isSingleton, zipEqual, panic, pprPanic, assertPanic )
\end{code}
GenType{-instance Outputable-}, GenTyVar{-ditto-},
TyCon{-ditto-}
)
-import PrelInfo ( liftDataCon )
import Pretty ( ppHang, ppCat, ppStr, ppAboves, ppBesides,
ppInt, ppSP, ppInterleave, ppNil, Pretty(..)
)
nullTyVarEnv, growTyVarEnvList, TyVarEnv(..),
GenTyVar{-instance Eq-}
)
+import TysWiredIn ( liftDataCon )
import Unique ( Unique{-instance Eq-} )
import UniqSet ( mkUniqSet, unionUniqSets, uniqSetToList )
import UniqSupply ( splitUniqSupply, getUniques, getUnique )
)
import Literal ( mkMachInt, Literal(..) )
import Name ( isExported )
-import PrelInfo ( unpackCStringId, unpackCString2Id, stringTy,
- integerTy, rationalTy, ratioDataCon,
+import PrelVals ( unpackCStringId, unpackCString2Id,
integerZeroId, integerPlusOneId,
integerPlusTwoId, integerMinusOneId
)
import SpecUtils ( mkSpecialisedCon )
import SrcLoc ( mkUnknownSrcLoc )
import Type ( getAppDataTyConExpandingDicts )
+import TysWiredIn ( stringTy, integerTy, rationalTy, ratioDataCon )
import UniqSupply -- all of it, really
import Util ( panic )
= let
(_,_, binders, body) = collectBinders expr
in
- coreExprToStg env body `thenUs` \ (stg_body, binds) ->
- newStgVar (coreExprType expr) `thenUs` \ var ->
- returnUs
- (StgLet (StgNonRec var (StgRhsClosure noCostCentre
- stgArgOcc
- bOGUS_FVs
- ReEntrant -- binders is non-empty
- binders
- stg_body))
- (StgApp (StgVarArg var) [] bOGUS_LVs),
- binds)
+ coreExprToStg env body `thenUs` \ stuff@(stg_body, binds) ->
+
+ if null binders then -- it was all type/usage binders; tossed
+ returnUs stuff
+ else
+ newStgVar (coreExprType expr) `thenUs` \ var ->
+ returnUs
+ (StgLet (StgNonRec var (StgRhsClosure noCostCentre
+ stgArgOcc
+ bOGUS_FVs
+ ReEntrant -- binders is non-empty
+ binders
+ stg_body))
+ (StgApp (StgVarArg var) [] bOGUS_LVs),
+ binds)
\end{code}
%************************************************************************
import Maybes ( maybeToBool )
import Outputable ( Outputable(..){-instance * []-} )
import PprStyle ( PprStyle(..) )
-import PrelInfo ( intTyCon, integerTyCon, doubleTyCon,
- floatTyCon, wordTyCon, addrTyCon
- )
import Pretty ( ppStr )
import PrimOp ( PrimOp(..) )
import SaLib
TyCon{-instance Eq-}
)
import Type ( maybeAppDataTyConExpandingDicts, isPrimType )
+import TysWiredIn ( intTyCon, integerTyCon, doubleTyCon,
+ floatTyCon, wordTyCon, addrTyCon
+ )
import Util ( isIn, isn'tIn, nOfThem, zipWithEqual,
pprTrace, panic, pprPanic, assertPanic
)
import CoreSyn
import Id ( idType, mkSysLocal, dataConArgTys )
import IdInfo ( mkStrictnessInfo, nonAbsentArgs, Demand(..) )
-import PrelInfo ( aBSENT_ERROR_ID )
+import PrelVals ( aBSENT_ERROR_ID )
import SrcLoc ( mkUnknownSrcLoc )
import Type ( isPrimType, mkTyVarTys, mkForAllTys, mkFunTys,
maybeAppDataTyConExpandingDicts
\begin{code}
instToId :: Inst s -> TcIdOcc s
instToId (Dict u clas ty orig loc)
- = TcId (mkInstId u (mkDictTy clas ty) (mkLocalName u str loc))
+ = TcId (mkInstId u (mkDictTy clas ty) (mkLocalName u str False{-emph name-} loc))
where
str = SLIT("d.") _APPEND_ (getLocalName clas)
instToId (Method u id tys rho_ty orig loc)
- = TcId (mkInstId u tau_ty (mkLocalName u str loc))
+ = TcId (mkInstId u tau_ty (mkLocalName u str False{-emph name-} loc))
where
(_, tau_ty) = splitRhoTy rho_ty -- NB The method Id has just the tau type
str = SLIT("m.") _APPEND_ (getLocalName id)
instToId (LitInst u list ty orig loc)
- = TcId (mkInstId u ty (mkLocalName u SLIT("lit") loc))
+ = TcId (mkInstId u ty (mkLocalName u SLIT("lit") True{-emph uniq-} loc))
\end{code}
\begin{code}
import TcMonoType ( tcMonoType )
import TcSimplify ( tcSimplifyCheckThetas )
-import PrelInfo ( intTy, doubleTy, unitTy )
+import TysWiredIn ( intTy, doubleTy, unitTy )
import Unique ( numClassKey )
import Util
\end{code}
import Kind ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
import GenSpecEtc ( checkSigTyVars, checkSigTyVarsGivenGlobals )
import Name ( Name{-instance Eq-} )
-import PrelInfo ( intPrimTy, charPrimTy, doublePrimTy,
- floatPrimTy, addrPrimTy, addrTy,
- boolTy, charTy, stringTy, mkListTy,
- mkTupleTy, mkPrimIoTy )
import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys,
getTyVar_maybe, getFunTy_maybe, instantiateTy,
splitForAllTy, splitRhoTy, splitSigmaTy, splitFunTy,
getAppDataTyCon, maybeAppDataTyCon
)
import TyVar ( GenTyVar, TyVarSet(..), unionTyVarSets, mkTyVarSet )
+import TysPrim ( intPrimTy, charPrimTy, doublePrimTy,
+ floatPrimTy, addrPrimTy
+ )
+import TysWiredIn ( addrTy,
+ boolTy, charTy, stringTy, mkListTy,
+ mkTupleTy, mkPrimIoTy
+ )
import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy )
import Unique ( Unique, cCallableClassKey, cReturnableClassKey,
enumFromClassOpKey, enumFromThenClassOpKey,
enumFromToClassOpKey, enumFromThenToClassOpKey,
- monadClassKey, monadZeroClassKey )
-
+ monadClassKey, monadZeroClassKey
+ )
--import Name ( Name ) -- Instance
import Outputable ( interpp'SP )
import PprType ( GenType, GenTyVar ) -- Instances
stmts_ty)
tcDoStmts _ m (stmt@(BindStmt pat exp src_loc) : stmts)
- = tcAddSrcLoc src_loc (
+ = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ ->
+ tcAddSrcLoc src_loc (
tcSetErrCtxt (stmtCtxt stmt) (
tcPat pat `thenTc` \ (pat', pat_lie, pat_ty) ->
+
tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
+ -- See comments with tcListComp on GeneratorQual
+
newTyVarTy mkTypeKind `thenNF_Tc` \ a ->
unifyTauTy a pat_ty `thenTc_`
unifyTauTy (mkAppTy m a) exp_ty `thenTc_`
import TcType ( TcType(..) )
import Unify ( unifyTauTy )
-import PrelInfo ( boolTy )
+import TysWiredIn ( boolTy )
\end{code}
\begin{code}
--import Name ( Name(..) )
import Outputable
import PrimOp
-import PrelInfo
+--import PrelInfo
import Pretty
import SrcLoc ( mkGeneratedSrcLoc )
import TyCon ( TyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon )
showParen_PN = prelude_val pRELUDE_TEXT SLIT("showParen")
readParen_PN = prelude_val pRELUDE_TEXT SLIT("readParen")
lex_PN = prelude_val pRELUDE_TEXT SLIT("lex")
-_showList_PN = prelude_val pRELUDE_CORE SLIT("_showList")
-_readList_PN = prelude_val pRELUDE_CORE SLIT("_readList")
+_showList_PN = prelude_val pRELUDE SLIT("_showList")
+_readList_PN = prelude_val pRELUDE SLIT("_readList")
prelude_val m s = Imp m s [m] s
-prelude_method c o = Imp pRELUDE_CORE o [pRELUDE_CORE] o -- class not used...
+prelude_method c o = Imp pRELUDE o [pRELUDE] o -- class not used...
a_Expr = HsVar a_PN
b_Expr = HsVar b_PN
import Id ( GenId, isDataCon, isMethodSelId, idType, IdEnv(..), nullIdEnv )
import Maybes ( catMaybes )
import Name ( isExported, isLocallyDefined )
-import PrelInfo ( unitTy, mkPrimIoTy )
import Pretty
import RnUtils ( RnEnv(..) )
-import TyCon ( TyCon )
+import TyCon ( isDataTyCon, TyCon )
import Type ( mkSynTy )
+import TysWiredIn ( unitTy, mkPrimIoTy )
import TyVar ( TyVarEnv(..), nullTyVarEnv )
import Unify ( unifyTauTy )
import UniqFM ( lookupUFM_Directly, lookupWithDefaultUFM_Directly,
-- any type errors are found (ie there's an inconsistency)
-- we silently discard the pragma
tcInterfaceSigs sigs `thenTc` \ sig_ids ->
+ tcGetEnv `thenNF_Tc` \ env ->
returnTc (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, sig_ids)
tycons = getEnv_TyCons final_env
classes = getEnv_Classes final_env
- local_tycons = filter isLocallyDefined tycons
+ local_tycons = [ tc | tc <- tycons, isLocallyDefined tc && isDataTyCon tc ]
local_classes = filter isLocallyDefined classes
exported_ids' = filter isExported (eltsUFM ve2)
in
mkSigmaTy
)
import TyVar ( GenTyVar, TyVar(..), mkTyVar )
-import PrelInfo ( mkListTy, mkTupleTy )
import Type ( mkDictTy )
import Class ( cCallishClassKeys )
import TyCon ( TyCon, Arity(..) )
+import TysWiredIn ( mkListTy, mkTupleTy )
import Unique ( Unique )
import PprStyle
import Pretty
import Kind ( Kind, mkBoxedTypeKind, mkTypeKind )
import Maybes ( maybeToBool )
import PprType ( GenType, GenTyVar )
-import PrelInfo ( charPrimTy, intPrimTy, floatPrimTy,
- doublePrimTy, charTy, stringTy, mkListTy,
- mkTupleTy, addrTy, addrPrimTy )
+import PprStyle--ToDo:rm
import Pretty
import RnHsSyn ( RnName{-instance Outputable-} )
import Type ( splitFunTy, splitRhoTy, splitSigmaTy, mkTyVarTys,
Type(..), GenType
)
import TyVar ( GenTyVar )
+import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
+ doublePrimTy, addrPrimTy
+ )
+import TysWiredIn ( charTy, stringTy, mkListTy, mkTupleTy, addrTy )
import Unique ( Unique, eqClassOpKey )
import Util ( assertPanic, panic{-ToDo:rm-} )
\end{code}
\begin{code}
tcPat (VarPatIn name)
- = tcLookupLocalValueOK "tcPat1" name `thenNF_Tc` \ id ->
+ = tcLookupLocalValueOK ("tcPat1:"++ppShow 80 (ppr PprDebug name)) name `thenNF_Tc` \ id ->
returnTc (VarPat (TcId id), emptyLIE, idType id)
tcPat (LazyPatIn pat)
import TcMonad hiding ( rnMtoTcM )
import HsSyn -- the stuff being typechecked
-import PrelInfo ( PrimOp(..) -- to see CCallOp
- )
+--import PrelInfo ( PrimOp(..) -- to see CCallOp
+-- )
import Type
import CmdLineOpts
import CostCentre
mkTupleTyConName, mkFunTyConName
)
import Unique ( Unique, funTyConKey, mkTupleTyConUnique )
-import PrelInfo ( intDataCon, charDataCon )
import Pretty ( Pretty(..), PrettyRep )
-import PprStyle ( PprStyle )
import SrcLoc ( SrcLoc, mkBuiltinSrcLoc )
-import Unique ( intDataConKey, charDataConKey )
-import Util ( panic, panic#, nOfThem, isIn, Ord3(..) )
+import Util ( panic, panic#, pprPanic{-ToDo:rm-}, nOfThem, isIn, Ord3(..) )
+import {-hide me-}
+ PprType (pprTyCon)
+import {-hide me-}
+ PprStyle--ToDo:rm
\end{code}
\begin{code}
tyConFamilySize (DataTyCon _ _ _ _ _ data_cons _ _) = length data_cons
tyConFamilySize (TupleTyCon _ _ _) = 1
+#ifdef DEBUG
+tyConFamilySize other = pprPanic "tyConFamilySize:" (pprTyCon PprDebug other)
+#endif
\end{code}
\begin{code}
instance NamedThing (GenTyVar a) where
getName (TyVar _ _ (Just n) _) = n
- getName (TyVar u _ _ _) = mkLocalName u (showUnique u) mkUnknownSrcLoc
+ getName (TyVar u _ _ _) = mkLocalName u (showUnique u) True{-emph uniq-} mkUnknownSrcLoc
\end{code}
import TyLoop -- for paranoia checking
import PrelLoop -- for paranoia checking
--- ToDo:rm
---import PprType ( pprGenType ) -- ToDo: rm
---import PprStyle ( PprStyle(..) )
---import Util ( pprPanic )
-
-- friends:
import Class ( classSig, classOpLocalType, GenClass{-instances-} )
import Kind ( mkBoxedTypeKind, resultKind )
Nothing -> tv
Just (TyVarTy tv2) -> tv2
_ -> panic "applyTypeEnvToTy"
-{-
-instantiateTy tenv ty
- = go ty
- where
- go (TyVarTy tv) = case [ty | (tv',ty) <- tenv, tv==tv'] of
- [] -> TyVarTy tv
- (ty:_) -> ty
- go ty@(TyConTy tycon usage) = ty
- go (SynTy tycon tys ty) = SynTy tycon (map go tys) (go ty)
- go (FunTy arg res usage) = FunTy (go arg) (go res) usage
- go (AppTy fun arg) = AppTy (go fun) (go arg)
- go (DictTy clas ty usage) = DictTy clas (go ty) usage
- go (ForAllTy tv ty) = ASSERT(null tv_bound)
- ForAllTy tv (go ty)
- where
- tv_bound = [() | (tv',_) <- tenv, tv==tv']
-
- go (ForAllUsageTy uvar bds ty) = ForAllUsageTy uvar bds (go ty)
-
-instantiateTauTy tenv ty
- = go ty
- where
- go (TyVarTy tv) = case [ty | (tv',ty) <- tenv, tv==tv'] of
- (ty:_) -> ty
- [] -> panic "instantiateTauTy"
- go (TyConTy tycon usage) = TyConTy tycon usage
- go (SynTy tycon tys ty) = SynTy tycon (map go tys) (go ty)
- go (FunTy arg res usage) = FunTy (go arg) (go res) usage
- go (AppTy fun arg) = AppTy (go fun) (go arg)
- go (DictTy clas ty usage) = DictTy clas (go ty) usage
-
-applyTypeEnvToTy tenv ty
- = let
- result = mapOverTyVars v_fn ty
- in
--- pprTrace "applyTypeEnv:" (ppAboves [pprType PprDebug ty, pprType PprDebug result, ppAboves [ppCat [pprUnique u, pprType PprDebug t] | (u,t) <- ufmToList tenv]]) $
- result
- where
- v_fn v = case (lookupTyVarEnv tenv v) of
- Just ty -> ty
- Nothing -> TyVarTy v
-\end{code}
-
-@mapOverTyVars@ is a local function which actually does the work. It
-does no cloning or other checks for shadowing, so be careful when
-calling this on types with Foralls in them.
-
-\begin{code}
-mapOverTyVars :: (TyVar -> Type) -> Type -> Type
-
-mapOverTyVars v_fn ty
- = let
- mapper = mapOverTyVars v_fn
- in
- case ty of
- TyVarTy v -> v_fn v
- SynTy c as e -> SynTy c (map mapper as) (mapper e)
- FunTy a r u -> FunTy (mapper a) (mapper r) u
- AppTy f a -> AppTy (mapper f) (mapper a)
- DictTy c t u -> DictTy c (mapper t) u
- ForAllTy v t -> case (v_fn v) of
- TyVarTy v2 -> ForAllTy v2 (mapper t)
- _ -> panic "mapOverTyVars"
- tc@(TyConTy _ _) -> tc
--}
\end{code}
\begin{code}
(AppTy f1 a1) `eqSimpleTy` (AppTy f2 a2) =
f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2
(TyConTy tc1 u1) `eqSimpleTy` (TyConTy tc2 u2) =
- tc1 == tc2 && u1 == u2
+ tc1 == tc2 --ToDo: later: && u1 == u2
(FunTy f1 a1 u1) `eqSimpleTy` (FunTy f2 a2 u2) =
f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2 && u1 == u2
eq tve uve (AppTy f1 a1) (AppTy f2 a2) =
eq tve uve f1 f2 && eq tve uve a1 a2
eq tve uve (TyConTy tc1 u1) (TyConTy tc2 u2) =
- tc1 == tc2 && eqUsage uve u1 u2
+ tc1 == tc2 -- ToDo: LATER: && eqUsage uve u1 u2
eq tve uve (FunTy f1 a1 u1) (FunTy f2 a2 u2) =
eq tve uve f1 f2 && eq tve uve a1 a2 && eqUsage uve u1 u2
eqUVar, eqUsage
) where
-import Ubiq
+import Ubiq{-uitous-}
+
import Pretty ( Pretty(..), PrettyRep, ppPStr, ppBeside )
import UniqFM ( emptyUFM, listToUFM, addToUFM, lookupUFM,
- plusUFM, sizeUFM, UniqFM )
+ plusUFM, sizeUFM, UniqFM
+ )
import Unique ( Unique{-instances-} )
+import Util ( panic )
\end{code}
\begin{code}
usageOmega = UsageOmega
duffUsage :: GenUsage uvar
-duffUsage = error "Usage of non-Type kind doesn't make sense"
+duffUsage = panic "Usage of non-Type kind doesn't make sense"
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-#if __HASKELL1__ < 3
-data Maybe a
- = Nothing
- | Just a
-#endif
-\end{code}
-
-\begin{code}
maybeToBool :: Maybe a -> Bool
maybeToBool Nothing = False
maybeToBool (Just x) = True
The Maybe monad
~~~~~~~~~~~~~~~
\begin{code}
-#if __HASKELL1__ < 3
-thenMaybe :: Maybe a -> (a -> Maybe b) -> Maybe b
-m `thenMaybe` k = case m of
- Nothing -> Nothing
- Just a -> k a
-#endif
-
seqMaybe :: Maybe a -> Maybe a -> Maybe a
seqMaybe (Just x) _ = Just x
seqMaybe Nothing my = my
IF_NOT_GHC(forall COMMA exists COMMA)
zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
zipLazy,
- mapAndUnzip,
+ mapAndUnzip, mapAndUnzip3,
nOfThem, lengthExceeds, isSingleton,
startsWith, endsWith,
#if defined(COMPILING_GHC)
-- comparisons
Ord3(..), thenCmp, cmpList,
IF_NOT_GHC(cmpString COMMA)
-#ifdef USE_FAST_STRINGS
cmpPString,
-#else
- substr,
-#endif
+
-- pairs
IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA)
IF_NOT_GHC(applyToSnd COMMA foldPair COMMA)
, assertPanic
#endif {- COMPILING_GHC -}
- -- and to make the interface self-sufficient...
-#if __HASKELL1__ < 3
-# if defined(COMPILING_GHC)
- , Maybe(..){-.. for pragmas...-}, PrettyRep, Pretty(..)
-# else
- , Maybe
-# endif
-#endif
-
) where
#if defined(COMPILING_GHC)
import Pretty
#endif
-#if __HASKELL1__ < 3
-import Maybes ( Maybe(..) )
-#endif
infixr 9 `thenCmp`
\end{code}
(rs1, rs2) = mapAndUnzip f xs
in
(r1:rs1, r2:rs2)
+
+mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
+
+mapAndUnzip3 f [] = ([],[],[])
+mapAndUnzip3 f (x:xs)
+ = let
+ (r1, r2, r3) = f x
+ (rs1, rs2, rs3) = mapAndUnzip3 f xs
+ in
+ (r1:rs1, r2:rs2, r3:rs3)
\end{code}
\begin{code}
\end{code}
\begin{code}
-#ifdef USE_FAST_STRINGS
cmpPString :: FAST_STRING -> FAST_STRING -> TAG_
cmpPString x y
= case (_tagCmp x y) of { _LT -> LT_ ; _EQ -> EQ_ ; _GT -> GT_ }
-#endif
-\end{code}
-
-\begin{code}
-#ifndef USE_FAST_STRINGS
-substr :: FAST_STRING -> Int -> Int -> FAST_STRING
-
-substr str beg end
- = ASSERT (beg >= 0 && beg <= end)
- take (end - beg + 1) (drop beg str)
-#endif
\end{code}
%************************************************************************
projects / ghc-hetmet.git / commitdiff