[project @ 1996-07-19 18:36:04 by partain]

[ghc-hetmet.git] / ghc / compiler / prelude / PrelVals.lhs

diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs
index 30f24db..37d6f6b 100644 (file)
--- a/ghc/compiler/prelude/PrelVals.lhs
+++ b/ghc/compiler/prelude/PrelVals.lhs
@@ -9,8 +9,8 @@
 module PrelVals where
 
 IMP_Ubiq()
 module PrelVals where
 
 IMP_Ubiq()

-IMPORT_DELOOPER(IdLoop)                ( UnfoldingGuidance(..) )
-import Id              ( Id(..), GenId, mkImported, mkUserId, mkTemplateLocals )
+IMPORT_DELOOPER(IdLoop)                ( UnfoldingGuidance(..), nullSpecEnv, SpecEnv )
+import Id              ( SYN_IE(Id), GenId, mkImported, mkUserId, mkTemplateLocals )

 IMPORT_DELOOPER(PrelLoop)
 
 -- friends:
 IMPORT_DELOOPER(PrelLoop)
 
 -- friends:

@@ -19,45 +19,34 @@ import TysPrim
 import TysWiredIn
 
 -- others:
 import TysWiredIn
 
 -- others:

-import CmdLineOpts     ( maybe_CompilingPrelude )
+import CmdLineOpts     ( maybe_CompilingGhcInternals )

 import CoreSyn         -- quite a bit
 import IdInfo          -- quite a bit
 import Literal         ( mkMachInt )
 import CoreSyn         -- quite a bit
 import IdInfo          -- quite a bit
 import Literal         ( mkMachInt )

+import Name            ( ExportFlag(..) )

 import PragmaInfo
 import PrimOp          ( PrimOp(..) )
 import PragmaInfo
 import PrimOp          ( PrimOp(..) )

-import SpecEnv         ( SpecEnv(..), nullSpecEnv )

 import Type            ( mkTyVarTy )
 import TyVar           ( openAlphaTyVar, alphaTyVar, betaTyVar, gammaTyVar )
 import Unique          -- lots of *Keys
 import Util            ( panic )
 \end{code}
 
 import Type            ( mkTyVarTy )
 import TyVar           ( openAlphaTyVar, alphaTyVar, betaTyVar, gammaTyVar )
 import Unique          -- lots of *Keys
 import Util            ( panic )
 \end{code}
 

-
-
-

 \begin{code}
 -- only used herein:
 pcMiscPrelId :: Unique{-IdKey-} -> FAST_STRING -> FAST_STRING -> Type -> IdInfo -> Id
 
 pcMiscPrelId key m n ty info
   = let
 \begin{code}
 -- only used herein:
 pcMiscPrelId :: Unique{-IdKey-} -> FAST_STRING -> FAST_STRING -> Type -> IdInfo -> Id
 
 pcMiscPrelId key m n ty info
   = let

-       name = mkWiredInName key (OrigName m n)
+       name = mkWiredInName key (OrigName m n) ExportAll

        imp  = mkImported name ty info -- the usual case...
     in
     imp
     -- We lie and say the thing is imported; otherwise, we get into
     -- a mess with dependency analysis; e.g., core2stg may heave in
        imp  = mkImported name ty info -- the usual case...
     in
     imp
     -- We lie and say the thing is imported; otherwise, we get into
     -- a mess with dependency analysis; e.g., core2stg may heave in

-    -- random calls to GHCbase.unpackPS.  If GHCbase is the module
+    -- random calls to GHCbase.unpackPS__.  If GHCbase is the module

     -- being compiled, then it's just a matter of luck if the definition
     -- will be in "the right place" to be in scope.
     -- being compiled, then it's just a matter of luck if the definition
     -- will be in "the right place" to be in scope.

-{- ???
-    case maybe_CompilingPrelude of
-      Nothing -> imp
-      Just modname ->
-       if modname == _UNPK_ m -- we are compiling the module where this thing is defined...
-       then mkUserId name ty NoPragmaInfo
-       else imp
--}

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

@@ -91,7 +80,7 @@ eRROR_ID
   = pc_bottoming_Id errorIdKey pRELUDE SLIT("error") errorTy
 
 generic_ERROR_ID u n
   = pc_bottoming_Id errorIdKey pRELUDE SLIT("error") errorTy
 
 generic_ERROR_ID u n

-  = pc_bottoming_Id u gHC__ n errorTy
+  = pc_bottoming_Id u SLIT("GHCerr") n errorTy

 
 pAT_ERROR_ID
   = generic_ERROR_ID patErrorIdKey SLIT("patError")
 
 pAT_ERROR_ID
   = generic_ERROR_ID patErrorIdKey SLIT("patError")

@@ -109,24 +98,23 @@ nO_EXPLICIT_METHOD_ERROR_ID
   = generic_ERROR_ID nonExplicitMethodErrorIdKey SLIT("noExplicitMethodError")
 
 aBSENT_ERROR_ID
   = generic_ERROR_ID nonExplicitMethodErrorIdKey SLIT("noExplicitMethodError")
 
 aBSENT_ERROR_ID

-  = pc_bottoming_Id absentErrorIdKey gHC__ SLIT("absentErr")
-       (mkSigmaTy [alphaTyVar] [] alphaTy)
+  = pc_bottoming_Id absentErrorIdKey SLIT("GHCerr") SLIT("absentErr")
+       (mkSigmaTy [openAlphaTyVar] [] openAlphaTy)

 
 pAR_ERROR_ID
 
 pAR_ERROR_ID

-  = pcMiscPrelId parErrorIdKey gHC__ SLIT("parError")
-    (mkSigmaTy [alphaTyVar] [] alphaTy) noIdInfo
+  = pcMiscPrelId parErrorIdKey SLIT("GHCerr") SLIT("parError")
+    (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noIdInfo
+
+openAlphaTy = mkTyVarTy openAlphaTyVar

 
 errorTy  :: Type
 
 errorTy  :: Type

-errorTy  = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] (mkTyVarTy openAlphaTyVar))
+errorTy  = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)

 \end{code}
 
 \end{code}
 

-We want \tr{_trace} (NB: name not in user namespace) to be wired in
+We want \tr{GHCbase.trace} to be wired in

 because we don't want the strictness analyser to get ahold of it,
 decide that the second argument is strict, evaluate that first (!!),
 because we don't want the strictness analyser to get ahold of it,
 decide that the second argument is strict, evaluate that first (!!),

-and make a jolly old mess.  Having \tr{_trace} wired in also helps when
-attempting to re-export it---because it's in \tr{PreludeBuiltin}, it
-won't get an \tr{import} declaration in the interface file, so the
-importing-subsequently module needs to know it's magic.
+and make a jolly old mess.

 \begin{code}
 tRACE_ID
   = pcMiscPrelId traceIdKey gHC__ SLIT("trace") traceTy
 \begin{code}
 tRACE_ID
   = pcMiscPrelId traceIdKey gHC__ SLIT("trace") traceTy

@@ -143,33 +131,33 @@ tRACE_ID
 
 \begin{code}
 packStringForCId
 
 \begin{code}
 packStringForCId

-  = pcMiscPrelId packCStringIdKey{-ToDo:rename-} gHC__ SLIT("packStringForC")
+  = pcMiscPrelId packCStringIdKey{-ToDo:rename-} gHC__ SLIT("packStringForC__")

        (mkFunTys [stringTy] byteArrayPrimTy) noIdInfo
 
 --------------------------------------------------------------------
 
 unpackCStringId
        (mkFunTys [stringTy] byteArrayPrimTy) noIdInfo
 
 --------------------------------------------------------------------
 
 unpackCStringId

-  = pcMiscPrelId unpackCStringIdKey gHC__ SLIT("unpackPS")
+  = pcMiscPrelId unpackCStringIdKey gHC__ SLIT("unpackPS__")

                 (mkFunTys [addrPrimTy{-a char *-}] stringTy) noIdInfo
 -- Andy says:
 --     (FunTy addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` mkArityInfo 1)
 -- but I don't like wired-in IdInfos (WDP)
 
 unpackCString2Id -- for cases when a string has a NUL in it
                 (mkFunTys [addrPrimTy{-a char *-}] stringTy) noIdInfo
 -- Andy says:
 --     (FunTy addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` mkArityInfo 1)
 -- but I don't like wired-in IdInfos (WDP)
 
 unpackCString2Id -- for cases when a string has a NUL in it

-  = pcMiscPrelId unpackCString2IdKey gHC__ SLIT("unpackPS2")
+  = pcMiscPrelId unpackCString2IdKey gHC__ SLIT("unpackPS2__")

                 (mkFunTys [addrPrimTy{-a char *-}, intPrimTy{-length-}] stringTy)
                 noIdInfo
 
 --------------------------------------------------------------------
 unpackCStringAppendId
                 (mkFunTys [addrPrimTy{-a char *-}, intPrimTy{-length-}] stringTy)
                 noIdInfo
 
 --------------------------------------------------------------------
 unpackCStringAppendId

-  = pcMiscPrelId unpackCStringAppendIdKey gHC__ SLIT("unpackAppendPS")
+  = pcMiscPrelId unpackCStringAppendIdKey gHC__ SLIT("unpackAppendPS__")

                (mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy)
                ((noIdInfo
                 {-LATER:`addInfo_UF` mkMagicUnfolding unpackCStringAppendIdKey-})
                 `addInfo` mkArityInfo 2)
 
 unpackCStringFoldrId
                (mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy)
                ((noIdInfo
                 {-LATER:`addInfo_UF` mkMagicUnfolding unpackCStringAppendIdKey-})
                 `addInfo` mkArityInfo 2)
 
 unpackCStringFoldrId

-  = pcMiscPrelId unpackCStringFoldrIdKey gHC__ SLIT("unpackFoldrPS")
+  = pcMiscPrelId unpackCStringFoldrIdKey gHC__ SLIT("unpackFoldrPS__")

                (mkSigmaTy [alphaTyVar] []
                (mkFunTys [addrPrimTy{-a "char *" pointer-},
                           mkFunTys [charTy, alphaTy] alphaTy,
                (mkSigmaTy [alphaTyVar] []
                (mkFunTys [addrPrimTy{-a "char *" pointer-},
                           mkFunTys [charTy, alphaTy] alphaTy,

@@ -200,6 +188,7 @@ integerMinusOneId
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

+{- OUT:

 --------------------------------------------------------------------
 -- seqId :: "seq", used w/ GRIP, etc., is really quite similar to
 -- dangerousEval
 --------------------------------------------------------------------
 -- seqId :: "seq", used w/ GRIP, etc., is really quite similar to
 -- dangerousEval

@@ -291,11 +280,12 @@ forkId = pcMiscPrelId forkIdKey gHC__ SLIT("fork")
                  PrimAlts
                    [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
                    (BindDefault z (Var y))))
                  PrimAlts
                    [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
                    (BindDefault z (Var y))))

-
+-}

 \end{code}
 
 GranSim ones:
 \begin{code}
 \end{code}
 
 GranSim ones:
 \begin{code}

+{- OUT:

 parLocalId = pcMiscPrelId parLocalIdKey gHC__ SLIT("parLocal")
                  (mkSigmaTy [alphaTyVar, betaTyVar] []
                    (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
 parLocalId = pcMiscPrelId parLocalIdKey gHC__ SLIT("parLocal")
                  (mkSigmaTy [alphaTyVar, betaTyVar] []
                    (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))

@@ -368,7 +358,7 @@ parAtId = pcMiscPrelId parAtIdKey gHC__ SLIT("parAt")
       = 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
       = 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])]
+                   [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [gammaTy])]

                    (BindDefault z (Var y))))
 
 parAtAbsId = pcMiscPrelId parAtAbsIdKey gHC__ SLIT("parAtAbs")
                    (BindDefault z (Var y))))
 
 parAtAbsId = pcMiscPrelId parAtAbsIdKey gHC__ SLIT("parAtAbs")

@@ -444,7 +434,7 @@ parAtForNowId = pcMiscPrelId parAtForNowIdKey gHC__ SLIT("parAtForNow")
       = 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
       = 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])]
+                   [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [gammaTy])]

                    (BindDefault z (Var y))))
 
 -- copyable and noFollow are currently merely hooks: they are translated into
                    (BindDefault z (Var y))))
 
 -- copyable and noFollow are currently merely hooks: they are translated into

@@ -479,41 +469,25 @@ noFollowId = pcMiscPrelId noFollowIdKey gHC__ SLIT("noFollow")
 
     noFollow_template
       = mkLam [alphaTyVar] [x] ( Prim NoFollowOp [TyArg alphaTy, VarArg x] )
 
     noFollow_template
       = mkLam [alphaTyVar] [x] ( Prim NoFollowOp [TyArg alphaTy, VarArg x] )

+-}

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

-\subsection[PrelVals-deriving]{Values known about mainly for doing derived instance decls}
-%*                                                                     *
-%************************************************************************
-
-map            :: (a -> b) -> [a] -> [b]
-       -- this is up in the here-because-of-unfolding list
-
---??showChar   :: Char -> ShowS
-showSpace      :: ShowS        -- non-std: == "showChar ' '"
-showString     :: String -> ShowS
-showParen      :: Bool -> ShowS -> ShowS
-
-(++)           :: [a] -> [a] -> [a]
-readParen      :: Bool -> ReadS a -> ReadS a
-lex            :: ReadS String
-
-%************************************************************************
-%*                                                                     *
-\subsection[PrelVals-runST]{@_runST@: Magic start-state-transformer function}
+\subsection[PrelVals-runST]{@runST@: Magic start-state-transformer function}

 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

-@_runST@ has a non-Haskell-able type:
+@runST@ has a non-Haskell-able type:

 \begin{verbatim}
 \begin{verbatim}

--- _runST :: forall a. (forall s. _ST s a) -> a
+-- runST :: forall a. (forall s. _ST s a) -> a

 -- which is to say ::
 --          forall a. (forall s. (_State s -> (a, _State s))) -> a
 
 -- which is to say ::
 --          forall a. (forall s. (_State s -> (a, _State s))) -> a
 

-_runST a m = case m _RealWorld (S# _RealWorld realWorld#) of
+runST a m = case m _RealWorld (S# _RealWorld realWorld#) of

               (r :: a, wild :: _State _RealWorld) -> r
 \end{verbatim}
               (r :: a, wild :: _State _RealWorld) -> r
 \end{verbatim}

+

 We unfold always, just for simplicity:
 \begin{code}
 runSTId
 We unfold always, just for simplicity:
 \begin{code}
 runSTId

@@ -554,16 +528,16 @@ runSTId
 -}
 \end{code}
 
 -}
 \end{code}
 

-SLPJ 95/04: Why @_runST@ must not have an unfolding; consider:
+SLPJ 95/04: Why @runST@ must not have an unfolding; consider:

 \begin{verbatim}
 f x =
 \begin{verbatim}
 f x =

-  _runST ( \ s -> let
+  runST ( \ s -> let

                    (a, s')  = newArray# 100 [] s
                    (_, s'') = fill_in_array_or_something a x s'
                  in
                  freezeArray# a s'' )
 \end{verbatim}
                    (a, s')  = newArray# 100 [] s
                    (_, s'') = fill_in_array_or_something a x s'
                  in
                  freezeArray# a s'' )
 \end{verbatim}

-If we inline @_runST@, we'll get:
+If we inline @runST@, we'll get:

 \begin{verbatim}
 f x = let
        (a, s')  = newArray# 100 [] realWorld#{-NB-}
 \begin{verbatim}
 f x = let
        (a, s')  = newArray# 100 [] realWorld#{-NB-}

@@ -604,7 +578,7 @@ voidId = pcMiscPrelId voidIdKey gHC_BUILTINS SLIT("void") voidTy noIdInfo
 
 \begin{code}
 buildId
 
 \begin{code}
 buildId

-  = pcMiscPrelId buildIdKey gHC__ SLIT("build") buildTy
+  = pcMiscPrelId buildIdKey SLIT("GHCerr") SLIT("build") buildTy

        ((((noIdInfo
                {-LATER:`addInfo_UF` mkMagicUnfolding buildIdKey-})
                `addInfo` mkStrictnessInfo [WwStrict] Nothing)
        ((((noIdInfo
                {-LATER:`addInfo_UF` mkMagicUnfolding buildIdKey-})
                `addInfo` mkStrictnessInfo [WwStrict] Nothing)

@@ -649,7 +623,7 @@ mkBuild ty tv c n g expr
 
 \begin{code}
 augmentId
 
 \begin{code}
 augmentId

-  = pcMiscPrelId augmentIdKey gHC__ SLIT("augment") augmentTy
+  = pcMiscPrelId augmentIdKey SLIT("GHCerr") 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)