pprPrimOp,
- CCall(..), CCallTarget(..), ccallMayGC, ccallIsCasm, pprCCallOp
+ CCall(..), CCallTarget(..), ccallMayGC, ccallIsCasm, pprCCallOp,
+ isDynamicTarget, dynamicTarget, setCCallUnique
) where
#include "HsVersions.h"
UsageAnn(..), mkUsgTy
)
import Unique ( Unique, mkPrimOpIdUnique )
-import BasicTypes ( Arity )
-import PrelMods ( pREL_GHC, pREL_GHC_Name )
+import BasicTypes ( Arity, Boxity(..) )
+import CStrings ( CLabelString, pprCLabelString )
+import PrelNames ( pREL_GHC, pREL_GHC_Name )
import Outputable
import Util ( assoc, zipWithEqual )
import GlaExts ( Int(..), Int#, (==#) )
| TakeMVarOp
| PutMVarOp
| SameMVarOp
+ | TryTakeMVarOp
| IsEmptyMVarOp
-- exceptions
| UnblockAsyncExceptionsOp
-- foreign objects
- | MakeForeignObjOp
+ | MkForeignObjOp
| WriteForeignObjOp
-- weak pointers
tagOf_PrimOp TakeMVarOp = ILIT(218)
tagOf_PrimOp PutMVarOp = ILIT(219)
tagOf_PrimOp SameMVarOp = ILIT(220)
-tagOf_PrimOp IsEmptyMVarOp = ILIT(221)
-tagOf_PrimOp MakeForeignObjOp = ILIT(222)
-tagOf_PrimOp WriteForeignObjOp = ILIT(223)
-tagOf_PrimOp MkWeakOp = ILIT(224)
-tagOf_PrimOp DeRefWeakOp = ILIT(225)
-tagOf_PrimOp FinalizeWeakOp = ILIT(226)
-tagOf_PrimOp MakeStableNameOp = ILIT(227)
-tagOf_PrimOp EqStableNameOp = ILIT(228)
-tagOf_PrimOp StableNameToIntOp = ILIT(229)
-tagOf_PrimOp MakeStablePtrOp = ILIT(230)
-tagOf_PrimOp DeRefStablePtrOp = ILIT(231)
-tagOf_PrimOp EqStablePtrOp = ILIT(232)
-tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(234)
-tagOf_PrimOp SeqOp = ILIT(235)
-tagOf_PrimOp ParOp = ILIT(236)
-tagOf_PrimOp ForkOp = ILIT(237)
-tagOf_PrimOp KillThreadOp = ILIT(238)
-tagOf_PrimOp YieldOp = ILIT(239)
-tagOf_PrimOp MyThreadIdOp = ILIT(240)
-tagOf_PrimOp DelayOp = ILIT(241)
-tagOf_PrimOp WaitReadOp = ILIT(242)
-tagOf_PrimOp WaitWriteOp = ILIT(243)
-tagOf_PrimOp ParGlobalOp = ILIT(244)
-tagOf_PrimOp ParLocalOp = ILIT(245)
-tagOf_PrimOp ParAtOp = ILIT(246)
-tagOf_PrimOp ParAtAbsOp = ILIT(247)
-tagOf_PrimOp ParAtRelOp = ILIT(248)
-tagOf_PrimOp ParAtForNowOp = ILIT(249)
-tagOf_PrimOp CopyableOp = ILIT(250)
-tagOf_PrimOp NoFollowOp = ILIT(251)
-tagOf_PrimOp NewMutVarOp = ILIT(252)
-tagOf_PrimOp ReadMutVarOp = ILIT(253)
-tagOf_PrimOp WriteMutVarOp = ILIT(254)
-tagOf_PrimOp SameMutVarOp = ILIT(255)
-tagOf_PrimOp CatchOp = ILIT(256)
-tagOf_PrimOp RaiseOp = ILIT(257)
-tagOf_PrimOp BlockAsyncExceptionsOp = ILIT(258)
-tagOf_PrimOp UnblockAsyncExceptionsOp = ILIT(259)
-tagOf_PrimOp DataToTagOp = ILIT(260)
-tagOf_PrimOp TagToEnumOp = ILIT(261)
+tagOf_PrimOp TryTakeMVarOp = ILIT(221)
+tagOf_PrimOp IsEmptyMVarOp = ILIT(222)
+tagOf_PrimOp MkForeignObjOp = ILIT(223)
+tagOf_PrimOp WriteForeignObjOp = ILIT(224)
+tagOf_PrimOp MkWeakOp = ILIT(225)
+tagOf_PrimOp DeRefWeakOp = ILIT(226)
+tagOf_PrimOp FinalizeWeakOp = ILIT(227)
+tagOf_PrimOp MakeStableNameOp = ILIT(228)
+tagOf_PrimOp EqStableNameOp = ILIT(229)
+tagOf_PrimOp StableNameToIntOp = ILIT(230)
+tagOf_PrimOp MakeStablePtrOp = ILIT(231)
+tagOf_PrimOp DeRefStablePtrOp = ILIT(232)
+tagOf_PrimOp EqStablePtrOp = ILIT(234)
+tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(235)
+tagOf_PrimOp SeqOp = ILIT(236)
+tagOf_PrimOp ParOp = ILIT(237)
+tagOf_PrimOp ForkOp = ILIT(238)
+tagOf_PrimOp KillThreadOp = ILIT(239)
+tagOf_PrimOp YieldOp = ILIT(240)
+tagOf_PrimOp MyThreadIdOp = ILIT(241)
+tagOf_PrimOp DelayOp = ILIT(242)
+tagOf_PrimOp WaitReadOp = ILIT(243)
+tagOf_PrimOp WaitWriteOp = ILIT(244)
+tagOf_PrimOp ParGlobalOp = ILIT(245)
+tagOf_PrimOp ParLocalOp = ILIT(246)
+tagOf_PrimOp ParAtOp = ILIT(247)
+tagOf_PrimOp ParAtAbsOp = ILIT(248)
+tagOf_PrimOp ParAtRelOp = ILIT(249)
+tagOf_PrimOp ParAtForNowOp = ILIT(250)
+tagOf_PrimOp CopyableOp = ILIT(251)
+tagOf_PrimOp NoFollowOp = ILIT(252)
+tagOf_PrimOp NewMutVarOp = ILIT(253)
+tagOf_PrimOp ReadMutVarOp = ILIT(254)
+tagOf_PrimOp WriteMutVarOp = ILIT(255)
+tagOf_PrimOp SameMutVarOp = ILIT(256)
+tagOf_PrimOp CatchOp = ILIT(257)
+tagOf_PrimOp RaiseOp = ILIT(258)
+tagOf_PrimOp BlockAsyncExceptionsOp = ILIT(259)
+tagOf_PrimOp UnblockAsyncExceptionsOp = ILIT(260)
+tagOf_PrimOp DataToTagOp = ILIT(261)
+tagOf_PrimOp TagToEnumOp = ILIT(262)
tagOf_PrimOp op = pprPanic# "tagOf_PrimOp: pattern-match" (ppr op)
TakeMVarOp,
PutMVarOp,
SameMVarOp,
+ TryTakeMVarOp,
IsEmptyMVarOp,
- MakeForeignObjOp,
+ MkForeignObjOp,
WriteForeignObjOp,
MkWeakOp,
DeRefWeakOp,
= [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])
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:
in
mkGenPrimOp SLIT("sameMVar#") [s_tv, elt_tv] [mvar_ty, mvar_ty] boolTy
+primOpInfo TryTakeMVarOp
+ = let
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
+ state = mkStatePrimTy s
+ in
+ mkGenPrimOp SLIT("tryTakeMVar#") [s_tv, elt_tv]
+ [mkMVarPrimTy s elt, state]
+ (unboxedTriple [state, intPrimTy, elt])
+
primOpInfo IsEmptyMVarOp
= let
elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
%************************************************************************
\begin{code}
-primOpInfo MakeForeignObjOp
- = mkGenPrimOp SLIT("makeForeignObj#") []
+primOpInfo MkForeignObjOp
+ = mkGenPrimOp SLIT("mkForeignObj#") []
[addrPrimTy, realWorldStatePrimTy]
(unboxedPair [realWorldStatePrimTy, foreignObjPrimTy])
primOpOutOfLine op
= case op of
TakeMVarOp -> True
+ TryTakeMVarOp -> True
PutMVarOp -> True
DelayOp -> True
WaitReadOp -> True
MkWeakOp -> True
FinalizeWeakOp -> True
MakeStableNameOp -> True
- MakeForeignObjOp -> True
+ MkForeignObjOp -> True
NewMutVarOp -> True
NewMVarOp -> True
ForkOp -> True
primOpHasSideEffects YieldOp = True
primOpHasSideEffects SeqOp = True
-primOpHasSideEffects MakeForeignObjOp = True
+primOpHasSideEffects MkForeignObjOp = True
primOpHasSideEffects WriteForeignObjOp = True
primOpHasSideEffects MkWeakOp = True
primOpHasSideEffects DeRefWeakOp = True
primOpHasSideEffects UnsafeThawArrayOp = True
primOpHasSideEffects TakeMVarOp = True
+primOpHasSideEffects TryTakeMVarOp = True
primOpHasSideEffects PutMVarOp = True
primOpHasSideEffects DelayOp = True
primOpHasSideEffects WaitReadOp = True
TakeMVarOp -> mangle [mkM, mkP ] mkM
PutMVarOp -> mangle [mkM, mkM, mkP ] mkR
SameMVarOp -> mangle [mkP, mkP ] mkM
+ TryTakeMVarOp -> mangle [mkM, mkP ] mkM
IsEmptyMVarOp -> mangle [mkP, mkP ] mkM
ForkOp -> mangle [mkO, mkP ] mkR
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}
Bool -- True <=> really a "casm"
Bool -- True <=> might invoke Haskell GC
CallConv -- calling convention to use.
+ deriving( Eq )
data CCallTarget
- = StaticTarget FAST_STRING -- An "unboxed" ccall# to `fn'.
+ = StaticTarget CLabelString -- An "unboxed" ccall# to `fn'.
| DynamicTarget Unique -- First argument (an Addr#) is the function pointer
-- (unique is used to generate a 'typedef' to cast
-- 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}
ppr_fun = case fun of
DynamicTarget _ -> text "\"\""
- StaticTarget fn -> ptext fn
+ StaticTarget fn -> pprCLabelString fn
\end{code}
projects / ghc-hetmet.git / blobdiff