[project @ 2000-06-30 13:11:07 by simonpj]

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

diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs
index 7a0627d..34d49c7 100644 (file)
--- a/ghc/compiler/prelude/PrimOp.lhs
+++ b/ghc/compiler/prelude/PrimOp.lhs
@@ -19,7 +19,8 @@ module PrimOp (
 
        pprPrimOp,
 
-       CCall(..), CCallTarget(..), ccallMayGC, ccallIsCasm, pprCCallOp
+       CCall(..), CCallTarget(..), ccallMayGC, ccallIsCasm, pprCCallOp,
+       isDynamicTarget, dynamicTarget, setCCallUnique
     ) where
 
 #include "HsVersions.h"
@@ -42,9 +43,9 @@ import Type           ( Type, mkForAllTys, mkForAllTy, mkFunTy, mkFunTys, mkTyVarTys,
                           UsageAnn(..), mkUsgTy
                        )
 import Unique          ( Unique, mkPrimOpIdUnique )
-import BasicTypes      ( Arity )
+import BasicTypes      ( Arity, Boxity(..) )
 import CStrings                ( CLabelString, pprCLabelString )
-import PrelMods                ( pREL_GHC, pREL_GHC_Name )
+import PrelNames       ( pREL_GHC, pREL_GHC_Name )
 import Outputable
 import Util            ( assoc, zipWithEqual )
 import GlaExts         ( Int(..), Int#, (==#) )
@@ -832,9 +833,10 @@ an_Integer_and_Int_tys
   = [intPrimTy, byteArrayPrimTy, -- Integer
      intPrimTy]
 
-unboxedPair     = mkUnboxedTupleTy 2
-unboxedTriple    = mkUnboxedTupleTy 3
-unboxedQuadruple = mkUnboxedTupleTy 4
+unboxedSingleton = mkTupleTy Unboxed 1
+unboxedPair     = mkTupleTy Unboxed 2
+unboxedTriple    = mkTupleTy Unboxed 3
+unboxedQuadruple = mkTupleTy Unboxed 4
 
 mkIOTy ty = mkFunTy realWorldStatePrimTy 
                    (unboxedPair [realWorldStatePrimTy,ty])
@@ -1270,7 +1272,7 @@ primOpInfo WriteArrayOp
 primOpInfo IndexArrayOp
   = let { elt = alphaTy; elt_tv = alphaTyVar } in
     mkGenPrimOp SLIT("indexArray#") [elt_tv] [mkArrayPrimTy elt, intPrimTy]
-       (mkUnboxedTupleTy 1 [elt])
+       (unboxedSingleton [elt])
 
 ---------------------------------------------------------------------------
 -- Primitive arrays full of unboxed bytes:
@@ -2302,8 +2304,8 @@ primOpUsg op
                          Nothing    -> pprPanic "primOpUsg:inFun" (ppr op <+> ppr ty)
 
         inUB fs ty  = case splitTyConApp_maybe ty of
-                        Just (tc,tys) -> ASSERT( tc == unboxedTupleTyCon (length fs) )
-                                         mkUnboxedTupleTy (length fs) (zipWithEqual "primOpUsg"
+                        Just (tc,tys) -> ASSERT( tc == tupleTyCon Unboxed (length fs) )
+                                         mkTupleTy Unboxed (length fs) (zipWithEqual "primOpUsg"
                                                                          ($) fs tys)
                         Nothing       -> pprPanic "primOpUsg:inUB" (ppr op <+> ppr ty)
 \end{code}
@@ -2409,6 +2411,7 @@ data CCall
                Bool            -- True <=> really a "casm"
                Bool            -- True <=> might invoke Haskell GC
                CallConv        -- calling convention to use.
+  deriving( Eq )
 
 data CCallTarget
   = StaticTarget  CLabelString  -- An "unboxed" ccall# to `fn'.
@@ -2417,11 +2420,33 @@ data CCallTarget
                                --    the function pointer if compiling the ccall# down to
                                --    .hc code - can't do this inline for tedious reasons.)
 
+instance Eq CCallTarget where
+  (StaticTarget l1) == (StaticTarget l2) = l1 == l2
+  (DynamicTarget _) == (DynamicTarget _) = True        
+       -- Ignore the arbitrary unique; this is important when comparing
+       -- a dynamic ccall read from an interface file A.hi with the
+       -- one constructed from A.hs, when deciding whether the interface
+       -- has changed
+  t1 == t2 = False
+
 ccallMayGC :: CCall -> Bool
 ccallMayGC (CCall _ _ may_gc _) = may_gc
 
 ccallIsCasm :: CCall -> Bool
 ccallIsCasm (CCall _ c_asm _ _) = c_asm
+
+isDynamicTarget (DynamicTarget _) = True
+isDynamicTarget (StaticTarget _)  = False
+
+dynamicTarget :: CCallTarget
+dynamicTarget = DynamicTarget (panic "Unique in DynamicTarget not yet set")
+       -- The unique is really only to do with code generation, so it
+       -- is only set in CoreToStg; before then it's just an error message
+
+setCCallUnique :: CCall -> Unique -> CCall
+setCCallUnique (CCall (DynamicTarget _) is_asm may_gc cconv) uniq
+  = CCall (DynamicTarget uniq) is_asm may_gc cconv
+setCCallUnique ccall uniq = ccall
 \end{code}
 
 \begin{code}