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

Sansom 1.3 changes through 960507

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)
 

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@).

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

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'

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

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

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

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