diff options
68 files changed, 968 insertions, 865 deletions
diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs index c36e26e6ff..e518dcd6d6 100644 --- a/ghc/compiler/absCSyn/AbsCSyn.lhs +++ b/ghc/compiler/absCSyn/AbsCSyn.lhs @@ -31,11 +31,8 @@ module AbsCSyn {- ( -- registers MagicId(..), node, infoptr, - isVolatileReg, noLiveRegsMask, mkLiveRegsMask - -#ifdef GRAN - , CostRes(Cost) -#endif + isVolatileReg, noLiveRegsMask, mkLiveRegsMask, + CostRes(Cost) )-} where import Ubiq{-uitous-} @@ -224,14 +221,12 @@ data CStmtMacro | SET_ARITY | CHK_ARITY | SET_TAG -#ifdef GRAN | GRAN_FETCH -- for GrAnSim only -- HWL | GRAN_RESCHEDULE -- for GrAnSim only -- HWL | GRAN_FETCH_AND_RESCHEDULE -- for GrAnSim only -- HWL | THREAD_CONTEXT_SWITCH -- for GrAnSim only -- HWL -#endif + | GRAN_YIELD -- for GrAnSim only -- HWL deriving Text - \end{code} \item[@CCallProfCtrMacro@:] @@ -440,7 +435,7 @@ data MagicId -- Argument and return registers | VanillaReg -- pointers, unboxed ints and chars - PrimRep -- PtrRep, IntRep, CharRep, StablePtrRep or MallocPtrRep + PrimRep -- PtrRep, IntRep, CharRep, StablePtrRep or ForeignObjRep -- (in case we need to distinguish) FAST_INT -- its number (1 .. mAX_Vanilla_REG) diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index 74d2144243..f35342ca4b 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -43,10 +43,6 @@ module CLabel ( #if ! OMIT_NATIVE_CODEGEN , pprCLabel_asm #endif - -#ifdef GRAN - , isSlowEntryCCodeBlock -#endif ) where import Ubiq{-uitous-} @@ -299,20 +295,10 @@ externallyVisibleCLabel (IdLabel (CLabelId id) _) is_SuperDictSelId id = maybeToBool (isSuperDictSelId_maybe id) \end{code} -These GRAN functions are needed for spitting out GRAN_FETCH() at the +OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the right places. It is used to detect when the abstractC statement of an CCodeBlock actually contains the code for a slow entry point. -- HWL -\begin{code} -#ifdef GRAN - -isSlowEntryCCodeBlock :: CLabel -> Bool -isSlowEntryCCodeBlock _ = False --- Worth keeping? ToDo (WDP) - -#endif {-GRAN-} -\end{code} - We need at least @Eq@ for @CLabels@, because we want to avoid duplicate declarations in generating C (see @labelSeenTE@ in @PprAbsC@). diff --git a/ghc/compiler/absCSyn/Costs.lhs b/ghc/compiler/absCSyn/Costs.lhs index fd803f6b96..8f5e4d72db 100644 --- a/ghc/compiler/absCSyn/Costs.lhs +++ b/ghc/compiler/absCSyn/Costs.lhs @@ -60,28 +60,9 @@ module Costs( costs, import Ubiq{-uitous-} import AbsCSyn +import PrimOp ( primOpNeedsWrapper, PrimOp(..) ) -- -------------------------------------------------------------------------- -#ifndef GRAN --- a module of "stubs" that don't do anything -data CostRes = Cost (Int, Int, Int, Int, Int) -data Side = Lhs | Rhs - -nullCosts = Cost (0, 0, 0, 0, 0) :: CostRes - -costs :: AbstractC -> CostRes -addrModeCosts :: CAddrMode -> Side -> CostRes -costs _ = nullCosts -addrModeCosts _ _ = nullCosts - -instance Eq CostRes; instance Text CostRes - -instance Num CostRes where - x + y = nullCosts - -#else {-GRAN-} --- the real thing - data CostRes = Cost (Int, Int, Int, Int, Int) deriving (Text) @@ -425,10 +406,7 @@ gmpOps = ] --- Haven't found the .umul .div .rem macros yet --- If they are not Haskell cde, they are not costed, yet - -abs_costs = nullCosts -- NB: This is normal STG code with costs already +abs_costs = nullCosts -- NB: This is normal STG code with costs already -- included; no need to add costs again. umul_costs = Cost (21,4,0,0,0) -- due to spy counts @@ -439,8 +417,10 @@ primOpCosts :: PrimOp -> CostRes -- Special cases -primOpCosts (CCallOp _ _ _ _ _) = SAVE_COSTS + CCALL_COSTS_GUESS + - RESTORE_COSTS -- GUESS; check it +primOpCosts (CCallOp _ _ _ _ _) = SAVE_COSTS + RESTORE_COSTS + -- don't guess costs of ccall proper + -- for exact costing use a GRAN_EXEC + -- in the C code -- Usually 3 mov instructions are needed to get args and res in right place. @@ -484,7 +464,7 @@ primOpCosts FloatPowerOp = Cost (2, 1, 4, 4, 3) primOpCosts primOp | primOp `elem` floatOps = Cost (0, 0, 0, 0, 1) :: CostRes - | primOp `elem` gmpOps = Cost (50, 5, 10, 10, 0) :: CostRes -- GUESS; check it + | primOp `elem` gmpOps = Cost (30, 5, 10, 10, 0) :: CostRes -- GUESS; check it | otherwise = Cost (1, 0, 0, 0, 0) -- --------------------------------------------------------------------------- @@ -502,8 +482,6 @@ costsByKind FloatRep _ = nullCosts costsByKind DoubleRep _ = nullCosts -} -- --------------------------------------------------------------------------- - -#endif {-GRAN-} \end{code} This is the data structure of {\tt PrimOp} copied from prelude/PrimOp.lhs. @@ -601,8 +579,8 @@ data PrimOp | IndexOffAddrOp PrimRep -- PrimRep can be one of {Char,Int,Addr,Float,Double}Kind. -- This is just a cheesy encoding of a bunch of ops. - -- Note that MallocPtrRep is not included -- the only way of - -- creating a MallocPtr is with a ccall or casm. + -- Note that ForeignObjRep is not included -- the only way of + -- creating a ForeignObj is with a ccall or casm. | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp @@ -610,7 +588,11 @@ data PrimOp \end{pseudocode} A special ``trap-door'' to use in making calls direct to C functions: -Note: From GrAn point of view, CCall is probably very expensive -- HWL +Note: From GrAn point of view, CCall is probably very expensive + The programmer can specify the costs of the Ccall by inserting + a GRAN_EXEC(a,b,l,s,f) at the end of the C- code, specifing the + number or arithm., branch, load, store and floating point instructions + -- HWL \begin{pseudocode} | CCallOp String -- An "unboxed" ccall# to this named function diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index 9247568401..18053a7e91 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -13,7 +13,7 @@ module PprAbsC ( writeRealC, dumpRealC -#if defined(DEBUG) +#ifdef DEBUG , pprAmode -- otherwise, not exported #endif ) where @@ -83,14 +83,11 @@ from a cost 5 tuple. %% HWL \begin{code} emitMacro :: CostRes -> Unpretty -#ifndef GRAN -emitMacro _ = uppNil -#else +-- ToDo: Check a compile time flag to decide whether a macro should be emitted emitMacro (Cost (i,b,l,s,f)) = uppBesides [ uppStr "GRAN_EXEC(", - uppInt i, uppComma, uppInt b, uppComma, uppInt l, uppComma, - uppInt s, uppComma, uppInt f, pp_paren_semi ] -#endif {-GRAN-} + uppInt i, uppComma, uppInt b, uppComma, uppInt l, uppComma, + uppInt s, uppComma, uppInt f, pp_paren_semi ] \end{code} \begin{code} @@ -577,9 +574,11 @@ Some rough notes on generating code for @CCallOp@: (This happens after restoration of essential registers because we might need the @Base@ register to access all the others correctly.) +{- Doesn't apply anymore with ForeignObj, structure create via primop. + makeForeignObj (ForeignObj is not CReturnable) 7) If returning Malloc Pointer, build a closure containing the appropriate value. - +-} Otherwise, copy local variable into result register. 8) If ccall (not casm), declare the function being called as extern so @@ -593,11 +592,7 @@ Some rough notes on generating code for @CCallOp@: basic_restores; restores; - #if MallocPtr - constructMallocPtr(liveness, return_reg, _ccall_result); - #else - return_reg = _ccall_result; - #end + return_reg = _ccall_result; } \end{pseudocode} @@ -607,7 +602,7 @@ Amendment to the above: if we can GC, we have to: can get at them. * be sure that there are no live registers or we're in trouble. (This can cause problems if you try something foolish like passing - an array or mallocptr to a _ccall_GC_ thing.) + an array or foreign obj to a _ccall_GC_ thing.) * increment/decrement the @inCCallGC@ counter before/after the call so that the runtime check that PerformGC is being used sensibly will work. @@ -675,7 +670,7 @@ pprCCall sty op@(CCallOp op_str is_asm may_gc _ _) args results liveness_mask vo If the argument is a heap object, we need to reach inside and pull out the bit the C world wants to see. The only heap objects which can be -passed are @Array@s, @ByteArray@s and @MallocPtr@s. +passed are @Array@s, @ByteArray@s and @ForeignObj@s. \begin{code} ppr_casm_arg :: PprStyle -> CAddrMode -> Int -> (Unpretty, Unpretty) @@ -699,9 +694,9 @@ ppr_casm_arg sty amode a_num ByteArrayRep -> (pp_kind, uppBesides [uppStr "BYTE_ARR_CTS(", pp_amode, uppRparen]) - -- for Malloc Pointers, use MALLOC_PTR_DATA to fish out the contents. - MallocPtrRep -> (uppPStr SLIT("StgMallocPtr"), - uppBesides [uppStr "MallocPtr_CLOSURE_DATA(", pp_amode, uppStr")"]) + -- for ForeignObj, use FOREIGN_OBJ_DATA to fish out the contents. + ForeignObjRep -> (uppPStr SLIT("StgForeignObj"), + uppBesides [uppStr "ForeignObj_CLOSURE_DATA(", pp_amode, uppStr")"]) other -> (pp_kind, pp_amode) declare_local_var @@ -716,10 +711,11 @@ For l-values, the critical questions are: We only allow zero or one results. -2) Is the result is a mallocptr? +{- With the introduction of ForeignObj (MallocPtr++), no longer necess. +2) Is the result is a foreign obj? The mallocptr must be encapsulated immediately in a heap object. - +-} \begin{code} ppr_casm_results :: PprStyle -- style @@ -742,13 +738,20 @@ ppr_casm_results sty [r] liveness (result_type, assign_result) = case r_kind of - MallocPtrRep -> - (uppPStr SLIT("StgMallocPtr"), - uppBesides [ uppStr "constructMallocPtr(", +{- @ForeignObj@s replaces MallocPtrs and are *not* CReturnable. + Instead, external references have to be turned into ForeignObjs + using the primop makeForeignObj#. Benefit: Multiple finalisation + routines can be accommodated and the below special case is not needed. + Price is, of course, that you have to explicitly wrap `foreign objects' + with makeForeignObj#. ++ + ForeignObjRep -> + (uppPStr SLIT("StgForeignObj"), + uppBesides [ uppStr "constructForeignObj(", liveness, uppComma, result_reg, uppComma, local_var, - pp_paren_semi ]) + pp_paren_semi ]) -} _ -> (pprPrimKind sty r_kind, uppBesides [ result_reg, uppEquals, local_var, uppSemi ]) @@ -825,14 +828,6 @@ of the source addressing mode.) If the kind of the assignment is of pprAssign :: PprStyle -> PrimRep -> CAddrMode -> CAddrMode -> Unpretty pprAssign sty VoidRep dest src = uppNil - -#if 0 -pprAssign sty kind dest src - | (kind /= getAmodeRep dest) || (kind /= getAmodeRep src) - = uppCat [uppStr "Bad kind:", pprPrimKind sty kind, - pprPrimKind sty (getAmodeRep dest), pprAmode sty dest, - pprPrimKind sty (getAmodeRep src), pprAmode sty src] -#endif \end{code} Special treatment for floats and doubles, to avoid unwanted conversions. @@ -1089,7 +1084,7 @@ pprUnionTag FloatRep = uppChar 'f' pprUnionTag DoubleRep = panic "pprUnionTag:Double?" pprUnionTag StablePtrRep = uppChar 'i' -pprUnionTag MallocPtrRep = uppChar 'p' +pprUnionTag ForeignObjRep = uppChar 'p' pprUnionTag ArrayRep = uppChar 'p' pprUnionTag ByteArrayRep = uppChar 'b' diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 59d4697e59..d302df49ae 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -1122,10 +1122,10 @@ no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty) mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b mkSysLocal str uniq ty loc - = Id uniq (mkLocalName uniq str loc) ty (SysLocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo + = Id uniq (mkLocalName uniq str True{-emph uniq-} loc) ty (SysLocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo mkUserLocal str uniq ty loc - = Id uniq (mkLocalName uniq str loc) ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo + = Id uniq (mkLocalName uniq str False{-emph name-} loc) ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo -- mkUserId builds a local or top-level Id, depending on the name given mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 29c1667ce6..905c4bcbe1 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -147,21 +147,23 @@ showRdr sty rdr = ppShow 100 (ppr sty rdr) data Name = Local Unique FAST_STRING + Bool -- True <=> emphasize Unique when + -- printing; this is just an esthetic thing... SrcLoc | Global Unique - RdrName -- original name; Unqual => prelude - Provenance -- where it came from - ExportFlag -- is it exported? - [RdrName] -- ordered occurrence names (usually just one); - -- first may be *un*qual. + RdrName -- original name; Unqual => prelude + Provenance -- where it came from + ExportFlag -- is it exported? + [RdrName] -- ordered occurrence names (usually just one); + -- first may be *un*qual. data Provenance - = LocalDef SrcLoc -- locally defined; give its source location - - | Imported ExportFlag -- how it was imported - SrcLoc -- *original* source location - [SrcLoc] -- any import source location(s) + = LocalDef SrcLoc -- locally defined; give its source location + + | Imported ExportFlag -- how it was imported + SrcLoc -- *original* source location + [SrcLoc] -- any import source location(s) | Implicit | Builtin @@ -177,7 +179,8 @@ mkImplicitName :: Unique -> RdrName -> Name mkImplicitName u o = Global u o Implicit NotExported [] mkBuiltinName :: Unique -> Module -> FAST_STRING -> Name -mkBuiltinName u m{-NB: unused(?)-} n = Global u (Unqual n) Builtin NotExported [] +mkBuiltinName u m n + = Global u (if fromPrelude m then Unqual n else Qual m n) Builtin NotExported [] mkCompoundName :: Unique -> FAST_STRING -- indicates what kind of compound thing it is (e.g., "sdsel") @@ -185,7 +188,7 @@ mkCompoundName :: Unique -> Name -- from which we get provenance, etc.... -> Name -- result! -mkCompoundName u str ns (Local _ _ _) = panic "mkCompoundName:Local?" +mkCompoundName u str ns (Local _ _ _ _) = panic "mkCompoundName:Local?" mkCompoundName u str ns (Global _ _ prov exp _) = Global u (Unqual{-???-} (_CONCAT_ (glue ns [str]))) prov exp [] @@ -226,8 +229,8 @@ mkTupNameStr n -- ToDo: what about module ??? -- ToDo: exported when compiling builtin ??? -isLocalName (Local _ _ _) = True -isLocalName _ = False +isLocalName (Local _ _ _ _) = True +isLocalName _ = False isImplicitName (Global _ _ Implicit _ _) = True isImplicitName _ = False @@ -247,7 +250,7 @@ isBuiltinName _ = False \begin{code} cmpName n1 n2 = c n1 n2 where - c (Local u1 _ _) (Local u2 _ _) = cmp u1 u2 + c (Local u1 _ _ _) (Local u2 _ _ _) = cmp u1 u2 c (Global u1 _ _ _ _) (Global u2 _ _ _ _) = cmp u1 u2 c other_1 other_2 -- the tags *must* be different @@ -256,8 +259,8 @@ cmpName n1 n2 = c n1 n2 in if tag1 _LT_ tag2 then LT_ else GT_ - tag_Name (Local _ _ _) = (ILIT(1) :: FAST_INT) - tag_Name (Global _ _ _ _ _) = ILIT(2) + tag_Name (Local _ _ _ _) = (ILIT(1) :: FAST_INT) + tag_Name (Global _ _ _ _ _) = ILIT(2) \end{code} \begin{code} @@ -282,31 +285,31 @@ instance NamedThing Name where \end{code} \begin{code} -nameUnique (Local u _ _) = u -nameUnique (Global u _ _ _ _) = u +nameUnique (Local u _ _ _) = u +nameUnique (Global u _ _ _ _) = u -- when we renumber/rename things, we need to be -- able to change a Name's Unique to match the cached -- one in the thing it's the name of. If you know what I mean. -changeUnique (Local _ n l) u = Local u n l +changeUnique (Local _ n b l) u = Local u n b l changeUnique n@(Global _ o p e os) u = ASSERT(not (isBuiltinName n)) Global u o p e os -nameOrigName (Local _ n _) = Unqual n -nameOrigName (Global _ orig _ _ _) = orig +nameOrigName (Local _ n _ _) = Unqual n +nameOrigName (Global _ orig _ _ _) = orig -nameModuleNamePair (Local _ n _) = (panic "nameModuleNamePair", n) -nameModuleNamePair (Global _ (Unqual n) _ _ _) = (pRELUDE, n) -nameModuleNamePair (Global _ (Qual m n) _ _ _) = (m, n) +nameModuleNamePair (Local _ n _ _) = (panic "nameModuleNamePair", n) +nameModuleNamePair (Global _ (Unqual n) _ _ _) = (pRELUDE, n) +nameModuleNamePair (Global _ (Qual m n) _ _ _) = (m, n) -nameOccName (Local _ n _) = Unqual n -nameOccName (Global _ orig _ _ [] ) = orig -nameOccName (Global _ orig _ _ occs) = head occs +nameOccName (Local _ n _ _) = Unqual n +nameOccName (Global _ orig _ _ [] ) = orig +nameOccName (Global _ orig _ _ occs) = head occs -nameExportFlag (Local _ _ _) = NotExported -nameExportFlag (Global _ _ _ exp _) = exp +nameExportFlag (Local _ _ _ _) = NotExported +nameExportFlag (Global _ _ _ exp _) = exp -nameSrcLoc (Local _ _ loc) = loc +nameSrcLoc (Local _ _ _ loc) = loc nameSrcLoc (Global _ _ (LocalDef loc) _ _) = loc nameSrcLoc (Global _ _ (Imported _ loc _) _ _) = loc nameSrcLoc (Global _ _ Implicit _ _) = mkUnknownSrcLoc @@ -315,27 +318,28 @@ nameSrcLoc (Global _ _ Builtin _ _) = mkBuiltinSrcLoc nameImpLocs (Global _ _ (Imported _ _ locs) _ _) = locs nameImpLocs _ = [] -nameImportFlag (Local _ _ _) = NotExported +nameImportFlag (Local _ _ _ _) = NotExported nameImportFlag (Global _ _ (LocalDef _) _ _) = ExportAll nameImportFlag (Global _ _ (Imported exp _ _) _ _) = exp nameImportFlag (Global _ _ Implicit _ _) = ExportAll nameImportFlag (Global _ _ Builtin _ _) = ExportAll -isLocallyDefinedName (Local _ _ _) = True +isLocallyDefinedName (Local _ _ _ _) = True isLocallyDefinedName (Global _ _ (LocalDef _) _ _) = True isLocallyDefinedName (Global _ _ (Imported _ _ _) _ _) = False isLocallyDefinedName (Global _ _ Implicit _ _) = False isLocallyDefinedName (Global _ _ Builtin _ _) = False -isPreludeDefinedName (Local _ n _) = False -isPreludeDefinedName (Global _ orig _ _ _) = isUnqual orig +isPreludeDefinedName (Local _ n _ _) = False +isPreludeDefinedName (Global _ orig _ _ _) = isUnqual orig \end{code} \begin{code} instance Outputable Name where - ppr sty (Local u n _) + ppr sty (Local u n emph_uniq _) | codeStyle sty = pprUnique u - | otherwise = ppBesides [pprUnique u, ppStr "{-", ppPStr n, ppStr "-}"] + | emph_uniq = ppBesides [pprUnique u, ppStr "{-", ppPStr n, ppStr "-}"] + | otherwise = ppBesides [ppPStr n, ppStr "{-", pprUnique u, ppStr "-}"] ppr PprDebug (Global u o _ _ _) = ppBesides [ppr PprDebug o, ppStr "{-", pprUnique u, ppStr "-}"] ppr PprForUser (Global u o _ _ [] ) = ppr PprForUser o diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index 4e2d732d58..7e7b7193bd 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -107,9 +107,9 @@ module Unique ( ltDataConKey, mainIdKey, mainPrimIOIdKey, - mallocPtrDataConKey, - mallocPtrPrimTyConKey, - mallocPtrTyConKey, + foreignObjDataConKey, + foreignObjPrimTyConKey, + foreignObjTyConKey, monadClassKey, monadZeroClassKey, monadPlusClassKey, @@ -165,8 +165,8 @@ module Unique ( stateAndFloatPrimTyConKey, stateAndIntPrimDataConKey, stateAndIntPrimTyConKey, - stateAndMallocPtrPrimDataConKey, - stateAndMallocPtrPrimTyConKey, + stateAndForeignObjPrimDataConKey, + stateAndForeignObjPrimTyConKey, stateAndMutableArrayPrimDataConKey, stateAndMutableArrayPrimTyConKey, stateAndMutableByteArrayPrimDataConKey, @@ -195,13 +195,14 @@ module Unique ( wordDataConKey, wordPrimTyConKey, wordTyConKey -#ifdef GRAN , copyableIdKey , noFollowIdKey + , parAtAbsIdKey + , parAtForNowIdKey + , parAtIdKey + , parAtRelIdKey , parGlobalIdKey , parLocalIdKey -#endif - -- to make interface self-sufficient ) where import PreludeGlaST @@ -468,8 +469,8 @@ intTyConKey = mkPreludeTyConUnique 16 integerTyConKey = mkPreludeTyConUnique 17 liftTyConKey = mkPreludeTyConUnique 18 listTyConKey = mkPreludeTyConUnique 19 -mallocPtrPrimTyConKey = mkPreludeTyConUnique 20 -mallocPtrTyConKey = mkPreludeTyConUnique 21 +foreignObjPrimTyConKey = mkPreludeTyConUnique 20 +foreignObjTyConKey = mkPreludeTyConUnique 21 mutableArrayPrimTyConKey = mkPreludeTyConUnique 22 mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 23 orderingTyConKey = mkPreludeTyConUnique 24 @@ -488,7 +489,7 @@ stateAndCharPrimTyConKey = mkPreludeTyConUnique 36 stateAndDoublePrimTyConKey = mkPreludeTyConUnique 37 stateAndFloatPrimTyConKey = mkPreludeTyConUnique 38 stateAndIntPrimTyConKey = mkPreludeTyConUnique 39 -stateAndMallocPtrPrimTyConKey = mkPreludeTyConUnique 40 +stateAndForeignObjPrimTyConKey = mkPreludeTyConUnique 40 stateAndMutableArrayPrimTyConKey = mkPreludeTyConUnique 41 stateAndMutableByteArrayPrimTyConKey = mkPreludeTyConUnique 42 stateAndSynchVarPrimTyConKey = mkPreludeTyConUnique 43 @@ -526,7 +527,7 @@ intDataConKey = mkPreludeDataConUnique 11 integerDataConKey = mkPreludeDataConUnique 12 liftDataConKey = mkPreludeDataConUnique 13 ltDataConKey = mkPreludeDataConUnique 14 -mallocPtrDataConKey = mkPreludeDataConUnique 15 +foreignObjDataConKey = mkPreludeDataConUnique 15 nilDataConKey = mkPreludeDataConUnique 18 ratioDataConKey = mkPreludeDataConUnique 21 return2GMPsDataConKey = mkPreludeDataConUnique 22 @@ -539,7 +540,7 @@ stateAndCharPrimDataConKey = mkPreludeDataConUnique 28 stateAndDoublePrimDataConKey = mkPreludeDataConUnique 29 stateAndFloatPrimDataConKey = mkPreludeDataConUnique 30 stateAndIntPrimDataConKey = mkPreludeDataConUnique 31 -stateAndMallocPtrPrimDataConKey = mkPreludeDataConUnique 32 +stateAndForeignObjPrimDataConKey = mkPreludeDataConUnique 32 stateAndMutableArrayPrimDataConKey = mkPreludeDataConUnique 33 stateAndMutableByteArrayPrimDataConKey = mkPreludeDataConUnique 34 stateAndSynchVarPrimDataConKey = mkPreludeDataConUnique 35 @@ -593,12 +594,14 @@ nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 32 noDefaultMethodErrorIdKey = mkPreludeMiscIdUnique 33 nonExplicitMethodErrorIdKey = mkPreludeMiscIdUnique 34 -#ifdef GRAN -parLocalIdKey = mkPreludeMiscIdUnique 35 -parGlobalIdKey = mkPreludeMiscIdUnique 36 -noFollowIdKey = mkPreludeMiscIdUnique 37 -copyableIdKey = mkPreludeMiscIdUnique 38 -#endif +copyableIdKey = mkPreludeMiscIdUnique 35 +noFollowIdKey = mkPreludeMiscIdUnique 36 +parAtAbsIdKey = mkPreludeMiscIdUnique 37 +parAtForNowIdKey = mkPreludeMiscIdUnique 38 +parAtIdKey = mkPreludeMiscIdUnique 39 +parAtRelIdKey = mkPreludeMiscIdUnique 40 +parGlobalIdKey = mkPreludeMiscIdUnique 41 +parLocalIdKey = mkPreludeMiscIdUnique 42 \end{code} Certain class operations from Prelude classes. They get diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index 85f58f16b6..2d0f3aebd1 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -30,21 +30,21 @@ import CgBindery ( getVolatileRegs, getArgAmode, getArgAmodes, idInfoToAmode ) import CgCon ( buildDynCon, bindConArgs ) -import CgHeapery ( heapCheck ) +import CgHeapery ( heapCheck, yield ) import CgRetConv ( dataReturnConvAlg, dataReturnConvPrim, ctrlReturnConvAlg, DataReturnConvention(..), CtrlReturnConvention(..), assignPrimOpResultRegs, makePrimOpArgsRobust ) -import CgStackery ( allocAStack, allocBStack ) +import CgStackery ( allocAStack, allocBStack, allocAStackTop, allocBStackTop ) import CgTailCall ( tailCallBusiness, performReturn ) import CgUsages ( getSpARelOffset, getSpBRelOffset, freeBStkSlot ) import CLabel ( mkVecTblLabel, mkReturnPtLabel, mkDefaultLabel, mkAltLabel, mkClosureLabel ) import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynCon ) -import CmdLineOpts ( opt_SccProfilingOn ) +import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros ) import CostCentre ( useCurrentCostCentre ) import HeapOffs ( VirtualSpBOffset(..), VirtualHeapOffset(..) ) import Id ( idPrimRep, toplevelishId, @@ -55,7 +55,9 @@ import Id ( idPrimRep, toplevelishId, import Maybes ( catMaybes ) import PprStyle ( PprStyle(..) ) import PprType ( GenType{-instance Outputable-} ) -import PrimOp ( primOpCanTriggerGC, PrimOp(..) ) +import PrimOp ( primOpCanTriggerGC, PrimOp(..), + primOpStackRequired, StackRequirement(..) + ) import PrimRep ( getPrimRepSize, isFollowableRep, retPrimRepSize, PrimRep(..) ) @@ -173,10 +175,6 @@ cgCase scrut@(StgPrim op args _) live_in_whole_case live_in_alts uniq panic "cgCase: case on PrimOp with default *and* alts\n" -- For now, die if alts are non-empty else -#if 0 - pprTrace "cgCase:prim app returning alg data type: bad code!" (ppr PprDebug scrut) $ - -- See above TO DO TO DO -#endif cgExpr (StgLet (StgNonRec id scrut_rhs) deflt_rhs) where scrut_rhs = StgRhsClosure useCurrentCostCentre stgArgOcc{-safe-} scrut_free_vars @@ -199,6 +197,8 @@ cgCase (StgPrim op args _) live_in_whole_case live_in_alts uniq alts -- Perform the operation getVolatileRegs live_in_alts `thenFC` \ vol_regs -> + -- seq cannot happen here => no additional B Stack alloc + absC (COpStmt result_amodes op arg_amodes -- note: no liveness arg liveness_mask vol_regs) `thenC` @@ -231,9 +231,29 @@ cgCase (StgPrim op args _) live_in_whole_case live_in_alts uniq alts nukeDeadBindings live_in_whole_case `thenC` saveVolatileVars live_in_alts `thenFC` \ volatile_var_save_assts -> - getEndOfBlockInfo `thenFC` \ eob_info -> - forkEval eob_info nopC - (getAbsC (cgInlineAlts GCMayHappen uniq alts) `thenFC` \ abs_c -> + -- Allocate stack words for the prim-op itself, + -- these are guaranteed to be ON TOP OF the stack. + -- Currently this is used *only* by the seq# primitive op. + let + (a_req,b_req) = case (primOpStackRequired op) of + NoStackRequired -> (0, 0) + 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) @@ -461,7 +481,7 @@ cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt) 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 -> @@ -493,6 +513,12 @@ cgInlineAlts :: GCFlag -> Unique -> 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 @@ -500,7 +526,7 @@ do the right thing. \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. @@ -509,7 +535,8 @@ Tag is held in a temporary. \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) @@ -536,6 +563,11 @@ cgInlineAlts gc_flag uniq (StgPrimAlts ty alts deflt) 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 @@ -544,6 +576,7 @@ cgAlgAlts :: GCFlag -> 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 ) @@ -571,15 +604,16 @@ It's all pretty turgid anyway. \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 @@ -636,25 +670,36 @@ Now comes the general case \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) @@ -667,11 +712,19 @@ cgAlgDefault gc_flag uniq restore_cc must_label_branch 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 @@ -686,15 +739,21 @@ cgAlgDefault gc_flag uniq restore_cc must_label_branch 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 @@ -704,9 +763,14 @@ cgAlgAlt gc_flag uniq restore_cc must_label_branch (con, args, use_mask, rhs) 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 @@ -717,6 +781,13 @@ cgAlgAltRhs gc_flag con args use_mask rhs -- 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` \ _ -> diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 54875d7fab..81ff55f65c 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -29,9 +29,7 @@ import CgBindery ( getCAddrMode, getArgAmodes, 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, @@ -49,7 +47,7 @@ import CLabel ( mkClosureLabel, mkConUpdCodePtrVecLabel, 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 @@ -432,7 +430,6 @@ closureCodeBody binder_info closure_info cc all_args body = 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 @@ -489,12 +486,6 @@ closureCodeBody binder_info closure_info cc all_args body -- 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 @@ -515,11 +506,6 @@ closureCodeBody binder_info closure_info cc all_args body 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 @@ -659,35 +645,43 @@ argSatisfactionCheck closure_info args 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 @@ -708,12 +702,16 @@ thunkWrapper closure_info thunk_code = -- 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 @@ -739,6 +737,14 @@ funWrapper :: ClosureInfo -- Closure whose code body this is 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 diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs index 29a89a57f4..98c5a1deed 100644 --- a/ghc/compiler/codeGen/CgConTbls.lhs +++ b/ghc/compiler/codeGen/CgConTbls.lhs @@ -246,6 +246,25 @@ genConInfo comp_info tycon data_con 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 @@ -261,7 +280,7 @@ mkConCodeAndInfo con 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 @@ -278,7 +297,7 @@ mkConCodeAndInfo con = -- 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 @@ -288,6 +307,9 @@ mkConCodeAndInfo con 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} %************************************************************************ diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index 6fed112402..dd0b7f4d4f 100644 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -44,7 +44,7 @@ import PrimOp ( primOpCanTriggerGC, primOpHeapReq, HeapRequirement(..), ) 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 @@ -94,7 +94,8 @@ Here is where we insert real live machine instructions. \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 diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs index 798c6ba16e..fa8f1e0bdb 100644 --- a/ghc/compiler/codeGen/CgHeapery.lhs +++ b/ghc/compiler/codeGen/CgHeapery.lhs @@ -10,10 +10,8 @@ module CgHeapery ( 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-} @@ -41,56 +39,15 @@ import PrimRep ( PrimRep(..) ) %* * %************************************************************************ -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 @@ -169,10 +126,10 @@ heapCheck' do_context_switch regs node_reqd 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 @@ -187,8 +144,35 @@ fetchAndReschedule regs node_reqd = --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} %************************************************************************ diff --git a/ghc/compiler/codeGen/CgRetConv.lhs b/ghc/compiler/codeGen/CgRetConv.lhs index 856a119cd2..14e59f4526 100644 --- a/ghc/compiler/codeGen/CgRetConv.lhs +++ b/ghc/compiler/codeGen/CgRetConv.lhs @@ -42,7 +42,6 @@ import Id ( isDataCon, dataConSig, import Maybes ( catMaybes ) import PprStyle ( PprStyle(..) ) import PprType ( TyCon{-instance Outputable-} ) -import PrelInfo ( integerDataCon ) import PrimOp ( primOpCanTriggerGC, getPrimOpResultInfo, PrimOpResultInfo(..), PrimOp{-instance Outputable-} @@ -129,8 +128,6 @@ dataReturnConvAlg data_con (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} %************************************************************************ @@ -158,7 +155,7 @@ dataReturnConvPrim ArrayRep = VanillaReg ArrayRep ILIT(1) 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" @@ -207,8 +204,8 @@ argument into it). 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... diff --git a/ghc/compiler/codeGen/CgStackery.lhs b/ghc/compiler/codeGen/CgStackery.lhs index 0ad6fc52fb..8e1c90a58e 100644 --- a/ghc/compiler/codeGen/CgStackery.lhs +++ b/ghc/compiler/codeGen/CgStackery.lhs @@ -10,7 +10,8 @@ Stack-twiddling operations, which are pretty low-down and grimy. #include "HsVersions.h" module CgStackery ( - allocAStack, allocBStack, allocUpdateFrame, + allocAStack, allocBStack, allocAStackTop, allocBStackTop, + allocUpdateFrame, adjustRealSps, getFinalStackHW, mkVirtStkOffsets, mkStkAmodes ) where @@ -59,7 +60,20 @@ mkVirtStkOffsets init_SpA_offset init_SpB_offset kind_fun things (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@. @@ -166,6 +180,28 @@ allocBStack size info_down (MkCgState absC binds 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 diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs index 8b3c23e5cc..15b2ae249b 100644 --- a/ghc/compiler/codeGen/CgTailCall.lhs +++ b/ghc/compiler/codeGen/CgTailCall.lhs @@ -36,7 +36,7 @@ import CLabel ( mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel ) 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 @@ -314,10 +314,7 @@ tailCallBusiness :: Id -> CAddrMode -- Function and its amode -> 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 -> @@ -346,10 +343,7 @@ tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts `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 diff --git a/ghc/compiler/coreSyn/CoreLift.lhs b/ghc/compiler/coreSyn/CoreLift.lhs index 6719a8051f..664231e378 100644 --- a/ghc/compiler/coreSyn/CoreLift.lhs +++ b/ghc/compiler/coreSyn/CoreLift.lhs @@ -26,9 +26,10 @@ import Id ( idType, mkSysLocal, 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 ) diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index f30e5e724e..304b30ecd7 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -38,7 +38,7 @@ import Type ( mkFunTy,getFunTy_maybe,mkForAllTy,mkForAllTys,getForAllTy_maybe, 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(..) diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index c282c70ccb..6e6d7baf30 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -43,9 +43,7 @@ import PprCore ( GenCoreExpr{-instances-}, GenCoreArg{-instances-} ) 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(..) ) @@ -53,6 +51,7 @@ import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy, mkTyVarTy, getFunTy_maybe, applyTy, isPrimType, splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy ) +import TysWiredIn ( trueDataCon, falseDataCon ) import UniqSupply ( initUs, returnUs, thenUs, mapUs, mapAndUnzipUs, getUnique, UniqSM(..), UniqSupply diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index d324b5f28e..fbae35c89b 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -20,13 +20,15 @@ import Id ( dataConArgTys, mkTupleCon ) 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" @@ -147,38 +149,7 @@ unboxArg arg \ 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 @@ -256,34 +227,6 @@ boxResult result_ty \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) diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 835c9f9d9a..8d059a2671 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -42,15 +42,15 @@ import MagicUFs ( MagicUnfoldingFun ) 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 ) diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs index 938d8657ed..a1a41b4fdb 100644 --- a/ghc/compiler/deSugar/DsGRHSs.lhs +++ b/ghc/compiler/deSugar/DsGRHSs.lhs @@ -22,7 +22,7 @@ import DsMonad 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-} ) diff --git a/ghc/compiler/deSugar/DsHsSyn.lhs b/ghc/compiler/deSugar/DsHsSyn.lhs index 8fae20c9e8..b54d8a2698 100644 --- a/ghc/compiler/deSugar/DsHsSyn.lhs +++ b/ghc/compiler/deSugar/DsHsSyn.lhs @@ -16,7 +16,7 @@ import TcHsSyn ( TypecheckedPat(..), TypecheckedBind(..), TypecheckedMonoBinds(..) ) import Id ( idType ) -import PrelInfo ( mkListTy, mkTupleTy, unitTy ) +import TysWiredIn ( mkListTy, mkTupleTy, unitTy ) import Util ( panic ) \end{code} diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index 123a8f28f9..5508cb1b40 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -19,10 +19,10 @@ import DsUtils 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 ) diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 740044bae0..579062820d 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -40,7 +40,7 @@ import DsMonad 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-}, diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index ebddac2413..82c5a8ea8f 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -32,19 +32,20 @@ import Id ( idType, mkTupleCon, dataConSig, ) 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} diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index a2e7a00a62..c2a2b437bd 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -161,7 +161,7 @@ opt_AllStrict = lookup SLIT("-fall-strict") 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") @@ -185,10 +185,10 @@ opt_D_verbose_stg2stg = lookup SLIT("-dverbose-stg") 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") @@ -201,7 +201,6 @@ opt_NumbersStrict = lookup SLIT("-fnumbers-strict") 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") diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 129afc12ef..ce876cb1b2 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -140,11 +140,11 @@ ifaceUsages (Just if_hdl) usages 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} @@ -160,7 +160,7 @@ ifaceVersions (Just if_hdl) version_info 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} @@ -257,13 +257,13 @@ ifaceDecls Nothing{-no iface handle-} _ = return () 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 @@ -281,17 +281,17 @@ ifaceInstances Nothing{-no iface handle-} _ = return () 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 -- && ... ------- diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs index add0adae06..237b3343f1 100644 --- a/ghc/compiler/nativeGen/MachMisc.lhs +++ b/ghc/compiler/nativeGen/MachMisc.lhs @@ -390,7 +390,7 @@ primRepToSize DoubleRep = IF_ARCH_alpha( TF, IF_ARCH_i386( DF,IF_ARCH_sparc( 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} %************************************************************************ diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index d8e1bf6154..01b0404176 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -52,7 +52,7 @@ First, the dreaded @ccall@. We can't handle @casm@s. 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 @@ -414,7 +414,7 @@ primCode lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs 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} diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index c6b04a2790..dee0852bb4 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -8,88 +8,11 @@ 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 @@ -231,7 +154,7 @@ prim_tycons , doublePrimTyCon , floatPrimTyCon , intPrimTyCon - , mallocPtrPrimTyCon + , foreignObjPrimTyCon , mutableArrayPrimTyCon , mutableByteArrayPrimTyCon , synchVarPrimTyCon @@ -272,7 +195,7 @@ data_tycons , intTyCon , integerTyCon , liftTyCon - , mallocPtrTyCon + , foreignObjTyCon , ratioTyCon , return2GMPsTyCon , returnIntAndGMPTyCon @@ -284,7 +207,7 @@ data_tycons , stateAndDoublePrimTyCon , stateAndFloatPrimTyCon , stateAndIntPrimTyCon - , stateAndMallocPtrPrimTyCon + , stateAndForeignObjPrimTyCon , stateAndMutableArrayPrimTyCon , stateAndMutableByteArrayPrimTyCon , stateAndSynchVarPrimTyCon @@ -338,15 +261,14 @@ parallel_ids 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) @@ -405,6 +327,7 @@ tysyn_keys 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 @@ -414,6 +337,7 @@ class_keys , (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 diff --git a/ghc/compiler/prelude/PrelMods.lhs b/ghc/compiler/prelude/PrelMods.lhs index 08bcc1a099..02fd9f6fef 100644 --- a/ghc/compiler/prelude/PrelMods.lhs +++ b/ghc/compiler/prelude/PrelMods.lhs @@ -9,11 +9,14 @@ defined here so as to avod #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 @@ -25,15 +28,15 @@ gLASGOW_MISC = SLIT("PreludeGlaMisc") 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} diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs index 506b50e8d6..0ce975e5ef 100644 --- a/ghc/compiler/prelude/PrelVals.lhs +++ b/ghc/compiler/prelude/PrelVals.lhs @@ -24,7 +24,7 @@ import IdInfo -- quite a bit 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} @@ -164,13 +164,13 @@ OK, this is Will's idea: we should have magic values for Integers 0, +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} %************************************************************************ @@ -274,50 +274,191 @@ forkId = pcMiscPrelId forkIdKey pRELUDE_BUILTIN SLIT("_fork_") \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} %************************************************************************ @@ -453,7 +594,7 @@ realWorldPrimId \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) @@ -498,7 +639,7 @@ mkBuild ty tv c n g expr \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) diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 1874d83a4f..d02f5e19a7 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -20,6 +20,7 @@ module PrimOp ( primOpOkForSpeculation, primOpIsCheap, fragilePrimOp, HeapRequirement(..), primOpHeapReq, + StackRequirement(..), primOpStackRequired, -- export for the Native Code Generator primOpInfo, -- needed for primOpNameInfo @@ -45,7 +46,7 @@ import TyCon ( TyCon{-instances-} ) 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} @@ -144,8 +145,8 @@ data PrimOp | IndexOffAddrOp PrimRep -- PrimRep can be one of {Char,Int,Addr,Float,Double}Kind. -- This is just a cheesy encoding of a bunch of ops. - -- Note that MallocPtrRep is not included -- the only way of - -- creating a MallocPtr is with a ccall or casm. + -- Note that ForeignObjRep is not included -- the only way of + -- creating a ForeignObj is with a ccall or casm. | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp @@ -153,6 +154,7 @@ data PrimOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp + | MakeForeignObjOp -- foreign objects (malloc pointers or any old URL) | MakeStablePtrOp | DeRefStablePtrOp \end{code} @@ -239,18 +241,19 @@ about using it this way?? ADR) | 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 @@ -409,25 +412,27 @@ tagOf_PrimOp TakeMVarOp = ILIT(151) 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" @@ -591,19 +596,25 @@ allThePrimOps 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} @@ -1117,16 +1128,56 @@ primOpInfo DelayOp [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} %************************************************************************ %* * @@ -1239,27 +1290,26 @@ primOpInfo ForkOp -- fork# :: a -> Int# \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} %************************************************************************ @@ -1337,18 +1387,12 @@ primOpHeapReq DoubleDecodeOp = FixedHeapRequired (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 @@ -1375,24 +1419,31 @@ primOpHeapReq ForkOp = 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. @@ -1405,7 +1456,8 @@ primOpCanTriggerGC op TakeMVarOp -> True ReadIVarOp -> True DelayOp -> True - WaitOp -> True + WaitReadOp -> True + WaitWriteOp -> True _ -> case primOpHeapReq op of VariableHeapRequired -> True @@ -1457,10 +1509,14 @@ primOpOkForSpeculation ParOp = False -- Could be expensive! 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 @@ -1483,15 +1539,18 @@ fragilePrimOp :: PrimOp -> Bool 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} @@ -1551,6 +1610,7 @@ primOpNeedsWrapper DoublePowerOp = True primOpNeedsWrapper DoubleEncodeOp = True primOpNeedsWrapper DoubleDecodeOp = True +primOpNeedsWrapper MakeForeignObjOp = True primOpNeedsWrapper MakeStablePtrOp = True primOpNeedsWrapper DeRefStablePtrOp = True @@ -1559,7 +1619,8 @@ primOpNeedsWrapper PutMVarOp = True primOpNeedsWrapper ReadIVarOp = True primOpNeedsWrapper DelayOp = True -primOpNeedsWrapper WaitOp = True +primOpNeedsWrapper WaitReadOp = True +primOpNeedsWrapper WaitWriteOp = True primOpNeedsWrapper other_op = False \end{code} diff --git a/ghc/compiler/prelude/PrimRep.lhs b/ghc/compiler/prelude/PrimRep.lhs index b4fbf55e9f..1a6d45e5e1 100644 --- a/ghc/compiler/prelude/PrimRep.lhs +++ b/ghc/compiler/prelude/PrimRep.lhs @@ -50,7 +50,7 @@ data PrimRep | 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] @@ -86,7 +86,8 @@ isFollowableRep :: PrimRep -> Bool 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 @@ -166,7 +167,7 @@ showPrimRep DoubleRep = "StgDouble" 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 @@ -186,15 +187,17 @@ All local C variables of @ArrayRep@ are declared in C as type @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 diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs index a64821db44..28b4571219 100644 --- a/ghc/compiler/prelude/TysPrim.lhs +++ b/ghc/compiler/prelude/TysPrim.lhs @@ -182,25 +182,26 @@ mkStablePtrPrimTy ty = applyTyCon stablePtrPrimTyCon [ty] %************************************************************************ %* * -\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} diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 2efbb8494a..a4623c2fd2 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -42,7 +42,7 @@ module TysWiredIn ( liftTyCon, listTyCon, ltDataCon, - mallocPtrTyCon, + foreignObjTyCon, mkLiftTy, mkListTy, mkPrimIoTy, @@ -68,7 +68,7 @@ module TysWiredIn ( stateAndDoublePrimTyCon, stateAndFloatPrimTyCon, stateAndIntPrimTyCon, - stateAndMallocPtrPrimTyCon, + stateAndForeignObjPrimTyCon, stateAndMutableArrayPrimTyCon, stateAndMutableByteArrayPrimTyCon, stateAndPtrPrimTyCon, @@ -219,17 +219,17 @@ stablePtrTyCon 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} %************************************************************************ @@ -330,14 +330,14 @@ stateAndStablePtrPrimDataCon [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#") @@ -424,7 +424,7 @@ getStatePairingConInfo prim_ty (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)), @@ -531,10 +531,10 @@ primitive counterpart. \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} %************************************************************************ @@ -660,15 +660,15 @@ rationalTy :: GenType t u 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} @@ -725,7 +725,7 @@ stringTy = mkListTy charTy stringTyCon = mkSynTyCon - (mkBuiltinName stringTyConKey pRELUDE_CORE SLIT("String")) + (mkBuiltinName stringTyConKey pRELUDE SLIT("String")) mkBoxedTypeKind 0 [] stringTy \end{code} diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs index b5beb1f1bd..2740a5b6b8 100644 --- a/ghc/compiler/profiling/CostCentre.lhs +++ b/ghc/compiler/profiling/CostCentre.lhs @@ -228,7 +228,7 @@ setToAbleCostCentre :: CostCentre -> Bool -- 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" diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index d87feb2ce9..bd7dc9d3a7 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -119,8 +119,8 @@ module_stuff_pair : CONID INTEGER DCOLON name_version_pairs SEMI 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 diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 743c83d125..47ed0fd245 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -14,7 +14,7 @@ import Ubiq 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 @@ -43,6 +43,7 @@ import Maybes ( catMaybes ) 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 ) @@ -165,13 +166,18 @@ renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _) -- 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 diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 51073048bc..c80f351cc2 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -92,12 +92,6 @@ isRnImplicit _ = False 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 @@ -128,8 +122,8 @@ instance NamedThing RnName where 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" diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 9b7bf0fac6..eaaa862186 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -308,7 +308,7 @@ mkLocalNames names_w_locs 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} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 10ea30ac30..ff9736afdc 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -22,7 +22,7 @@ import RnHsSyn import RnMonad import RnIfaces ( IfaceCache(..), cachedIface, cachedDecl ) import RnUtils ( RnEnv(..), emptyRnEnv, extendGlobalRnEnv, - lubExportFlag, qualNameErr, dupNamesErr, negateNameWarn + lubExportFlag, qualNameErr, dupNamesErr ) import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst ) @@ -292,7 +292,6 @@ newGlobalName locn maybe_exp rdr 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} @@ -491,6 +490,7 @@ getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec 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 @@ -509,7 +509,7 @@ getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec 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) @@ -518,6 +518,11 @@ getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec (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 -> diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 6050153bac..043d0ebe42 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -29,13 +29,13 @@ import Name ( Name, isLocallyDefined, isLexVarId, getLocalName, ExportFlag(..), 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. @@ -122,45 +122,67 @@ rnExports mods unqual_imps Nothing 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 @@ -169,20 +191,20 @@ rnIE mods (IEVar name) 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 -> @@ -190,13 +212,14 @@ rnIE mods (IEThingAll name) 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) @@ -209,19 +232,21 @@ rnIE mods (IEThingWith name names) 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) @@ -231,14 +256,14 @@ rnIE mods (IEThingWith name names) 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 @@ -306,7 +331,7 @@ rn_derivs tycon2 locn (Just ds) 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 diff --git a/ghc/compiler/simplCore/ConFold.lhs b/ghc/compiler/simplCore/ConFold.lhs index c508cf59fd..ef787b2d23 100644 --- a/ghc/compiler/simplCore/ConFold.lhs +++ b/ghc/compiler/simplCore/ConFold.lhs @@ -19,10 +19,10 @@ import CoreUnfold ( UnfoldingDetails(..), FormSummary(..) ) 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} diff --git a/ghc/compiler/simplCore/MagicUFs.lhs b/ghc/compiler/simplCore/MagicUFs.lhs index ad986d78b6..32318fe299 100644 --- a/ghc/compiler/simplCore/MagicUFs.lhs +++ b/ghc/compiler/simplCore/MagicUFs.lhs @@ -17,10 +17,10 @@ import Ubiq{-uitous-} 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} diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs index 3ec493a76a..4054a14463 100644 --- a/ghc/compiler/simplCore/SimplCase.lhs +++ b/ghc/compiler/simplCore/SimplCase.lhs @@ -28,12 +28,13 @@ import Id ( idType, isDataCon, getIdDemandInfo, 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 ) diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index ade1cfa03f..5406e3da09 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -663,7 +663,7 @@ extendUnfoldEnvGivenConstructor env var con args (_, 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} diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index ba1cc4e7bc..ac24d65fc4 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -32,11 +32,12 @@ import Id ( idType, isBottomingId, idWantsToBeINLINEd, dataConArgTys, ) 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 ) diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 9ef9b2a491..27424dd023 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -29,7 +29,6 @@ import Maybes ( maybeToBool ) 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 ) @@ -40,6 +39,7 @@ import SimplUtils import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, splitFunTy, getFunTy_maybe, eqTy ) +import TysWiredIn ( realWorldStateTy ) import Util ( isSingleton, zipEqual, panic, pprPanic, assertPanic ) \end{code} diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 4a87887eb0..2b69f39cce 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -49,7 +49,6 @@ import PprType ( pprGenType, pprParendGenType, pprMaybeTy, GenType{-instance Outputable-}, GenTyVar{-ditto-}, TyCon{-ditto-} ) -import PrelInfo ( liftDataCon ) import Pretty ( ppHang, ppCat, ppStr, ppAboves, ppBesides, ppInt, ppSP, ppInterleave, ppNil, Pretty(..) ) @@ -64,6 +63,7 @@ import TyVar ( cloneTyVar, nullTyVarEnv, growTyVarEnvList, TyVarEnv(..), GenTyVar{-instance Eq-} ) +import TysWiredIn ( liftDataCon ) import Unique ( Unique{-instance Eq-} ) import UniqSet ( mkUniqSet, unionUniqSets, uniqSetToList ) import UniqSupply ( splitUniqSupply, getUniques, getUnique ) diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 3ed0d38090..edd2d815f3 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -29,8 +29,7 @@ import Id ( mkSysLocal, idType, isBottomingId, ) import Literal ( mkMachInt, Literal(..) ) import Name ( isExported ) -import PrelInfo ( unpackCStringId, unpackCString2Id, stringTy, - integerTy, rationalTy, ratioDataCon, +import PrelVals ( unpackCStringId, unpackCString2Id, integerZeroId, integerPlusOneId, integerPlusTwoId, integerMinusOneId ) @@ -38,6 +37,7 @@ import PrimOp ( PrimOp(..) ) import SpecUtils ( mkSpecialisedCon ) import SrcLoc ( mkUnknownSrcLoc ) import Type ( getAppDataTyConExpandingDicts ) +import TysWiredIn ( stringTy, integerTy, rationalTy, ratioDataCon ) import UniqSupply -- all of it, really import Util ( panic ) @@ -426,17 +426,21 @@ coreExprToStg env expr@(Lam _ _) = 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} %************************************************************************ diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs index cc26fab490..04ba2f0b6d 100644 --- a/ghc/compiler/stranal/SaAbsInt.lhs +++ b/ghc/compiler/stranal/SaAbsInt.lhs @@ -30,9 +30,6 @@ import MagicUFs ( MagicUnfoldingFun ) 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 @@ -40,6 +37,9 @@ import TyCon ( maybeTyConSingleCon, isEnumerationTyCon, 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 ) diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index ceea5e7242..eeaafc9c03 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -17,7 +17,7 @@ import Ubiq{-uitous-} 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 diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index b4fc7f2c80..052d796319 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -225,17 +225,17 @@ newOverloadedLit orig lit ty \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} diff --git a/ghc/compiler/typecheck/TcDefaults.lhs b/ghc/compiler/typecheck/TcDefaults.lhs index d714ddd21a..964847d8d8 100644 --- a/ghc/compiler/typecheck/TcDefaults.lhs +++ b/ghc/compiler/typecheck/TcDefaults.lhs @@ -21,7 +21,7 @@ import TcEnv ( tcLookupClassByKey ) import TcMonoType ( tcMonoType ) import TcSimplify ( tcSimplifyCheckThetas ) -import PrelInfo ( intTy, doubleTy, unitTy ) +import TysWiredIn ( intTy, doubleTy, unitTy ) import Unique ( numClassKey ) import Util \end{code} diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index fa2ff93539..21e864e3e0 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -47,10 +47,6 @@ import Id ( Id(..), GenId, idType, dataConFieldLabels, dataConSig ) 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, @@ -58,12 +54,19 @@ import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, 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 @@ -781,10 +784,14 @@ tcDoStmts _ m (stmt@(ExprStmt exp src_loc) : stmts) 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_` diff --git a/ghc/compiler/typecheck/TcGRHSs.lhs b/ghc/compiler/typecheck/TcGRHSs.lhs index 44bdfce15c..edc2869829 100644 --- a/ghc/compiler/typecheck/TcGRHSs.lhs +++ b/ghc/compiler/typecheck/TcGRHSs.lhs @@ -21,7 +21,7 @@ import TcExpr ( tcExpr ) import TcType ( TcType(..) ) import Unify ( unifyTauTy ) -import PrelInfo ( boolTy ) +import TysWiredIn ( boolTy ) \end{code} \begin{code} diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index cf7eb32745..8f19aef1c7 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -81,7 +81,7 @@ import Maybes ( maybeToBool ) --import Name ( Name(..) ) import Outputable import PrimOp -import PrelInfo +--import PrelInfo import Pretty import SrcLoc ( mkGeneratedSrcLoc ) import TyCon ( TyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon ) @@ -1047,11 +1047,11 @@ showString_PN = prelude_val pRELUDE_TEXT SLIT("showString") 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 diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 9f3506bdeb..006777ac1a 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -48,11 +48,11 @@ import ErrUtils ( Warning(..), Error(..) ) 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, @@ -185,6 +185,7 @@ tcModule rn_env -- 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) @@ -244,7 +245,7 @@ tcModule rn_env 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 diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index 34b628dede..eee6f125e1 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -29,10 +29,10 @@ import Type ( GenType, Type(..), ThetaType(..), 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 diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index bb9f71e23f..0c8470cbd1 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -32,9 +32,7 @@ import Id ( GenId, idType ) 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, @@ -42,6 +40,10 @@ 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} @@ -58,7 +60,7 @@ tcPat :: RenamedPat -> TcM s (TcPat s, LIE s, TcType s) \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) diff --git a/ghc/compiler/typecheck/TcPragmas.lhs b/ghc/compiler/typecheck/TcPragmas.lhs index 8e28da6099..5ce5ca76a2 100644 --- a/ghc/compiler/typecheck/TcPragmas.lhs +++ b/ghc/compiler/typecheck/TcPragmas.lhs @@ -16,8 +16,8 @@ module TcPragmas ( 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 diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index d40619627a..b983664863 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -54,12 +54,13 @@ import Name ( Name, RdrName(..), appendRdr, nameUnique, 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} @@ -230,6 +231,9 @@ tyConDataCons other = [] tyConFamilySize (DataTyCon _ _ _ _ _ data_cons _ _) = length data_cons tyConFamilySize (TupleTyCon _ _ _) = 1 +#ifdef DEBUG +tyConFamilySize other = pprPanic "tyConFamilySize:" (pprTyCon PprDebug other) +#endif \end{code} \begin{code} diff --git a/ghc/compiler/types/TyVar.lhs b/ghc/compiler/types/TyVar.lhs index 88f1e855d8..980f1dd1e2 100644 --- a/ghc/compiler/types/TyVar.lhs +++ b/ghc/compiler/types/TyVar.lhs @@ -148,5 +148,5 @@ instance Uniquable (GenTyVar a) where 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} diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index e7774150be..aff733f824 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -44,11 +44,6 @@ import IdLoop -- for paranoia checking 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 ) @@ -596,71 +591,6 @@ applyTypeEnvToTy tenv ty 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} @@ -779,7 +709,7 @@ eqSimpleTy :: (Eq t,Eq u) => GenType t u -> GenType t u -> Bool (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 @@ -828,7 +758,7 @@ eqTy t1 t2 = 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 diff --git a/ghc/compiler/types/Usage.lhs b/ghc/compiler/types/Usage.lhs index 7d6c448f1f..e5c4eb147f 100644 --- a/ghc/compiler/types/Usage.lhs +++ b/ghc/compiler/types/Usage.lhs @@ -14,11 +14,14 @@ module Usage ( 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} @@ -33,7 +36,7 @@ type Usage = GenUsage UVar 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} %************************************************************************ diff --git a/ghc/compiler/utils/Maybes.lhs b/ghc/compiler/utils/Maybes.lhs index 3a29c7f017..1c6a863eaa 100644 --- a/ghc/compiler/utils/Maybes.lhs +++ b/ghc/compiler/utils/Maybes.lhs @@ -52,14 +52,6 @@ CHK_Ubiq() -- debugging consistency check %************************************************************************ \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 @@ -112,13 +104,6 @@ expectJust err Nothing = error ("expectJust " ++ err) 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 diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index b56e4cca0f..c026524ecf 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -39,7 +39,7 @@ module Util ( IF_NOT_GHC(forall COMMA exists COMMA) zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, zipLazy, - mapAndUnzip, + mapAndUnzip, mapAndUnzip3, nOfThem, lengthExceeds, isSingleton, startsWith, endsWith, #if defined(COMPILING_GHC) @@ -67,11 +67,8 @@ module Util ( -- 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) @@ -83,15 +80,6 @@ module Util ( , 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) @@ -100,9 +88,6 @@ CHK_Ubiq() -- debugging consistency check import Pretty #endif -#if __HASKELL1__ < 3 -import Maybes ( Maybe(..) ) -#endif infixr 9 `thenCmp` \end{code} @@ -195,6 +180,16 @@ mapAndUnzip f (x:xs) (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} @@ -722,22 +717,10 @@ cmpString _ _ = panic# "cmpString" \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} %************************************************************************ |