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

Sansom 1.3 changes through 960507

diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs
index c36e26e..e518dcd 100644 (file)
--- a/ghc/compiler/absCSyn/AbsCSyn.lhs
+++ b/ghc/compiler/absCSyn/AbsCSyn.lhs
@@ -31,11 +31,8 @@ module AbsCSyn {- (
 
        -- registers
        MagicId(..), node, infoptr,
 
        -- registers
        MagicId(..), node, infoptr,

-       isVolatileReg, noLiveRegsMask, mkLiveRegsMask
-
-#ifdef GRAN
-       , CostRes(Cost)
-#endif
+       isVolatileReg, noLiveRegsMask, mkLiveRegsMask,
+       CostRes(Cost)

     )-} where
 
 import Ubiq{-uitous-}
     )-} where
 
 import Ubiq{-uitous-}

@@ -224,14 +221,12 @@ data CStmtMacro
   | SET_ARITY
   | CHK_ARITY
   | SET_TAG
   | 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
   | 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
   deriving Text

-

 \end{code}
 
 \item[@CCallProfCtrMacro@:]
 \end{code}
 
 \item[@CCallProfCtrMacro@:]

@@ -440,7 +435,7 @@ data MagicId
 
   -- Argument and return registers
   | VanillaReg         -- pointers, unboxed ints and chars
 
   -- 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)
 
                        --      (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 74d2144..f35342c 100644 (file)
--- 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
 #if ! OMIT_NATIVE_CODEGEN
        , pprCLabel_asm
 #endif

-
-#ifdef GRAN
-       , isSlowEntryCCodeBlock
-#endif

     ) where
 
 import Ubiq{-uitous-}
     ) where
 
 import Ubiq{-uitous-}

@@ -299,20 +295,10 @@ externallyVisibleCLabel (IdLabel (CLabelId id) _)
     is_SuperDictSelId  id = maybeToBool (isSuperDictSelId_maybe  id)
 \end{code}
 
     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
 
 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@).
 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 fd803f6..8f5e4d7 100644 (file)
--- 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 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)
 
 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
                        --      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
 
 
 -- 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.
 
 
 -- 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
 
 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)
 
 -- ---------------------------------------------------------------------------
   | otherwise             = Cost (1, 0, 0, 0, 0)
 
 -- ---------------------------------------------------------------------------

@@ -502,8 +482,6 @@ costsByKind FloatRep        _ = nullCosts
 costsByKind DoubleRep  _ = nullCosts
 -}
 -- ---------------------------------------------------------------------------
 costsByKind DoubleRep  _ = nullCosts
 -}
 -- ---------------------------------------------------------------------------

-
-#endif {-GRAN-}

 \end{code}
 
 This is the data structure of {\tt PrimOp} copied from prelude/PrimOp.lhs.
 \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.
     | 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
 
 
     | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp
 

@@ -610,7 +588,11 @@ data PrimOp
 \end{pseudocode}
 
 A special ``trap-door'' to use in making calls direct to C functions:
 \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
 
 \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 9247568..18053a7 100644 (file)
--- a/ghc/compiler/absCSyn/PprAbsC.lhs
+++ b/ghc/compiler/absCSyn/PprAbsC.lhs
@@ -13,7 +13,7 @@
 module PprAbsC (
        writeRealC,
        dumpRealC
 module PprAbsC (
        writeRealC,
        dumpRealC

-#if defined(DEBUG)
+#ifdef DEBUG

        , pprAmode -- otherwise, not exported
 #endif
     ) where
        , pprAmode -- otherwise, not exported
 #endif
     ) where

@@ -83,14 +83,11 @@ from a cost 5 tuple. %%  HWL
 \begin{code}
 emitMacro :: CostRes -> Unpretty
 
 \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(",
 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}
 \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.)
 
    (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.
 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
    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;
 
   basic_restores;
   restores;
 

-  #if MallocPtr
-       constructMallocPtr(liveness, return_reg, _ccall_result);
-  #else
-       return_reg = _ccall_result;
-  #end
+  return_reg = _ccall_result;

 }
 \end{pseudocode}
 
 }
 \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
   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.
 
 * 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
 
 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)
 
 \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])
 
              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
              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.
 
 
    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.
 
    The mallocptr must be encapsulated immediately in a heap object.

-
+-}

 \begin{code}
 ppr_casm_results ::
        PprStyle        -- style
 \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
 
        (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,
                                liveness, uppComma,
                                result_reg, uppComma,
                                local_var,

-                            pp_paren_semi ])
+                            pp_paren_semi ]) -}

              _ ->
                (pprPrimKind sty r_kind,
                 uppBesides [ result_reg, uppEquals, local_var, uppSemi ])
              _ ->
                (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
 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.
 \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 DoubleRep          = panic "pprUnionTag:Double?"
 
 pprUnionTag StablePtrRep       = uppChar 'i'

-pprUnionTag MallocPtrRep       = uppChar 'p'
+pprUnionTag ForeignObjRep      = uppChar 'p'

 
 pprUnionTag ArrayRep           = uppChar 'p'
 pprUnionTag ByteArrayRep       = uppChar 'b'
 
 pprUnionTag ArrayRep           = uppChar 'p'
 pprUnionTag ByteArrayRep       = uppChar 'b'

diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index 59d4697..d302df4 100644 (file)
--- 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
 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
 
 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
 
 -- 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 29c1667..905c4bc 100644 (file)
--- 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
 data Name
   = Local    Unique
              FAST_STRING

+            Bool       -- True <=> emphasize Unique when
+                       -- printing; this is just an esthetic thing...

              SrcLoc
 
   | Global   Unique
              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
 
 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
 
   | Implicit
   | Builtin

@@ -177,7 +179,8 @@ mkImplicitName :: Unique -> RdrName -> Name
 mkImplicitName u o = Global u o Implicit NotExported []
 
 mkBuiltinName :: Unique -> Module -> FAST_STRING -> 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")
 
 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!
 
               -> 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 []
 
 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 ???
 
        -- 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
 
 isImplicitName (Global _ _ Implicit _ _) = True
 isImplicitName _                        = False

@@ -247,7 +250,7 @@ isBuiltinName  _                     = False
 \begin{code}
 cmpName n1 n2 = c n1 n2
   where
 \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
     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_
 
        in
        if tag1 _LT_ tag2 then LT_ else GT_
 

-    tag_Name (Local    _ _ _)    = (ILIT(1) :: FAST_INT)
-    tag_Name (Global   _ _ _ _ _) = ILIT(2)
+    tag_Name (Local  _ _ _ _)  = (ILIT(1) :: FAST_INT)
+    tag_Name (Global _ _ _ _ _) = ILIT(2)

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

@@ -282,31 +285,31 @@ instance NamedThing Name where
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

-nameUnique (Local    u _ _)     = u
-nameUnique (Global   u _ _ _ _) = u
+nameUnique (Local  u _ _ _)   = u
+nameUnique (Global u _ _ _ _) = u

 
 -- when we renumber/rename things, we need to be
 -- able to change a Name's Unique to match the cached
 -- one in the thing it's the name of.  If you know what I mean.
 
 -- 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
 
 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
 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 _                                   = []
 
 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
 
 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
 
 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
 \end{code}
 
 \begin{code}
 instance Outputable Name where

-    ppr sty (Local u n _)
+    ppr sty (Local u n emph_uniq _)

       | codeStyle sty = pprUnique u
       | 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
 
     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 4e2d732..7e7b719 100644 (file)
--- a/ghc/compiler/basicTypes/Unique.lhs
+++ b/ghc/compiler/basicTypes/Unique.lhs
@@ -107,9 +107,9 @@ module Unique (
        ltDataConKey,
        mainIdKey,
        mainPrimIOIdKey,
        ltDataConKey,
        mainIdKey,
        mainPrimIOIdKey,

-       mallocPtrDataConKey,
-       mallocPtrPrimTyConKey,
-       mallocPtrTyConKey,
+       foreignObjDataConKey,
+       foreignObjPrimTyConKey,
+       foreignObjTyConKey,

        monadClassKey,
        monadZeroClassKey,
        monadPlusClassKey,
        monadClassKey,
        monadZeroClassKey,
        monadPlusClassKey,

@@ -165,8 +165,8 @@ module Unique (
        stateAndFloatPrimTyConKey,
        stateAndIntPrimDataConKey,
        stateAndIntPrimTyConKey,
        stateAndFloatPrimTyConKey,
        stateAndIntPrimDataConKey,
        stateAndIntPrimTyConKey,

-       stateAndMallocPtrPrimDataConKey,
-       stateAndMallocPtrPrimTyConKey,
+       stateAndForeignObjPrimDataConKey,
+       stateAndForeignObjPrimTyConKey,

        stateAndMutableArrayPrimDataConKey,
        stateAndMutableArrayPrimTyConKey,
        stateAndMutableByteArrayPrimDataConKey,
        stateAndMutableArrayPrimDataConKey,
        stateAndMutableArrayPrimTyConKey,
        stateAndMutableByteArrayPrimDataConKey,

@@ -195,13 +195,14 @@ module Unique (
        wordDataConKey,
        wordPrimTyConKey,
        wordTyConKey
        wordDataConKey,
        wordPrimTyConKey,
        wordTyConKey

-#ifdef GRAN

        , copyableIdKey
        , noFollowIdKey
        , copyableIdKey
        , noFollowIdKey

+       , parAtAbsIdKey
+       , parAtForNowIdKey
+       , parAtIdKey
+       , parAtRelIdKey

        , parGlobalIdKey
        , parLocalIdKey
        , parGlobalIdKey
        , parLocalIdKey

-#endif
-       -- to make interface self-sufficient

     ) where
 
 import PreludeGlaST
     ) where
 
 import PreludeGlaST

@@ -468,8 +469,8 @@ intTyConKey                         = mkPreludeTyConUnique 16
 integerTyConKey                                = mkPreludeTyConUnique 17
 liftTyConKey                           = mkPreludeTyConUnique 18
 listTyConKey                           = mkPreludeTyConUnique 19
 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
 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
 stateAndDoublePrimTyConKey             = mkPreludeTyConUnique 37
 stateAndFloatPrimTyConKey              = mkPreludeTyConUnique 38
 stateAndIntPrimTyConKey                        = mkPreludeTyConUnique 39

-stateAndMallocPtrPrimTyConKey          = mkPreludeTyConUnique 40
+stateAndForeignObjPrimTyConKey         = mkPreludeTyConUnique 40

 stateAndMutableArrayPrimTyConKey       = mkPreludeTyConUnique 41
 stateAndMutableByteArrayPrimTyConKey   = mkPreludeTyConUnique 42
 stateAndSynchVarPrimTyConKey           = mkPreludeTyConUnique 43
 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
 integerDataConKey                      = mkPreludeDataConUnique 12
 liftDataConKey                         = mkPreludeDataConUnique 13
 ltDataConKey                           = mkPreludeDataConUnique 14

-mallocPtrDataConKey                    = mkPreludeDataConUnique 15
+foreignObjDataConKey                   = mkPreludeDataConUnique 15

 nilDataConKey                          = mkPreludeDataConUnique 18
 ratioDataConKey                                = mkPreludeDataConUnique 21
 return2GMPsDataConKey                  = mkPreludeDataConUnique 22
 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
 stateAndDoublePrimDataConKey           = mkPreludeDataConUnique 29
 stateAndFloatPrimDataConKey            = mkPreludeDataConUnique 30
 stateAndIntPrimDataConKey              = mkPreludeDataConUnique 31

-stateAndMallocPtrPrimDataConKey                = mkPreludeDataConUnique 32
+stateAndForeignObjPrimDataConKey               = mkPreludeDataConUnique 32

 stateAndMutableArrayPrimDataConKey     = mkPreludeDataConUnique 33
 stateAndMutableByteArrayPrimDataConKey = mkPreludeDataConUnique 34
 stateAndSynchVarPrimDataConKey         = mkPreludeDataConUnique 35
 stateAndMutableArrayPrimDataConKey     = mkPreludeDataConUnique 33
 stateAndMutableByteArrayPrimDataConKey = mkPreludeDataConUnique 34
 stateAndSynchVarPrimDataConKey         = mkPreludeDataConUnique 35

@@ -593,12 +594,14 @@ nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 32
 noDefaultMethodErrorIdKey     = mkPreludeMiscIdUnique 33
 nonExplicitMethodErrorIdKey   = mkPreludeMiscIdUnique 34
 
 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
 \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 85f58f1..2d0f3ae 100644 (file)
--- 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 )
                          idInfoToAmode
                        )
 import CgCon           ( buildDynCon, bindConArgs )

-import CgHeapery       ( heapCheck )
+import CgHeapery       ( heapCheck, yield )

 import CgRetConv       ( dataReturnConvAlg, dataReturnConvPrim,
                          ctrlReturnConvAlg,
                          DataReturnConvention(..), CtrlReturnConvention(..),
                          assignPrimOpResultRegs,
                          makePrimOpArgsRobust
                        )
 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 CgTailCall      ( tailCallBusiness, performReturn )
 import CgUsages                ( getSpARelOffset, getSpBRelOffset, freeBStkSlot )
 import CLabel          ( mkVecTblLabel, mkReturnPtLabel, mkDefaultLabel,
                          mkAltLabel, mkClosureLabel
                        )
 import ClosureInfo     ( mkConLFInfo, mkLFArgument, layOutDynCon )

-import CmdLineOpts     ( opt_SccProfilingOn )
+import CmdLineOpts     ( opt_SccProfilingOn, opt_GranMacros )

 import CostCentre      ( useCurrentCostCentre )
 import HeapOffs                ( VirtualSpBOffset(..), VirtualHeapOffset(..) )
 import Id              ( idPrimRep, toplevelishId,
 import 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 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(..)
                        )
 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
        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
        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 ->
 
        -- 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`
     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 ->
 
     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)
              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
            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 ->
                                        `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}
 
             -> 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
 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)
 
 \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.
 \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-}
 \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)
 
        -- 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.
 
 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
 \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
          -> 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
             )
          -> 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-} _)
 \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
   = 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
             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
   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 -}
 \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" -}]
             [{- 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
 \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
 
 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)
   = 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`
 
   = 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)
             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)
 
 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`
 
   =    -- 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
             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
 
   where
     lbl = mkDefaultLabel uniq
 

+-- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs

 
 cgAlgAlt :: GCFlag
         -> Unique -> AbstractC -> Bool         -- turgid state
 
 cgAlgAlt :: GCFlag
         -> Unique -> AbstractC -> Bool         -- turgid state

+        -> Bool                               -- Context switch at alts?

         -> (Id, [Id], [Bool], StgExpr)
         -> FCode (ConTag, AbstractC)
 
         -> (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`
   = 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
     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
 
     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
   = 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
                                -- 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` \ _ ->
     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 54875d7..81ff55f 100644 (file)
--- 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
 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, 
                        )
 import CgRetConv       ( mkLiveRegsMask,
                          ctrlReturnConvAlg, dataReturnConvAlg, 

@@ -49,7 +47,7 @@ import CLabel         ( mkClosureLabel, mkConUpdCodePtrVecLabel,
                          mkErrorStdEntryLabel, mkRednCountsLabel
                        )
 import ClosureInfo     -- lots and lots of stuff
                          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
 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
   = 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
        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`
 
            -- 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
            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`
                    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
 
                -- 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 ->
 
 
     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`
     -- 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
 
     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
        in

+       ASSERT(a_rel_int /= 0)

        if node_points then
        if node_points then

-           absC (CMacroStmt ARGS_CHK_A [lit])
+           absC (CMacroStmt ARGS_CHK_A [a_rel_arg])

        else
        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
     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
        in

+       ASSERT(b_rel_int /= 0)

        if node_points then
        if node_points then

-           absC (CMacroStmt ARGS_CHK_B [lit])
+           absC (CMacroStmt ARGS_CHK_B [b_rel_arg])

        else
        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
   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 ->
 
   =    -- 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
 
 
     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 ->
 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
     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 29a89a5..98c5a1d 100644 (file)
--- 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}
 
     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
 \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`
 
            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
                              (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`
 
                = -- 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
                                (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))
     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}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs
index 6fed112..dd0b7f4 100644 (file)
--- 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 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
 \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)
 
 \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
     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 798c6ba..fa8f1e0 100644 (file)
--- a/ghc/compiler/codeGen/CgHeapery.lhs
+++ b/ghc/compiler/codeGen/CgHeapery.lhs
@@ -10,10 +10,8 @@ module CgHeapery (
        heapCheck,
        allocHeap, allocDynClosure
 
        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-}
     ) 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}
 
 \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
 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
 -- Emit macro for simulating a fetch and then reschedule
 
 fetchAndReschedule ::   [MagicId]               -- Live registers

-                       -> Bool                 -- Node reqd
+                       -> Bool                 -- Node reqd?

                        -> Code
 
                        -> Code
 

-fetchAndReschedule regs node_reqd =
+fetchAndReschedule regs node_reqd  =

       if (node `elem` regs || node_reqd)
        then fetch_code `thenC` reschedule_code
        else absC AbsCNop
       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 [])
         --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}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

diff --git a/ghc/compiler/codeGen/CgRetConv.lhs b/ghc/compiler/codeGen/CgRetConv.lhs
index 856a119..14e59f4 100644 (file)
--- 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 Maybes          ( catMaybes )
 import PprStyle                ( PprStyle(..) )
 import PprType         ( TyCon{-instance Outputable-} )

-import PrelInfo                ( integerDataCon )

 import PrimOp          ( primOpCanTriggerGC,
                          getPrimOpResultInfo, PrimOpResultInfo(..),
                          PrimOp{-instance Outputable-}
 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)
     (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}
 
 %************************************************************************
 \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 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"
 
 #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
 
 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...
 
 
 See after for some ADR comments...
 

diff --git a/ghc/compiler/codeGen/CgStackery.lhs b/ghc/compiler/codeGen/CgStackery.lhs
index 0ad6fc5..8e1c90a 100644 (file)
--- 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 (
 #include "HsVersions.h"
 
 module CgStackery (

-       allocAStack, allocBStack, allocUpdateFrame,
+       allocAStack, allocBStack, allocAStackTop, allocBStackTop,
+       allocUpdateFrame,

        adjustRealSps, getFinalStackHW,
        mkVirtStkOffsets, mkStkAmodes
     ) where
        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
        (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@.
 \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
     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
 \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 8b3c23e..15b2ae2 100644 (file)
--- 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 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
 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
                 -> 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 ->
 
     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  ->
                                                     `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
 
 
        no_of_args = length arg_amodes
 

diff --git a/ghc/compiler/coreSyn/CoreLift.lhs b/ghc/compiler/coreSyn/CoreLift.lhs
index 6719a80..664231e 100644 (file)
--- 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 )
                          GenId{-instances-}
                        )
 import Name            ( isLocallyDefined, getSrcLoc )

-import PrelInfo                ( liftDataCon, mkLiftTy, statePrimTyCon )

 import TyCon           ( isBoxedTyCon, TyCon{-instance-} )
 import Type            ( maybeAppDataTyConExpandingDicts, eqTy )
 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 )
 
 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 f30e5e7..304b30e 100644 (file)
--- 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
                        )
                          maybeAppDataTyConExpandingDicts, eqTy
 --                       ,expandTy -- ToDo:rm
                        )

-import TyCon           ( isPrimTyCon, tyConFamilySize )
+import TyCon           ( isPrimTyCon )

 import TyVar           ( tyVarKind, GenTyVar{-instances-} )
 import UniqSet         ( emptyUniqSet, mkUniqSet, intersectUniqSets,
                          unionUniqSets, elementOfUniqSet, UniqSet(..)
 import 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 c282c70..6e6d7ba 100644 (file)
--- 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 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(..) )
 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
                        )
                          getFunTy_maybe, applyTy, isPrimType,
                          splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy
                        )

+import TysWiredIn      ( trueDataCon, falseDataCon )

 import UniqSupply      ( initUs, returnUs, thenUs,
                          mapUs, mapAndUnzipUs, getUnique,
                          UniqSM(..), UniqSupply
 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 d324b5f..fbae35c 100644 (file)
--- 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 Maybes          ( maybeToBool )
 import PprStyle                ( PprStyle(..) )
 import PprType         ( GenType{-instances-} )

-import PrelInfo                ( byteArrayPrimTy, getStatePairingConInfo,
-                         packStringForCId, realWorldStatePrimTy,
-                         realWorldStateTy, realWorldTy, stateDataCon,
-                         stringTy )

 import Pretty
 import Pretty

+import PrelVals                ( packStringForCId )

 import PrimOp          ( PrimOp(..) )
 import Type            ( isPrimType, maybeAppDataTyConExpandingDicts, eqTy )
 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"
 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)
     )
              \ 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
   | otherwise
   = pprPanic "unboxArg: " (ppr PprDebug arg_ty)
   where

@@ -256,34 +227,6 @@ boxResult result_ty
              \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
     )
 
              \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)
 
   | otherwise
   = pprPanic "boxResult: " (ppr PprDebug result_ty)
 

diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index 835c9f9..8d059a2 100644 (file)
--- 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 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 Pretty          ( ppShow, ppBesides, ppPStr, ppStr )
 import TyCon           ( isDataTyCon, isNewTyCon )
 import Type            ( splitSigmaTy, splitFunTy, typePrimRep,
                          getAppDataTyConExpandingDicts, getAppTyCon, applyTy
                        )

+import TysWiredIn      ( mkTupleTy, unitTy, nilDataCon, consDataCon,
+                         charDataCon, charTy
+                       )

 import TyVar           ( nullTyVarEnv, addOneToTyVarEnv, GenTyVar{-instance Eq-} )
 import Usage           ( UVar(..) )
 import Util            ( zipEqual, pprError, panic, assertPanic )
 import 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 938d865..a1a41b4 100644 (file)
--- a/ghc/compiler/deSugar/DsGRHSs.lhs
+++ b/ghc/compiler/deSugar/DsGRHSs.lhs
@@ -22,7 +22,7 @@ import DsMonad
 import DsUtils
 
 import CoreUtils       ( mkCoreIfThenElse )
 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-} )
 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 8fae20c..b54d8a2 100644 (file)
--- a/ghc/compiler/deSugar/DsHsSyn.lhs
+++ b/ghc/compiler/deSugar/DsHsSyn.lhs
@@ -16,7 +16,7 @@ import TcHsSyn                ( TypecheckedPat(..), TypecheckedBind(..),
                          TypecheckedMonoBinds(..) )
 
 import Id              ( idType )
                          TypecheckedMonoBinds(..) )
 
 import Id              ( idType )

-import PrelInfo                ( mkListTy, mkTupleTy, unitTy )
+import TysWiredIn      ( mkListTy, mkTupleTy, unitTy )

 import Util            ( panic )
 \end{code}
 
 import Util            ( panic )
 \end{code}
 

diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs
index 123a8f2..5508cb1 100644 (file)
--- 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 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 Type            ( mkTyVarTy, mkForAllTy, mkFunTys )
 import TysPrim         ( alphaTy )

+import TysWiredIn      ( nilDataCon, consDataCon, listTyCon )

 import TyVar           ( alphaTyVar )
 import Match           ( matchSimply )
 import Util            ( panic )
 import TyVar           ( alphaTyVar )
 import Match           ( matchSimply )
 import Util            ( panic )

diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 740044b..5790628 100644 (file)
--- 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 CoreUtils       ( coreExprType, mkCoreIfThenElse )
 import PprStyle                ( PprStyle(..) )

-import PrelInfo                ( stringTy, iRREFUT_PAT_ERROR_ID )
+import PrelVals                ( iRREFUT_PAT_ERROR_ID )

 import Pretty          ( ppShow )
 import Id              ( idType, dataConArgTys, mkTupleCon,
                          pprId{-ToDo:rm-},
 import 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 ebddac2..82c5a8e 100644 (file)
--- 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 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 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}
 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 a2e7a00..c2a2b43 100644 (file)
--- 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_AutoSccsOnAllToplevs       = lookup  SLIT("-fauto-sccs-on-all-toplevs")
 opt_AutoSccsOnExportedToplevs  = lookup  SLIT("-fauto-sccs-on-exported-toplevs")
 opt_AutoSccsOnIndividualCafs   = lookup  SLIT("-fauto-sccs-on-individual-cafs")

-opt_CompilingPrelude           = lookup  SLIT("-prelude")
+opt_CompilingPrelude           = lookup  SLIT("-fcompiling-prelude")

 opt_D_dump_absC                        = lookup  SLIT("-ddump-absC")
 opt_D_dump_asm                 = lookup  SLIT("-ddump-asm")
 opt_D_dump_deforest            = lookup  SLIT("-ddump-deforest")
 opt_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_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_FoldrBuildOn               = lookup  SLIT("-ffoldr-build-on")
 opt_FoldrBuildTrace            = lookup  SLIT("-ffoldr-build-trace")
 opt_ForConcurrent              = lookup  SLIT("-fconcurrent")

+opt_GranMacros                 = lookup  SLIT("-fgransim")

 opt_GlasgowExts                        = lookup  SLIT("-fglasgow-exts")
 opt_Haskell_1_3                        = lookup  SLIT("-fhaskell-1.3")
 opt_HideBuiltinNames           = lookup  SLIT("-fhide-builtin-names")
 opt_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_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")
 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 129afc1..ce876cb 100644 (file)
--- 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))
     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
               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}
 \end{code}
 
 \begin{code}

@@ -160,7 +160,7 @@ ifaceVersions (Just if_hdl) version_info
     version_list = fmToList version_info
 
     upp_versions nvs
     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}
 \end{code}
 
 \begin{code}

@@ -257,13 +257,13 @@ ifaceDecls Nothing{-no iface handle-} _ = return ()
 
 ifaceDecls (Just if_hdl) (vals, tycons, classes, _)
   = let
 
 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
     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
 
 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
     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
        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 -- && ...
 
     -------
       = from_here -- && ...
 
     -------

diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs
index add0ada..237b334 100644 (file)
--- 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 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}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs
index d8e1bf6..01b0404 100644 (file)
--- 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.
 
 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
 
 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
            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}
 
              _ -> base
 \end{code}
 

diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs
index c6b04a2..dee0852 100644 (file)
--- a/ghc/compiler/prelude/PrelInfo.lhs
+++ b/ghc/compiler/prelude/PrelInfo.lhs
@@ -8,88 +8,11 @@
 
 module PrelInfo (
 
 
 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(..),
 
        -- 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
     ) where
 
 import Ubiq

@@ -231,7 +154,7 @@ prim_tycons
     , doublePrimTyCon
     , floatPrimTyCon
     , intPrimTyCon
     , doublePrimTyCon
     , floatPrimTyCon
     , intPrimTyCon

-    , mallocPtrPrimTyCon
+    , foreignObjPrimTyCon

     , mutableArrayPrimTyCon
     , mutableByteArrayPrimTyCon
     , synchVarPrimTyCon
     , mutableArrayPrimTyCon
     , mutableByteArrayPrimTyCon
     , synchVarPrimTyCon

@@ -272,7 +195,7 @@ data_tycons
     , intTyCon
     , integerTyCon
     , liftTyCon
     , intTyCon
     , integerTyCon
     , liftTyCon

-    , mallocPtrTyCon
+    , foreignObjTyCon

     , ratioTyCon
     , return2GMPsTyCon
     , returnIntAndGMPTyCon
     , ratioTyCon
     , return2GMPsTyCon
     , returnIntAndGMPTyCon

@@ -284,7 +207,7 @@ data_tycons
     , stateAndDoublePrimTyCon
     , stateAndFloatPrimTyCon
     , stateAndIntPrimTyCon
     , stateAndDoublePrimTyCon
     , stateAndFloatPrimTyCon
     , stateAndIntPrimTyCon

-    , stateAndMallocPtrPrimTyCon
+    , stateAndForeignObjPrimTyCon

     , stateAndMutableArrayPrimTyCon
     , stateAndMutableByteArrayPrimTyCon
     , stateAndSynchVarPrimTyCon
     , stateAndMutableArrayPrimTyCon
     , stateAndMutableByteArrayPrimTyCon
     , stateAndSynchVarPrimTyCon

@@ -338,15 +261,14 @@ parallel_ids
     else
         [ parId
         , forkId
     else
         [ parId
         , forkId

-#ifdef GRAN
-       , parLocalId
+       , copyableId
+       , noFollowId
+       , parAtAbsId
+       , parAtForNowId
+       , parAtId
+       , parAtRelId

        , parGlobalId
        , parGlobalId

-           -- Add later:
-           -- ,parAtId
-           -- ,parAtForNowId
-           -- ,copyableId
-           -- ,noFollowId
-#endif {-GRAN-}
+       , parLocalId

        ]
 
 pcIdWiredInInfo :: Id -> (FAST_STRING, RnName)
        ]
 
 pcIdWiredInInfo :: Id -> (FAST_STRING, RnName)

@@ -405,6 +327,7 @@ tysyn_keys
 class_keys
   = [ (s, (k, RnImplicitClass)) | (s,k) <-
     [ (SLIT("Eq"),             eqClassKey)             -- mentioned, derivable
 class_keys
   = [ (s, (k, RnImplicitClass)) | (s,k) <-
     [ (SLIT("Eq"),             eqClassKey)             -- mentioned, derivable

+    , (SLIT("Eval"),           evalClassKey)           -- mentioned

     , (SLIT("Ord"),            ordClassKey)            -- derivable
     , (SLIT("Num"),            numClassKey)            -- mentioned, numeric
     , (SLIT("Real"),           realClassKey)           -- numeric
     , (SLIT("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)
     , (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
     , (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 08bcc1a..02fd9f6 100644 (file)
--- 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 (
 #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_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
   ) 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")
 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_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")
 
 pRELUDE_TEXT   = SLIT("PreludeText")
 

+rATIO = SLIT("Ratio")
+

 fromPrelude :: FAST_STRING -> Bool
 fromPrelude s = (_SUBSTR_ s 0 6 == SLIT("Prelude"))
 \end{code}
 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 506b50e..0ce975e 100644 (file)
--- 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 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}
 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
 +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
 integerPlusOneId

-  = pcMiscPrelId integerPlusOneIdKey  pRELUDE_CORE SLIT("__integer1")  integerTy noIdInfo
+  = pcMiscPrelId integerPlusOneIdKey  pRELUDE SLIT("__integer1")  integerTy noIdInfo

 integerPlusTwoId
 integerPlusTwoId

-  = pcMiscPrelId integerPlusTwoIdKey  pRELUDE_CORE SLIT("__integer2")  integerTy noIdInfo
+  = pcMiscPrelId integerPlusTwoIdKey  pRELUDE SLIT("__integer2")  integerTy noIdInfo

 integerMinusOneId
 integerMinusOneId

-  = pcMiscPrelId integerMinusOneIdKey pRELUDE_CORE SLIT("__integerm1") integerTy noIdInfo
+  = pcMiscPrelId integerMinusOneIdKey pRELUDE SLIT("__integerm1") integerTy noIdInfo

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -274,50 +274,191 @@ forkId = pcMiscPrelId forkIdKey pRELUDE_BUILTIN SLIT("_fork_")
 
 \end{code}
 
 
 \end{code}
 

+GranSim ones:

 \begin{code}
 \begin{code}

-#ifdef GRAN
-

 parLocalId = pcMiscPrelId parLocalIdKey pRELUDE_BUILTIN SLIT("_parLocal_")
                  (mkSigmaTy [alphaTyVar, betaTyVar] []
 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
                  (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,
       = mkTemplateLocals [
        {-w-} intPrimTy,

+       {-g-} intPrimTy,
+       {-s-} intPrimTy,
+       {-p-} intPrimTy,

        {-x-} alphaTy,
        {-y-} betaTy,
        {-x-} alphaTy,
        {-y-} betaTy,

-       {-z-} betaTy
+       {-z-} intPrimTy

        ]
 
     parLocal_template
        ]
 
     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] []
 
 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
                  (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,
       = mkTemplateLocals [
        {-w-} intPrimTy,

+       {-g-} intPrimTy,
+       {-s-} intPrimTy,
+       {-p-} intPrimTy,

        {-x-} alphaTy,
        {-y-} betaTy,
        {-x-} alphaTy,
        {-y-} betaTy,

-       {-z-} betaTy
+       {-z-} intPrimTy

        ]
 
     parGlobal_template
        ]
 
     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}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -453,7 +594,7 @@ realWorldPrimId
 
 \begin{code}
 buildId
 
 \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)
        ((((noIdInfo
                {-LATER:`addInfo_UF` mkMagicUnfolding buildIdKey-})
                `addInfo` mkStrictnessInfo [WwStrict] Nothing)

@@ -498,7 +639,7 @@ mkBuild ty tv c n g expr
 
 \begin{code}
 augmentId
 
 \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)
        (((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 1874d83..d02f5e1 100644 (file)
--- a/ghc/compiler/prelude/PrimOp.lhs
+++ b/ghc/compiler/prelude/PrimOp.lhs
@@ -20,6 +20,7 @@ module PrimOp (
        primOpOkForSpeculation, primOpIsCheap,
        fragilePrimOp,
        HeapRequirement(..), primOpHeapReq,
        primOpOkForSpeculation, primOpIsCheap,
        fragilePrimOp,
        HeapRequirement(..), primOpHeapReq,

+       StackRequirement(..), primOpStackRequired,      

 
        -- export for the Native Code Generator
        primOpInfo, -- needed for primOpNameInfo
 
        -- 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 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}
 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.
     | 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
 
 
     | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp
 

@@ -153,6 +154,7 @@ data PrimOp
     | TakeMVarOp | PutMVarOp
     | ReadIVarOp | WriteIVarOp
 
     | TakeMVarOp | PutMVarOp
     | ReadIVarOp | WriteIVarOp
 

+    | MakeForeignObjOp -- foreign objects (malloc pointers or any old URL)

     | MakeStablePtrOp | DeRefStablePtrOp
 \end{code}
 
     | MakeStablePtrOp | DeRefStablePtrOp
 \end{code}
 

@@ -239,18 +241,19 @@ about using it this way?? ADR)
     | ParOp
     | ForkOp
 
     | ParOp
     | ForkOp
 

-    -- two for concurrency
+    -- three for concurrency

     | DelayOp
     | DelayOp

-    | WaitOp
+    | WaitReadOp
+    | WaitWriteOp

 
 

-#ifdef GRAN

     | ParGlobalOp      -- named global par
     | ParLocalOp       -- named local par
     | ParAtOp          -- specifies destination of local par
     | 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
     | 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
 \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 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"
 
 
 tagOf_PrimOp _ = panic# "tagOf_PrimOp: pattern-match"
 

@@ -591,19 +596,25 @@ allThePrimOps
        PutMVarOp,
        ReadIVarOp,
        WriteIVarOp,
        PutMVarOp,
        ReadIVarOp,
        WriteIVarOp,

+       MakeForeignObjOp,

        MakeStablePtrOp,
        DeRefStablePtrOp,
        ReallyUnsafePtrEqualityOp,
        ErrorIOPrimOp,
        MakeStablePtrOp,
        DeRefStablePtrOp,
        ReallyUnsafePtrEqualityOp,
        ErrorIOPrimOp,

-#ifdef GRAN

        ParGlobalOp,
        ParLocalOp,
        ParGlobalOp,
        ParLocalOp,

-#endif {-GRAN-}
+       ParAtOp,
+       ParAtAbsOp,
+       ParAtRelOp,
+       ParAtForNowOp,
+       CopyableOp,
+       NoFollowOp,

        SeqOp,
        ParOp,
        ForkOp,
        DelayOp,
        SeqOp,
        ParOp,
        ForkOp,
        DelayOp,

-       WaitOp
+       WaitReadOp,
+       WaitWriteOp

     ]
 \end{code}
 
     ]
 \end{code}
 

@@ -1117,16 +1128,56 @@ primOpInfo DelayOp
        [intPrimTy, mkStatePrimTy s]
        statePrimTyCon VoidRep [s]
 
        [intPrimTy, mkStatePrimTy s]
        statePrimTyCon VoidRep [s]
 

-primOpInfo WaitOp
+primOpInfo WaitReadOp

   = let {
        s = alphaTy; s_tv = alphaTyVar
     } in
   = let {
        s = alphaTy; s_tv = alphaTyVar
     } in

-    PrimResult SLIT("wait#") [s_tv]
+    PrimResult SLIT("waitRead#") [s_tv]

        [intPrimTy, mkStatePrimTy s]
        statePrimTyCon VoidRep [s]
 
        [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}
 
 \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}
 \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}
 
 %************************************************************************
 \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_)
                                          (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
 
 -- 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
 
 -- 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.
 \end{code}
 
 Primops which can trigger GC have to be called carefully.

@@ -1405,7 +1456,8 @@ primOpCanTriggerGC op
        TakeMVarOp  -> True
        ReadIVarOp  -> True
        DelayOp     -> True
        TakeMVarOp  -> True
        ReadIVarOp  -> True
        DelayOp     -> True

-       WaitOp      -> True
+       WaitReadOp  -> True
+       WaitWriteOp -> True

        _           ->
            case primOpHeapReq op of
                VariableHeapRequired -> 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
 
 primOpOkForSpeculation ForkOp          = False         -- Likewise
 primOpOkForSpeculation SeqOp           = False         -- Likewise
 

-#ifdef GRAN

 primOpOkForSpeculation ParGlobalOp     = False         -- Could be expensive!
 primOpOkForSpeculation ParLocalOp      = False         -- Could be expensive!
 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
 
 -- 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 ParOp = True
 fragilePrimOp ForkOp = True
 fragilePrimOp SeqOp = True

-fragilePrimOp MakeStablePtrOp = True
+fragilePrimOp MakeForeignObjOp = True  -- SOF
+fragilePrimOp MakeStablePtrOp  = True

 fragilePrimOp DeRefStablePtrOp = True  -- ??? JSM & ADR
 
 fragilePrimOp DeRefStablePtrOp = True  -- ??? JSM & ADR
 

-#ifdef GRAN

 fragilePrimOp ParGlobalOp = True
 fragilePrimOp ParLocalOp = True
 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}
 
 fragilePrimOp other = False
 \end{code}

@@ -1551,6 +1610,7 @@ primOpNeedsWrapper DoublePowerOp          = True
 primOpNeedsWrapper DoubleEncodeOp      = True
 primOpNeedsWrapper DoubleDecodeOp      = True
 
 primOpNeedsWrapper DoubleEncodeOp      = True
 primOpNeedsWrapper DoubleDecodeOp      = True
 

+primOpNeedsWrapper MakeForeignObjOp    = True

 primOpNeedsWrapper MakeStablePtrOp     = True
 primOpNeedsWrapper DeRefStablePtrOp    = True
 
 primOpNeedsWrapper MakeStablePtrOp     = True
 primOpNeedsWrapper DeRefStablePtrOp    = True
 

@@ -1559,7 +1619,8 @@ primOpNeedsWrapper PutMVarOp              = True
 primOpNeedsWrapper ReadIVarOp          = True
 
 primOpNeedsWrapper DelayOp             = True
 primOpNeedsWrapper ReadIVarOp          = True
 
 primOpNeedsWrapper DelayOp             = True

-primOpNeedsWrapper WaitOp              = True
+primOpNeedsWrapper WaitReadOp          = True
+primOpNeedsWrapper WaitWriteOp         = True

 
 primOpNeedsWrapper other_op            = False
 \end{code}
 
 primOpNeedsWrapper other_op            = False
 \end{code}

diff --git a/ghc/compiler/prelude/PrimRep.lhs b/ghc/compiler/prelude/PrimRep.lhs
index b4fbf55..1a6d45e 100644 (file)
--- a/ghc/compiler/prelude/PrimRep.lhs
+++ b/ghc/compiler/prelude/PrimRep.lhs
@@ -50,7 +50,7 @@ data PrimRep
   | FloatRep           --         floats
   | DoubleRep          --         doubles
 
   | 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]
 
                        -- 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 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
 
 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 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
 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).
 
 @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
 \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@.)
 (This typename is hardwired into @ppr_casm_results@ in
 @PprAbsC.lhs@.)

+-}

 
 \item
 
 \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
 
 \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 a64821d..28b4571 100644 (file)
--- 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.
 
 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}
 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}
 \end{code}

diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs
index 2efbb84..a4623c2 100644 (file)
--- a/ghc/compiler/prelude/TysWiredIn.lhs
+++ b/ghc/compiler/prelude/TysWiredIn.lhs
@@ -42,7 +42,7 @@ module TysWiredIn (
        liftTyCon,
        listTyCon,
        ltDataCon,
        liftTyCon,
        listTyCon,
        ltDataCon,

-       mallocPtrTyCon,
+       foreignObjTyCon,

        mkLiftTy,
        mkListTy,
        mkPrimIoTy,
        mkLiftTy,
        mkListTy,
        mkPrimIoTy,

@@ -68,7 +68,7 @@ module TysWiredIn (
        stateAndDoublePrimTyCon,
        stateAndFloatPrimTyCon,
        stateAndIntPrimTyCon,
        stateAndDoublePrimTyCon,
        stateAndFloatPrimTyCon,
        stateAndIntPrimTyCon,

-       stateAndMallocPtrPrimTyCon,
+       stateAndForeignObjPrimTyCon,

        stateAndMutableArrayPrimTyCon,
        stateAndMutableByteArrayPrimTyCon,
        stateAndPtrPrimTyCon,
        stateAndMutableArrayPrimTyCon,
        stateAndMutableByteArrayPrimTyCon,
        stateAndPtrPrimTyCon,

@@ -219,17 +219,17 @@ stablePtrTyCon
   where
     stablePtrDataCon
       = pcDataCon stablePtrDataConKey gLASGOW_MISC SLIT("_StablePtr")
   where
     stablePtrDataCon
       = pcDataCon stablePtrDataConKey gLASGOW_MISC SLIT("_StablePtr")

-           [alphaTyVar] [] [applyTyCon stablePtrPrimTyCon [alphaTy]] stablePtrTyCon nullSpecEnv
+           [alphaTyVar] [] [mkStablePtrPrimTy alphaTy] stablePtrTyCon nullSpecEnv

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

-mallocPtrTyCon
-  = pcDataTyCon mallocPtrTyConKey gLASGOW_MISC SLIT("_MallocPtr")
-       [] [mallocPtrDataCon]
+foreignObjTyCon
+  = pcDataTyCon foreignObjTyConKey gLASGOW_MISC SLIT("_ForeignObj")
+       [] [foreignObjDataCon]

   where
   where

-    mallocPtrDataCon
-      = pcDataCon mallocPtrDataConKey gLASGOW_MISC SLIT("_MallocPtr")
-           [] [] [applyTyCon mallocPtrPrimTyCon []] mallocPtrTyCon nullSpecEnv
+    foreignObjDataCon
+      = pcDataCon foreignObjDataConKey gLASGOW_MISC SLIT("_ForeignObj")
+           [] [] [foreignObjPrimTy] foreignObjTyCon nullSpecEnv

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -330,14 +330,14 @@ stateAndStablePtrPrimDataCon
                [mkStatePrimTy alphaTy, applyTyCon stablePtrPrimTyCon [betaTy]]
                stateAndStablePtrPrimTyCon nullSpecEnv
 
                [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] []
                [alphaTyVar] []

-               [mkStatePrimTy alphaTy, applyTyCon mallocPtrPrimTyCon []]
-               stateAndMallocPtrPrimTyCon nullSpecEnv
+               [mkStatePrimTy alphaTy, applyTyCon foreignObjPrimTyCon []]
+               stateAndForeignObjPrimTyCon nullSpecEnv

 
 stateAndFloatPrimTyCon
   = pcDataTyCon stateAndFloatPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndFloat#")
 
 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)),
        (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)),
        (floatPrimTyCon, (stateAndFloatPrimDataCon, stateAndFloatPrimTyCon, 0)),
        (doublePrimTyCon, (stateAndDoublePrimDataCon, stateAndDoublePrimTyCon, 0)),
        (arrayPrimTyCon, (stateAndArrayPrimDataCon, stateAndArrayPrimTyCon, 0)),

@@ -531,10 +531,10 @@ primitive counterpart.
 \begin{code}
 boolTy = mkTyConTy boolTyCon
 
 \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}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -660,15 +660,15 @@ rationalTy :: GenType t u
 mkRatioTy ty = applyTyCon ratioTyCon [ty]
 rationalTy   = mkRatioTy integerTy
 
 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
                [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}
       mkBoxedTypeKind
       0        [] rationalTy -- == mkRatioTy integerTy
 \end{code}

@@ -725,7 +725,7 @@ stringTy = mkListTy charTy
 
 stringTyCon
  = mkSynTyCon
 
 stringTyCon
  = mkSynTyCon

-     (mkBuiltinName stringTyConKey pRELUDE_CORE SLIT("String"))
+     (mkBuiltinName stringTyConKey pRELUDE SLIT("String"))

      mkBoxedTypeKind
      0 [] stringTy
 \end{code}
      mkBoxedTypeKind
      0 [] stringTy
 \end{code}

diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs
index b5beb1f..2740a5b 100644 (file)
--- 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...
 
   -- 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"
 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 d87feb2..bd7dc9d 100644 (file)
--- 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  :: { 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
 
 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 743c83d..47ed0fd 100644 (file)
--- 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 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
 
 --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 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 )
 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 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
 
        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
            | (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
     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 5107304..c80f351 100644 (file)
--- a/ghc/compiler/rename/RnHsSyn.lhs
+++ b/ghc/compiler/rename/RnHsSyn.lhs
@@ -92,12 +92,6 @@ isRnImplicit _                        = False
 isRnUnbound (RnUnbound _) = True
 isRnUnbound _            = 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
 
 -- 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
     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"
 
                                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 9b7bf0f..eaaa862 100644 (file)
--- 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)
     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}
 
 
 \end{code}
 
 

diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 10ea30a..ff9736a 100644 (file)
--- 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,
 import RnMonad
 import RnIfaces                ( IfaceCache(..), cachedIface, cachedDecl )
 import RnUtils         ( RnEnv(..), emptyRnEnv, extendGlobalRnEnv,

-                         lubExportFlag, qualNameErr, dupNamesErr, negateNameWarn
+                         lubExportFlag, qualNameErr, dupNamesErr

                        )
 import ParseUtils      ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst )
 
                        )
 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
 
        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}
     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
       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 
                           (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
     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)
          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)
                                   (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 ->
             _ -> panic "importing builtin names (1)"
 
          Nothing ->

diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 6050153..043d0eb 100644 (file)
--- 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 
                          nameImportFlag, RdrName, pprNonSym )
 import Outputable      -- ToDo:rm
 import PprStyle        -- ToDo:rm 

-import PrelInfo                ( consDataCon )

 import Pretty
 import SrcLoc          ( SrcLoc )
 import Unique          ( Unique )
 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 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.
 \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 
 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
         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
 
        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
        -- 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
 
        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
        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
                     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
 
 
     returnRn exp_fn
 
 

@@ -169,20 +191,20 @@ rnIE mods (IEVar name)
     checkIEVar rn      `thenRn` \ exps ->
     returnRn (Nothing, exps)
   where
     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 ->
     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
 
 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 ->
 
 rnIE mods (IEThingAll name)
   = lookupTyConOrClass name    `thenRn` \ rn ->

@@ -190,13 +212,14 @@ rnIE mods (IEThingAll name)
     checkImportAll rn           `thenRn_`
     returnRn (Nothing, exps)
   where
     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 ->
     checkIEAll rn@(RnSyn n)           = getSrcLocRn `thenRn` \ src_loc ->

-                                       warnAndContinueRn (unitBag (n, ExportAbs))
+                                       warnAndContinueRn (unitBag (n, ExportAbs), emptyBag)

                                            (synAllExportErr False{-warning-} rn src_loc)
                                            (synAllExportErr False{-warning-} rn src_loc)

-    checkIEAll rn                     = returnRn emptyBag
+    checkIEAll rn                     = returnRn (emptyBag, emptyBag)

 
     exp_all n = (n, ExportAll)
 
 
     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
   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
        | 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 ->
        | 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
     checkIEWith rn rns

-       = returnRn emptyBag
+       = returnRn (emptyBag, emptyBag)

 
     exp_all n = (n, ExportAll)
 
 
     exp_all n = (n, ExportAll)
 

@@ -231,14 +256,14 @@ rnIE mods (IEThingWith name names)
 
     rnWithErr str rn has rns
       = getSrcLocRn `thenRn` \ src_loc ->
 
     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
 
 rnIE mods (IEModuleContents mod)
   | isIn "rnIE:IEModule" mod mods

-  = returnRn (Just mod, emptyBag)
+  = returnRn (Just mod, (emptyBag, emptyBag))

   | otherwise
   = getSrcLocRn `thenRn` \ src_loc ->
   | otherwise
   = getSrcLocRn `thenRn` \ src_loc ->

-    failButContinueRn (Nothing,emptyBag) (badModExportErr mod src_loc)
+    failButContinueRn (Nothing, (emptyBag, emptyBag)) (badModExportErr mod src_loc)

 
 
 checkImportAll rn 
 
 
 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)
     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
                                    `thenRn_`
        returnRn clas_name
       where

diff --git a/ghc/compiler/simplCore/ConFold.lhs b/ghc/compiler/simplCore/ConFold.lhs
index c508cf5..ef787b2 100644 (file)
--- 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 Id              ( idType )
 import Literal         ( mkMachInt, mkMachWord, Literal(..) )
 import MagicUFs                ( MagicUnfoldingFun )

-import PrelInfo                ( trueDataCon, falseDataCon )

 import PrimOp          ( PrimOp(..) )
 import SimplEnv
 import SimplMonad
 import PrimOp          ( PrimOp(..) )
 import SimplEnv
 import SimplMonad

+import TysWiredIn      ( trueDataCon, falseDataCon )

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

diff --git a/ghc/compiler/simplCore/MagicUFs.lhs b/ghc/compiler/simplCore/MagicUFs.lhs
index ad986d7..32318fe 100644 (file)
--- 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 IdLoop          -- paranoia checking
 
 import CoreSyn

-import PrelInfo                ( mkListTy )

 import SimplEnv                ( SimplEnv )
 import SimplMonad      ( SmplM(..), SimplCount )
 import Type            ( mkFunTys )
 import SimplEnv                ( SimplEnv )
 import SimplMonad      ( SmplM(..), SimplCount )
 import Type            ( mkFunTys )

+import TysWiredIn      ( mkListTy )

 import Unique          ( Unique{-instances-} )
 import Util            ( assoc, zipWith3Equal, nOfThem, panic )
 \end{code}
 import 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 3ec493a..4054a14 100644 (file)
--- 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 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 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 )
 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 ade1cfa..5406e3d 100644 (file)
--- 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
        (_, 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}
 
 
 \end{code}
 
 

diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index ba1cc4e..ac24d65 100644 (file)
--- 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 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 PrimOp          ( primOpIsCheap )
 import SimplEnv
 import SimplMonad
 import Type            ( eqTy, isPrimType, maybeAppDataTyConExpandingDicts, getTyVar_maybe )

+import TysWiredIn      ( realWorldStateTy )

 import TyVar           ( GenTyVar{-instance Eq-} )
 import Util            ( isIn, panic )
 
 import TyVar           ( GenTyVar{-instance Eq-} )
 import Util            ( isIn, panic )
 

diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 9ef9b2a..27424dd 100644 (file)
--- 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 Name            ( isLocallyDefined )
 import PprStyle                ( PprStyle(..) )
 import PprType         ( GenType{-instance Outputable-} )

-import PrelInfo                ( realWorldStateTy )

 import Pretty          ( ppAbove )
 import PrimOp          ( primOpOkForSpeculation, PrimOp(..) )
 import SimplCase       ( simplCase, bindLargeRhs )
 import 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 Type            ( mkTyVarTy, mkTyVarTys, mkAppTy,
                          splitFunTy, getFunTy_maybe, eqTy
                        )

+import TysWiredIn      ( realWorldStateTy )

 import Util            ( isSingleton, zipEqual, panic, pprPanic, assertPanic )
 \end{code}
 
 import Util            ( isSingleton, zipEqual, panic, pprPanic, assertPanic )
 \end{code}
 

diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index 4a87887..2b69f39 100644 (file)
--- 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-}
                        )
                          GenType{-instance Outputable-}, GenTyVar{-ditto-},
                          TyCon{-ditto-}
                        )

-import PrelInfo                ( liftDataCon )

 import Pretty          ( ppHang, ppCat, ppStr, ppAboves, ppBesides,
                          ppInt, ppSP, ppInterleave, ppNil, Pretty(..)
                        )
 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-}
                        )
                          nullTyVarEnv, growTyVarEnvList, TyVarEnv(..),
                          GenTyVar{-instance Eq-}
                        )

+import TysWiredIn      ( liftDataCon )

 import Unique          ( Unique{-instance Eq-} )
 import UniqSet         ( mkUniqSet, unionUniqSets, uniqSetToList )
 import UniqSupply      ( splitUniqSupply, getUniques, getUnique )
 import 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 3ed0d38..edd2d81 100644 (file)
--- 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 Literal         ( mkMachInt, Literal(..) )
 import Name            ( isExported )

-import PrelInfo                ( unpackCStringId, unpackCString2Id, stringTy,
-                         integerTy, rationalTy, ratioDataCon,
+import PrelVals                ( unpackCStringId, unpackCString2Id,

                          integerZeroId, integerPlusOneId,
                          integerPlusTwoId, integerMinusOneId
                        )
                          integerZeroId, integerPlusOneId,
                          integerPlusTwoId, integerMinusOneId
                        )

@@ -38,6 +37,7 @@ import PrimOp         ( PrimOp(..) )
 import SpecUtils       ( mkSpecialisedCon )
 import SrcLoc          ( mkUnknownSrcLoc )
 import Type            ( getAppDataTyConExpandingDicts )
 import SpecUtils       ( mkSpecialisedCon )
 import SrcLoc          ( mkUnknownSrcLoc )
 import Type            ( getAppDataTyConExpandingDicts )

+import TysWiredIn      ( stringTy, integerTy, rationalTy, ratioDataCon )

 import UniqSupply      -- all of it, really
 import Util            ( panic )
 
 import UniqSupply      -- all of it, really
 import Util            ( panic )
 

@@ -426,17 +426,21 @@ coreExprToStg env expr@(Lam _ _)
   = let
        (_,_, binders, body) = collectBinders expr
     in
   = 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}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs
index cc26fab..04ba2f0 100644 (file)
--- 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 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
 import Pretty          ( ppStr )
 import PrimOp          ( PrimOp(..) )
 import SaLib

@@ -40,6 +37,9 @@ import TyCon          ( maybeTyConSingleCon, isEnumerationTyCon,
                          TyCon{-instance Eq-}
                        )
 import Type            ( maybeAppDataTyConExpandingDicts, isPrimType )
                          TyCon{-instance Eq-}
                        )
 import Type            ( maybeAppDataTyConExpandingDicts, isPrimType )

+import TysWiredIn      ( intTyCon, integerTyCon, doubleTyCon,
+                         floatTyCon, wordTyCon, addrTyCon
+                       )

 import Util            ( isIn, isn'tIn, nOfThem, zipWithEqual,
                          pprTrace, panic, pprPanic, assertPanic
                        )
 import 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 ceea5e7..eeaafc9 100644 (file)
--- 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 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
 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 b4fc7f2..052d796 100644 (file)
--- 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)
 \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)
   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)
   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}
 \end{code}
 
 \begin{code}

diff --git a/ghc/compiler/typecheck/TcDefaults.lhs b/ghc/compiler/typecheck/TcDefaults.lhs
index d714ddd..964847d 100644 (file)
--- 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 TcMonoType      ( tcMonoType )
 import TcSimplify      ( tcSimplifyCheckThetas )
 

-import PrelInfo                ( intTy, doubleTy, unitTy )
+import TysWiredIn      ( intTy, doubleTy, unitTy )

 import Unique          ( numClassKey )
 import Util
 \end{code}
 import Unique          ( numClassKey )
 import Util
 \end{code}

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index fa2ff93..21e864e 100644 (file)
--- 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 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,
 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 )
                          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,
 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
 --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)
              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) ->  
     tcSetErrCtxt (stmtCtxt stmt)       (
        tcPat pat                       `thenTc`    \ (pat', pat_lie, pat_ty) ->  

+

        tcExpr exp                      `thenTc`    \ (exp', exp_lie, exp_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_`
        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 44bdfce..edc2869 100644 (file)
--- 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 TcType          ( TcType(..) ) 
 import Unify           ( unifyTauTy )
 

-import PrelInfo                ( boolTy )
+import TysWiredIn      ( boolTy )

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index cf7eb32..8f19aef 100644 (file)
--- 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 Name          ( Name(..) )
 import Outputable
 import PrimOp

-import PrelInfo
+--import PrelInfo

 import Pretty
 import SrcLoc          ( mkGeneratedSrcLoc )
 import TyCon           ( TyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon )
 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")
 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_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
 
 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 9f3506b..006777a 100644 (file)
--- 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 Id              ( GenId, isDataCon, isMethodSelId, idType, IdEnv(..), nullIdEnv )
 import Maybes          ( catMaybes )
 import Name            ( isExported, isLocallyDefined )

-import PrelInfo                ( unitTy, mkPrimIoTy )

 import Pretty
 import RnUtils         ( RnEnv(..) )
 import Pretty
 import RnUtils         ( RnEnv(..) )

-import TyCon           ( TyCon )
+import TyCon           ( isDataTyCon, TyCon )

 import Type            ( mkSynTy )
 import Type            ( mkSynTy )

+import TysWiredIn      ( unitTy, mkPrimIoTy )

 import TyVar           ( TyVarEnv(..), nullTyVarEnv )
 import Unify           ( unifyTauTy )
 import UniqFM          ( lookupUFM_Directly, lookupWithDefaultUFM_Directly,
 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 ->
            --   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)
 
 
        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
 
        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    
        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 34b628d..eee6f12 100644 (file)
--- 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 )
                          mkSigmaTy
                        )
 import TyVar           ( GenTyVar, TyVar(..), mkTyVar )

-import PrelInfo                ( mkListTy, mkTupleTy )

 import Type            ( mkDictTy )
 import Class           ( cCallishClassKeys )
 import TyCon           ( TyCon, Arity(..) )
 import Type            ( mkDictTy )
 import Class           ( cCallishClassKeys )
 import TyCon           ( TyCon, Arity(..) )

+import TysWiredIn      ( mkListTy, mkTupleTy )

 import Unique          ( Unique )
 import PprStyle
 import Pretty
 import Unique          ( Unique )
 import PprStyle
 import Pretty

diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index bb9f71e..0c8470c 100644 (file)
--- 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 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,
 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 )
                          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}
 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)
 
 \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)
     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 8e28da6..5ce5ca7 100644 (file)
--- 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 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
 import Type
 import CmdLineOpts
 import CostCentre

diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs
index d406196..b983664 100644 (file)
--- 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 )
                          mkTupleTyConName, mkFunTyConName
                        )
 import Unique          ( Unique, funTyConKey, mkTupleTyConUnique )

-import PrelInfo                ( intDataCon, charDataCon )

 import Pretty          ( Pretty(..), PrettyRep )
 import Pretty          ( Pretty(..), PrettyRep )

-import PprStyle                ( PprStyle )

 import SrcLoc          ( SrcLoc, mkBuiltinSrcLoc )
 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}
 \end{code}
 
 \begin{code}

@@ -230,6 +231,9 @@ tyConDataCons other                           = []
 
 tyConFamilySize (DataTyCon _ _ _ _ _ data_cons _ _) = length data_cons
 tyConFamilySize (TupleTyCon _ _ _)                 = 1
 
 tyConFamilySize (DataTyCon _ _ _ _ _ data_cons _ _) = length data_cons
 tyConFamilySize (TupleTyCon _ _ _)                 = 1

+#ifdef DEBUG
+tyConFamilySize other = pprPanic "tyConFamilySize:" (pprTyCon PprDebug other)
+#endif

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

diff --git a/ghc/compiler/types/TyVar.lhs b/ghc/compiler/types/TyVar.lhs
index 88f1e85..980f1dd 100644 (file)
--- 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
 
 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}
 \end{code}

diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index e777415..aff733f 100644 (file)
--- 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
 
 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 )
 -- 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"
                            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}
 \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) =
 (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
 
 (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) =
   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
 
   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 7d6c448..e5c4eb1 100644 (file)
--- a/ghc/compiler/types/Usage.lhs
+++ b/ghc/compiler/types/Usage.lhs
@@ -14,11 +14,14 @@ module Usage (
        eqUVar, eqUsage
 ) where
 
        eqUVar, eqUsage
 ) where
 

-import Ubiq
+import Ubiq{-uitous-}
+

 import Pretty  ( Pretty(..), PrettyRep, ppPStr, ppBeside )
 import UniqFM  ( emptyUFM, listToUFM, addToUFM, lookupUFM,
 import Pretty  ( Pretty(..), PrettyRep, ppPStr, ppBeside )
 import UniqFM  ( emptyUFM, listToUFM, addToUFM, lookupUFM,

-                 plusUFM, sizeUFM, UniqFM )
+                 plusUFM, sizeUFM, UniqFM
+               )

 import Unique  ( Unique{-instances-} )
 import Unique  ( Unique{-instances-} )

+import Util    ( panic )

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

@@ -33,7 +36,7 @@ type Usage = GenUsage UVar
 usageOmega = UsageOmega
 
 duffUsage :: 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}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

diff --git a/ghc/compiler/utils/Maybes.lhs b/ghc/compiler/utils/Maybes.lhs
index 3a29c7f..1c6a863 100644 (file)
--- a/ghc/compiler/utils/Maybes.lhs
+++ b/ghc/compiler/utils/Maybes.lhs
@@ -52,14 +52,6 @@ CHK_Ubiq() -- debugging consistency check
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-#if __HASKELL1__ < 3
-data Maybe a
-  = Nothing
-  | Just a
-#endif
-\end{code}
-
-\begin{code}

 maybeToBool :: Maybe a -> Bool
 maybeToBool Nothing  = False
 maybeToBool (Just x) = True
 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}
 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
 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 b56e4cc..c026524 100644 (file)
--- 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,
        IF_NOT_GHC(forall COMMA exists COMMA)
        zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
         zipLazy,

-       mapAndUnzip,
+       mapAndUnzip, mapAndUnzip3,

        nOfThem, lengthExceeds, isSingleton,
        startsWith, endsWith,
 #if defined(COMPILING_GHC)
        nOfThem, lengthExceeds, isSingleton,
        startsWith, endsWith,
 #if defined(COMPILING_GHC)

@@ -67,11 +67,8 @@ module Util (
        -- comparisons
        Ord3(..), thenCmp, cmpList,
        IF_NOT_GHC(cmpString COMMA)
        -- comparisons
        Ord3(..), thenCmp, cmpList,
        IF_NOT_GHC(cmpString COMMA)

-#ifdef USE_FAST_STRINGS

        cmpPString,
        cmpPString,

-#else
-       substr,
-#endif
+

        -- pairs
        IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA)
        IF_NOT_GHC(applyToSnd COMMA foldPair COMMA)
        -- 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 -}
 
        , 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)
     ) where
 
 #if defined(COMPILING_GHC)

@@ -100,9 +88,6 @@ CHK_Ubiq() -- debugging consistency check
 
 import Pretty
 #endif
 
 import Pretty
 #endif

-#if __HASKELL1__ < 3
-import Maybes          ( Maybe(..) )
-#endif

 
 infixr 9 `thenCmp`
 \end{code}
 
 infixr 9 `thenCmp`
 \end{code}

@@ -195,6 +180,16 @@ mapAndUnzip f (x:xs)
        (rs1, rs2) = mapAndUnzip f xs
     in
     (r1:rs1, r2:rs2)
        (rs1, rs2) = mapAndUnzip f xs
     in
     (r1:rs1, r2:rs2)

+
+mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
+
+mapAndUnzip3 f [] = ([],[],[])
+mapAndUnzip3 f (x:xs)
+  = let
+       (r1,  r2,  r3)  = f x
+       (rs1, rs2, rs3) = mapAndUnzip3 f xs
+    in
+    (r1:rs1, r2:rs2, r3:rs3)

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

@@ -722,22 +717,10 @@ cmpString _ _ = panic# "cmpString"
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

-#ifdef USE_FAST_STRINGS

 cmpPString :: FAST_STRING -> FAST_STRING -> TAG_
 
 cmpPString x y
   = case (_tagCmp x y) of { _LT -> LT_ ; _EQ -> EQ_ ; _GT -> GT_ }
 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}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************