projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[project @ 2002-03-05 14:18:53 by simonmar]
[ghc-hetmet.git] / ghc / compiler / basicTypes / MkId.lhs
diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index f5998d2..11dcc39 100644 (file)
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -21,11 +21,12 @@ module MkId (
        mkPrimOpId, mkFCallId,
 
        -- And some particular Ids; see below for why they are wired in
-       wiredInIds,
+       wiredInIds, ghcPrimIds,
        unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId,
-       eRROR_ID, eRROR_CSTRING_ID, rEC_SEL_ERROR_ID, pAT_ERROR_ID, rEC_CON_ERROR_ID,
-       rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID,
-       nO_METHOD_BINDING_ERROR_ID, aBSENT_ERROR_ID, pAR_ERROR_ID
+       eRROR_ID, eRROR_CSTRING_ID, rEC_SEL_ERROR_ID, pAT_ERROR_ID,
+       rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID,
+       nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
+       aBSENT_ERROR_ID, pAR_ERROR_ID
     ) where
 
 #include "HsVersions.h"
@@ -45,7 +46,7 @@ import TcType         ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp,
                          tcSplitFunTys, tcSplitForAllTys, mkPredTy
                        )
 import Module          ( Module )
-import CoreUtils       ( mkInlineMe, exprType )
+import CoreUtils       ( exprType )
 import CoreUnfold      ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon )
 import Literal         ( Literal(..), nullAddrLit )
 import TyCon           ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons,
@@ -71,10 +72,9 @@ import Id            ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
                        )
 import IdInfo          ( IdInfo, noCafNoTyGenIdInfo,
                          setUnfoldingInfo, 
-                         setArityInfo, setSpecInfo,  setCgInfo, setCafInfo,
-                         newStrictnessFromOld, setAllStrictnessInfo,
-                         GlobalIdDetails(..), CafInfo(..), CprInfo(..), 
-                         CgInfo 
+                         setArityInfo, setSpecInfo, setCafInfo,
+                         setAllStrictnessInfo,
+                         GlobalIdDetails(..), CafInfo(..)
                        )
 import NewDemand       ( mkStrictSig, strictSigResInfo, DmdResult(..),
                          mkTopDmdType, topDmd, evalDmd, lazyDmd, 
@@ -112,24 +112,27 @@ wiredInIds
        -- error-reporting functions that they have an 'open' 
        -- result type. -- sof 1/99]
 
-      aBSENT_ERROR_ID
-    , eRROR_ID
-    , eRROR_CSTRING_ID
-    , iRREFUT_PAT_ERROR_ID
-    , nON_EXHAUSTIVE_GUARDS_ERROR_ID
-    , nO_METHOD_BINDING_ERROR_ID
-    , pAR_ERROR_ID
-    , pAT_ERROR_ID
-    , rEC_CON_ERROR_ID
-    , rEC_UPD_ERROR_ID
-
-       -- These can't be defined in Haskell, but they have
+    aBSENT_ERROR_ID,
+    eRROR_ID,
+    eRROR_CSTRING_ID,
+    iRREFUT_PAT_ERROR_ID,
+    nON_EXHAUSTIVE_GUARDS_ERROR_ID,
+    nO_METHOD_BINDING_ERROR_ID,
+    pAR_ERROR_ID,
+    pAT_ERROR_ID,
+    rEC_CON_ERROR_ID,
+    rEC_UPD_ERROR_ID
+    ] ++ ghcPrimIds
+
+-- These Ids are exported from GHC.Prim
+ghcPrimIds
+  = [  -- These can't be defined in Haskell, but they have
        -- perfectly reasonable unfoldings in Core
-    , realWorldPrimId
-    , unsafeCoerceId
-    , nullAddrId
-    , getTagId
-    , seqId
+    realWorldPrimId,
+    unsafeCoerceId,
+    nullAddrId,
+    getTagId,
+    seqId
     ]
 \end{code}
 
@@ -548,7 +551,7 @@ rebuildConArgs (arg:args) (str:stricts) us
        (_, tycon_args, pack_con, con_arg_tys)
                 = splitProductType "rebuildConArgs" arg_ty
 
-       unpacked_args  = zipWith (mkSysLocal SLIT("rb")) us con_arg_tys
+       unpacked_args  = zipWith (mkSysLocal FSLIT("rb")) us con_arg_tys
        (binds, args') = rebuildConArgs args stricts (dropList con_arg_tys us)
        con_app        = mkConApp pack_con (map Type tycon_args ++ map Var unpacked_args)
     in
@@ -641,7 +644,7 @@ mkPrimOpId :: PrimOp -> Id
 mkPrimOpId prim_op 
   = id
   where
-    (tyvars,arg_tys,res_ty, arity, strict_info) = primOpSig prim_op
+    (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op
     ty   = mkForAllTys tyvars (mkFunTys arg_tys res_ty)
     name = mkPrimOpIdName prim_op
     id   = mkGlobalId (PrimOpId prim_op) name ty info
@@ -649,8 +652,7 @@ mkPrimOpId prim_op
     info = noCafNoTyGenIdInfo
           `setSpecInfo`        rules
           `setArityInfo`       arity
-          `setAllStrictnessInfo`       Just (newStrictnessFromOld name arity strict_info NoCPRInfo)
-       -- Until we modify the primop generation code
+          `setAllStrictnessInfo` Just strict_sig
 
     rules = foldl (addRule id) emptyCoreRules (primOpRules prim_op)
 
@@ -789,7 +791,7 @@ another gun with which to shoot yourself in the foot.
 \begin{code}
 -- unsafeCoerce# :: forall a b. a -> b
 unsafeCoerceId
-  = pcMiscPrelId unsafeCoerceIdKey pREL_GHC SLIT("unsafeCoerce#") ty info
+  = pcMiscPrelId unsafeCoerceIdKey gHC_PRIM FSLIT("unsafeCoerce#") ty info
   where
     info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
           
@@ -804,13 +806,13 @@ unsafeCoerceId
 -- The reason is is here is because we don't provide 
 -- a way to write this literal in Haskell.
 nullAddrId 
-  = pcMiscPrelId nullAddrIdKey pREL_GHC SLIT("nullAddr#") addrPrimTy info
+  = pcMiscPrelId nullAddrIdKey gHC_PRIM FSLIT("nullAddr#") addrPrimTy info
   where
     info = noCafNoTyGenIdInfo `setUnfoldingInfo` 
           mkCompulsoryUnfolding (Lit nullAddrLit)
 
 seqId
-  = pcMiscPrelId seqIdKey pREL_GHC SLIT("seq") ty info
+  = pcMiscPrelId seqIdKey gHC_PRIM FSLIT("seq") ty info
   where
     info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
           
@@ -826,7 +828,7 @@ evaluate its argument and call the dataToTag# primitive.
 
 \begin{code}
 getTagId
-  = pcMiscPrelId getTagIdKey pREL_GHC SLIT("getTag#") ty info
+  = pcMiscPrelId getTagIdKey gHC_PRIM FSLIT("getTag#") ty info
   where
     info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
        -- We don't provide a defn for this; you must inline it
@@ -851,7 +853,7 @@ This comes up in strictness analysis
 
 \begin{code}
 realWorldPrimId        -- :: State# RealWorld
-  = pcMiscPrelId realWorldPrimIdKey pREL_GHC SLIT("realWorld#")
+  = pcMiscPrelId realWorldPrimIdKey gHC_PRIM FSLIT("realWorld#")
                 realWorldStatePrimTy
                 (noCafNoTyGenIdInfo `setUnfoldingInfo` mkOtherCon [])
        -- The mkOtherCon makes it look that realWorld# is evaluated
@@ -860,7 +862,7 @@ realWorldPrimId     -- :: State# RealWorld
        -- to be inlined
 
 voidArgId      -- :: State# RealWorld
-  = mkSysLocal SLIT("void") voidArgIdKey realWorldStatePrimTy
+  = mkSysLocal FSLIT("void") voidArgIdKey realWorldStatePrimTy
 \end{code}
 
 
@@ -887,31 +889,31 @@ templates, but we don't ever expect to generate code for it.
 
 \begin{code}
 eRROR_ID
-  = pc_bottoming_Id errorIdKey pREL_ERR SLIT("error") errorTy
+  = pc_bottoming_Id errorIdKey pREL_ERR FSLIT("error") errorTy
 eRROR_CSTRING_ID
-  = pc_bottoming_Id errorCStringIdKey pREL_ERR SLIT("errorCString") 
+  = pc_bottoming_Id errorCStringIdKey pREL_ERR FSLIT("errorCString") 
                    (mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy))
 pAT_ERROR_ID
-  = generic_ERROR_ID patErrorIdKey SLIT("patError")
+  = generic_ERROR_ID patErrorIdKey FSLIT("patError")
 rEC_SEL_ERROR_ID
-  = generic_ERROR_ID recSelErrIdKey SLIT("recSelError")
+  = generic_ERROR_ID recSelErrIdKey FSLIT("recSelError")
 rEC_CON_ERROR_ID
-  = generic_ERROR_ID recConErrorIdKey SLIT("recConError")
+  = generic_ERROR_ID recConErrorIdKey FSLIT("recConError")
 rEC_UPD_ERROR_ID
-  = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError")
+  = generic_ERROR_ID recUpdErrorIdKey FSLIT("recUpdError")
 iRREFUT_PAT_ERROR_ID
-  = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError")
+  = generic_ERROR_ID irrefutPatErrorIdKey FSLIT("irrefutPatError")
 nON_EXHAUSTIVE_GUARDS_ERROR_ID
-  = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError")
+  = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey FSLIT("nonExhaustiveGuardsError")
 nO_METHOD_BINDING_ERROR_ID
-  = generic_ERROR_ID noMethodBindingErrorIdKey SLIT("noMethodBindingError")
+  = generic_ERROR_ID noMethodBindingErrorIdKey FSLIT("noMethodBindingError")
 
 aBSENT_ERROR_ID
-  = pc_bottoming_Id absentErrorIdKey pREL_ERR SLIT("absentErr")
+  = pc_bottoming_Id absentErrorIdKey pREL_ERR FSLIT("absentErr")
        (mkSigmaTy [openAlphaTyVar] [] openAlphaTy)
 
 pAR_ERROR_ID
-  = pcMiscPrelId parErrorIdKey pREL_ERR SLIT("parError")
+  = pcMiscPrelId parErrorIdKey pREL_ERR FSLIT("parError")
     (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noCafNoTyGenIdInfo
 \end{code}
 
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)