%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
-\section[PrimOps]{Primitive operations (machine-level)}
+\section[PrimOp]{Primitive operations (machine-level)}
\begin{code}
#include "HsVersions.h"
-module PrimOps (
- PrimOp(..),
+module PrimOp (
+ PrimOp(..), allThePrimOps,
tagOf_PrimOp, -- ToDo: rm
- primOpNameInfo, primOpId,
- typeOfPrimOp, isCompareOp,
- primOpCanTriggerGC, primOpNeedsWrapper,
- primOpOkForSpeculation, primOpIsCheap,
- fragilePrimOp,
+ primOp_str, -- sigh
+ primOpType, isCompareOp,
PrimOpResultInfo(..),
getPrimOpResultInfo,
- HeapRequirement(..), primOpHeapReq,
+--MOVE: primOpCanTriggerGC, primOpNeedsWrapper,
+--MOVE: primOpOkForSpeculation, primOpIsCheap,
+--MOVE: fragilePrimOp,
+--MOVE: HeapRequirement(..), primOpHeapReq,
-- export for the Native Code Generator
--- primOpInfo, not exported
- PrimOpInfo(..),
+ primOpInfo, -- needed for primOpNameInfo
+ PrimOpInfo(..),
- pprPrimOp, showPrimOp,
+ pprPrimOp, showPrimOp
-- and to make the interface self-sufficient....
- PrimKind, HeapOffset, Id, Name, TyCon, UniType, TyVarTemplate
) where
-import PrelFuns -- help stuff for prelude
-import PrimKind -- most of it
+import Ubiq{-uitous-}
+
+import PrimRep -- most of it
import TysPrim
import TysWiredIn
-import AbsUniType -- lots of things
-import CLabelInfo ( identToC )
+import CStrings ( identToC )
import CgCompInfo ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE )
-import BasicLit ( BasicLit(..) )
-import HeapOffs ( addOff, intOff, totHdrSize, HeapOffset )
-import Id -- lots
-import IdInfo -- plenty of this, too
-import Maybes ( Maybe(..) )
import NameTypes ( mkPreludeCoreName, FullName, ShortName )
-import Outputable
-import PlainCore -- all of it
+import PprStyle ( codeStyle )
import Pretty
import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
-import Unique
-import Util
-#ifdef DPH
-import TyPod
-#endif {- Data Parallel Haskell -}
+import TyCon ( TyCon{-instances-} )
+import Type ( getAppDataTyCon, maybeAppDataTyCon,
+ mkForAllTys, mkFunTys, applyTyCon )
+import TyVar ( alphaTyVar, betaTyVar )
+import Util ( panic#, assoc, panic{-ToDo:rm-} )
+
+glueTyArgs = panic "PrimOp:glueTyArgs"
+pprParendType = panic "PrimOp:pprParendType"
+primRepFromType = panic "PrimOp:primRepFromType"
\end{code}
%************************************************************************
%* *
-\subsection[PrimOps-datatype]{Datatype for @PrimOp@ (an enumeration)}
+\subsection[PrimOp-datatype]{Datatype for @PrimOp@ (an enumeration)}
%* *
%************************************************************************
-- Int#-related ops:
-- IntAbsOp unused?? ADR
| IntAddOp | IntSubOp | IntMulOp | IntQuotOp
- | IntDivOp{-UNUSED-} | IntRemOp | IntNegOp | IntAbsOp
+ | IntRemOp | IntNegOp | IntAbsOp
-- Word#-related ops:
| AndOp | OrOp | NotOp
-- primitive ops for primitive arrays
| NewArrayOp
- | NewByteArrayOp PrimKind
+ | NewByteArrayOp PrimRep
| SameMutableArrayOp
| SameMutableByteArrayOp
| ReadArrayOp | WriteArrayOp | IndexArrayOp -- for arrays of Haskell ptrs
- | ReadByteArrayOp PrimKind
- | WriteByteArrayOp PrimKind
- | IndexByteArrayOp PrimKind
- | IndexOffAddrOp PrimKind
- -- PrimKind can be one of {Char,Int,Addr,Float,Double}Kind.
+ | ReadByteArrayOp PrimRep
+ | WriteByteArrayOp PrimRep
+ | IndexByteArrayOp PrimRep
+ | 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 MallocPtrKind is not included -- the only way of
+ -- Note that MallocPtrRep is not included -- the only way of
-- creating a MallocPtr is with a ccall or casm.
| UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp
| CCallOp FAST_STRING -- An "unboxed" ccall# to this named function
Bool -- True <=> really a "casm"
Bool -- True <=> might invoke Haskell GC
- [UniType] -- Unboxed argument; the state-token
+ [Type] -- Unboxed argument; the state-token
-- argument will have been put *first*
- UniType -- Return type; one of the "StateAnd<blah>#" types
+ Type -- Return type; one of the "StateAnd<blah>#" types
-- (... to be continued ... )
\end{code}
\end{pseudocode}
by
\begin{pseudocode}
-CoCase
- ( CoPrim
- (CCallOp "foo" [Universe#, StablePtr# a, Int#] FloatPrimAndUniverse False)
+Case
+ ( Prim
+ (CCallOp "foo" [Universe#, StablePtr# a, Int#] FloatPrimAndUniverse False)
-- :: Universe# -> StablePtr# a -> Int# -> FloatPrimAndUniverse
[]
[w#, sp# i#]
)
- (CoAlgAlts [ ( FloatPrimAndIoWorld,
- [f#, w#],
- CoCon (TupleCon 2) [Float, IoWorld] [F# f#, World w#]
- ) ]
- CoNoDefault
+ (AlgAlts [ ( FloatPrimAndIoWorld,
+ [f#, w#],
+ Con (TupleCon 2) [Float, IoWorld] [F# f#, World w#]
+ ) ]
+ NoDefault
)
\end{pseudocode}
Nota Bene: there are some people who find the empty list of types in
-the @CoPrim@ somewhat puzzling and would represent the above by
+the @Prim@ somewhat puzzling and would represent the above by
\begin{pseudocode}
-CoCase
- ( CoPrim
+Case
+ ( Prim
(CCallOp "foo" [alpha1, alpha2, alpha3] alpha4 False)
- -- :: /\ alpha1, alpha2 alpha3, alpha4.
+ -- :: /\ alpha1, alpha2 alpha3, alpha4.
-- alpha1 -> alpha2 -> alpha3 -> alpha4
[Universe#, StablePtr# a, Int#, FloatPrimAndIoWorld]
[w#, sp# i#]
)
- (CoAlgAlts [ ( FloatPrimAndIoWorld,
- [f#, w#],
- CoCon (TupleCon 2) [Float, IoWorld] [F# f#, World w#]
- ) ]
- CoNoDefault
+ (AlgAlts [ ( FloatPrimAndIoWorld,
+ [f#, w#],
+ Con (TupleCon 2) [Float, IoWorld] [F# f#, World w#]
+ ) ]
+ NoDefault
)
-\end{pseudocode}
+\end{pseudocode}
But, this is a completely different way of using @CCallOp@. The most
major changes required if we switch to this are in @primOpInfo@, and
| CopyableOp -- marks copyable code
| NoFollowOp -- marks non-followup expression
#endif {-GRAN-}
-
-#ifdef DPH
--- Shadow all the the above primitive OPs for N dimensioned objects.
- | PodNPrimOp Int PrimOp
-
--- Primitive conversion functions.
-
- | Int2PodNOp Int | Char2PodNOp Int | Float2PodNOp Int
- | Double2PodNOp Int | String2PodNOp Int
-
-#endif {-Data Parallel Haskell -}
\end{code}
Deriving Ix is what we really want! ToDo
tagOf_PrimOp IntSubOp = ILIT( 40)
tagOf_PrimOp IntMulOp = ILIT( 41)
tagOf_PrimOp IntQuotOp = ILIT( 42)
---UNUSED:tagOf_PrimOp IntDivOp = ILIT( 43)
tagOf_PrimOp IntRemOp = ILIT( 44)
tagOf_PrimOp IntNegOp = ILIT( 45)
tagOf_PrimOp IntAbsOp = ILIT( 46)
tagOf_PrimOp DoubleEncodeOp = ILIT(115)
tagOf_PrimOp DoubleDecodeOp = ILIT(116)
tagOf_PrimOp NewArrayOp = ILIT(117)
-tagOf_PrimOp (NewByteArrayOp CharKind) = ILIT(118)
-tagOf_PrimOp (NewByteArrayOp IntKind) = ILIT(119)
-tagOf_PrimOp (NewByteArrayOp AddrKind) = ILIT(120)
-tagOf_PrimOp (NewByteArrayOp FloatKind) = ILIT(121)
-tagOf_PrimOp (NewByteArrayOp DoubleKind)= ILIT(122)
+tagOf_PrimOp (NewByteArrayOp CharRep) = ILIT(118)
+tagOf_PrimOp (NewByteArrayOp IntRep) = ILIT(119)
+tagOf_PrimOp (NewByteArrayOp AddrRep) = ILIT(120)
+tagOf_PrimOp (NewByteArrayOp FloatRep) = ILIT(121)
+tagOf_PrimOp (NewByteArrayOp DoubleRep)= ILIT(122)
tagOf_PrimOp SameMutableArrayOp = ILIT(123)
tagOf_PrimOp SameMutableByteArrayOp = ILIT(124)
tagOf_PrimOp ReadArrayOp = ILIT(125)
tagOf_PrimOp WriteArrayOp = ILIT(126)
tagOf_PrimOp IndexArrayOp = ILIT(127)
-tagOf_PrimOp (ReadByteArrayOp CharKind) = ILIT(128)
-tagOf_PrimOp (ReadByteArrayOp IntKind) = ILIT(129)
-tagOf_PrimOp (ReadByteArrayOp AddrKind) = ILIT(130)
-tagOf_PrimOp (ReadByteArrayOp FloatKind) = ILIT(131)
-tagOf_PrimOp (ReadByteArrayOp DoubleKind) = ILIT(132)
-tagOf_PrimOp (WriteByteArrayOp CharKind) = ILIT(133)
-tagOf_PrimOp (WriteByteArrayOp IntKind) = ILIT(134)
-tagOf_PrimOp (WriteByteArrayOp AddrKind) = ILIT(135)
-tagOf_PrimOp (WriteByteArrayOp FloatKind) = ILIT(136)
-tagOf_PrimOp (WriteByteArrayOp DoubleKind) = ILIT(137)
-tagOf_PrimOp (IndexByteArrayOp CharKind) = ILIT(138)
-tagOf_PrimOp (IndexByteArrayOp IntKind) = ILIT(139)
-tagOf_PrimOp (IndexByteArrayOp AddrKind) = ILIT(140)
-tagOf_PrimOp (IndexByteArrayOp FloatKind) = ILIT(141)
-tagOf_PrimOp (IndexByteArrayOp DoubleKind) = ILIT(142)
-tagOf_PrimOp (IndexOffAddrOp CharKind) = ILIT(143)
-tagOf_PrimOp (IndexOffAddrOp IntKind) = ILIT(144)
-tagOf_PrimOp (IndexOffAddrOp AddrKind) = ILIT(145)
-tagOf_PrimOp (IndexOffAddrOp FloatKind) = ILIT(146)
-tagOf_PrimOp (IndexOffAddrOp DoubleKind) = ILIT(147)
+tagOf_PrimOp (ReadByteArrayOp CharRep) = ILIT(128)
+tagOf_PrimOp (ReadByteArrayOp IntRep) = ILIT(129)
+tagOf_PrimOp (ReadByteArrayOp AddrRep) = ILIT(130)
+tagOf_PrimOp (ReadByteArrayOp FloatRep) = ILIT(131)
+tagOf_PrimOp (ReadByteArrayOp DoubleRep) = ILIT(132)
+tagOf_PrimOp (WriteByteArrayOp CharRep) = ILIT(133)
+tagOf_PrimOp (WriteByteArrayOp IntRep) = ILIT(134)
+tagOf_PrimOp (WriteByteArrayOp AddrRep) = ILIT(135)
+tagOf_PrimOp (WriteByteArrayOp FloatRep) = ILIT(136)
+tagOf_PrimOp (WriteByteArrayOp DoubleRep) = ILIT(137)
+tagOf_PrimOp (IndexByteArrayOp CharRep) = ILIT(138)
+tagOf_PrimOp (IndexByteArrayOp IntRep) = ILIT(139)
+tagOf_PrimOp (IndexByteArrayOp AddrRep) = ILIT(140)
+tagOf_PrimOp (IndexByteArrayOp FloatRep) = ILIT(141)
+tagOf_PrimOp (IndexByteArrayOp DoubleRep) = ILIT(142)
+tagOf_PrimOp (IndexOffAddrOp CharRep) = ILIT(143)
+tagOf_PrimOp (IndexOffAddrOp IntRep) = ILIT(144)
+tagOf_PrimOp (IndexOffAddrOp AddrRep) = ILIT(145)
+tagOf_PrimOp (IndexOffAddrOp FloatRep) = ILIT(146)
+tagOf_PrimOp (IndexOffAddrOp DoubleRep) = ILIT(147)
tagOf_PrimOp UnsafeFreezeArrayOp = ILIT(148)
tagOf_PrimOp UnsafeFreezeByteArrayOp = ILIT(149)
tagOf_PrimOp NewSynchVarOp = ILIT(150)
tagOf_PrimOp NoFollowOp = ILIT(170)
#endif {-GRAN-}
-#ifdef DPH
-tagOf_PrimOp (PodNPrimOp _ _) = panic "ToDo:DPH:tagOf_PrimOp"
-tagOf_PrimOp (Int2PodNOp _) = panic "ToDo:DPH:tagOf_PrimOp"
-tagOf_PrimOp (Char2PodNOp _) = panic "ToDo:DPH:tagOf_PrimOp"
-tagOf_PrimOp (Float2PodNOp _) = panic "ToDo:DPH:tagOf_PrimOp"
-tagOf_PrimOp (Double2PodNOp _) = panic "ToDo:DPH:tagOf_PrimOp"
-tagOf_PrimOp (String2PodNOp _) = panic "ToDo:DPH:tagOf_PrimOp"
-#endif {-Data Parallel Haskell -}
-
--- avoid BUG
-tagOf_PrimOp _ = case (panic "tagOf_PrimOp: pattern-match") of { o ->
- tagOf_PrimOp o
- }
+tagOf_PrimOp _ = panic# "tagOf_PrimOp: pattern-match"
instance Eq PrimOp where
op == op2 = tagOf_PrimOp op _EQ_ tagOf_PrimOp op2
\end{code}
+An @Enum@-derived list would be better; meanwhile... (ToDo)
+\begin{code}
+allThePrimOps
+ = [ CharGtOp,
+ CharGeOp,
+ CharEqOp,
+ CharNeOp,
+ CharLtOp,
+ CharLeOp,
+ IntGtOp,
+ IntGeOp,
+ IntEqOp,
+ IntNeOp,
+ IntLtOp,
+ IntLeOp,
+ WordGtOp,
+ WordGeOp,
+ WordEqOp,
+ WordNeOp,
+ WordLtOp,
+ WordLeOp,
+ AddrGtOp,
+ AddrGeOp,
+ AddrEqOp,
+ AddrNeOp,
+ AddrLtOp,
+ AddrLeOp,
+ FloatGtOp,
+ FloatGeOp,
+ FloatEqOp,
+ FloatNeOp,
+ FloatLtOp,
+ FloatLeOp,
+ DoubleGtOp,
+ DoubleGeOp,
+ DoubleEqOp,
+ DoubleNeOp,
+ DoubleLtOp,
+ DoubleLeOp,
+ OrdOp,
+ ChrOp,
+ IntAddOp,
+ IntSubOp,
+ IntMulOp,
+ IntQuotOp,
+ IntRemOp,
+ IntNegOp,
+ AndOp,
+ OrOp,
+ NotOp,
+ SllOp,
+ SraOp,
+ SrlOp,
+ ISllOp,
+ ISraOp,
+ ISrlOp,
+ Int2WordOp,
+ Word2IntOp,
+ Int2AddrOp,
+ Addr2IntOp,
+ FloatAddOp,
+ FloatSubOp,
+ FloatMulOp,
+ FloatDivOp,
+ FloatNegOp,
+ Float2IntOp,
+ Int2FloatOp,
+ FloatExpOp,
+ FloatLogOp,
+ FloatSqrtOp,
+ FloatSinOp,
+ FloatCosOp,
+ FloatTanOp,
+ FloatAsinOp,
+ FloatAcosOp,
+ FloatAtanOp,
+ FloatSinhOp,
+ FloatCoshOp,
+ FloatTanhOp,
+ FloatPowerOp,
+ DoubleAddOp,
+ DoubleSubOp,
+ DoubleMulOp,
+ DoubleDivOp,
+ DoubleNegOp,
+ Double2IntOp,
+ Int2DoubleOp,
+ Double2FloatOp,
+ Float2DoubleOp,
+ DoubleExpOp,
+ DoubleLogOp,
+ DoubleSqrtOp,
+ DoubleSinOp,
+ DoubleCosOp,
+ DoubleTanOp,
+ DoubleAsinOp,
+ DoubleAcosOp,
+ DoubleAtanOp,
+ DoubleSinhOp,
+ DoubleCoshOp,
+ DoubleTanhOp,
+ DoublePowerOp,
+ IntegerAddOp,
+ IntegerSubOp,
+ IntegerMulOp,
+ IntegerQuotRemOp,
+ IntegerDivModOp,
+ IntegerNegOp,
+ IntegerCmpOp,
+ Integer2IntOp,
+ Int2IntegerOp,
+ Word2IntegerOp,
+ Addr2IntegerOp,
+ FloatEncodeOp,
+ FloatDecodeOp,
+ DoubleEncodeOp,
+ DoubleDecodeOp,
+ NewArrayOp,
+ NewByteArrayOp CharRep,
+ NewByteArrayOp IntRep,
+ NewByteArrayOp AddrRep,
+ NewByteArrayOp FloatRep,
+ NewByteArrayOp DoubleRep,
+ SameMutableArrayOp,
+ SameMutableByteArrayOp,
+ ReadArrayOp,
+ WriteArrayOp,
+ IndexArrayOp,
+ ReadByteArrayOp CharRep,
+ ReadByteArrayOp IntRep,
+ ReadByteArrayOp AddrRep,
+ ReadByteArrayOp FloatRep,
+ ReadByteArrayOp DoubleRep,
+ WriteByteArrayOp CharRep,
+ WriteByteArrayOp IntRep,
+ WriteByteArrayOp AddrRep,
+ WriteByteArrayOp FloatRep,
+ WriteByteArrayOp DoubleRep,
+ IndexByteArrayOp CharRep,
+ IndexByteArrayOp IntRep,
+ IndexByteArrayOp AddrRep,
+ IndexByteArrayOp FloatRep,
+ IndexByteArrayOp DoubleRep,
+ IndexOffAddrOp CharRep,
+ IndexOffAddrOp IntRep,
+ IndexOffAddrOp AddrRep,
+ IndexOffAddrOp FloatRep,
+ IndexOffAddrOp DoubleRep,
+ UnsafeFreezeArrayOp,
+ UnsafeFreezeByteArrayOp,
+ NewSynchVarOp,
+ ReadArrayOp,
+ TakeMVarOp,
+ PutMVarOp,
+ ReadIVarOp,
+ WriteIVarOp,
+ MakeStablePtrOp,
+ DeRefStablePtrOp,
+ ReallyUnsafePtrEqualityOp,
+ ErrorIOPrimOp,
+#ifdef GRAN
+ ParGlobalOp,
+ ParLocalOp,
+#endif {-GRAN-}
+ SeqOp,
+ ParOp,
+ ForkOp,
+ DelayOp,
+ WaitOp
+ ]
+\end{code}
+
%************************************************************************
%* *
-\subsection[PrimOps-info]{The essential info about each @PrimOp@}
+\subsection[PrimOp-info]{The essential info about each @PrimOp@}
%* *
%************************************************************************
\begin{code}
data PrimOpInfo
= Dyadic FAST_STRING -- string :: T -> T -> T
- UniType
+ Type
| Monadic FAST_STRING -- string :: T -> T
- UniType
+ Type
| Compare FAST_STRING -- string :: T -> T -> Bool
- UniType
+ Type
| Coerce FAST_STRING -- string :: T1 -> T2
- UniType
- UniType
+ Type
+ Type
| PrimResult FAST_STRING
- [TyVarTemplate] [UniType] TyCon PrimKind [UniType]
+ [TyVar] [Type] TyCon PrimRep [Type]
-- "PrimResult tvs [t1,..,tn] D# kind [s1,..,sm]"
-- has type Forall tvs. t1 -> ... -> tn -> (D# s1 ... sm)
-- D# is a primitive type constructor.
-- (the kind is the same info as D#, in another convenient form)
| AlgResult FAST_STRING
- [TyVarTemplate] [UniType] TyCon [UniType]
+ [TyVar] [Type] TyCon [Type]
-- "AlgResult tvs [t1,..,tn] T [s1,..,sm]"
-- has type Forall tvs. t1 -> ... -> tn -> (T s1 ... sm)
-- ToDo: Specialised calls to PrimOps are prohibited but may be desirable
-
-#ifdef DPH
- | PodNInfo Int
- PrimOpInfo
-#endif {- Data Parallel Haskell -}
\end{code}
Utility bits:
integerDyadic2Results name = AlgResult name [] two_Integer_tys return2GMPsTyCon []
-integerCompare name = PrimResult name [] two_Integer_tys intPrimTyCon IntKind []
+integerCompare name = PrimResult name [] two_Integer_tys intPrimTyCon IntRep []
\end{code}
@primOpInfo@ gives all essential information (from which everything
%************************************************************************
%* *
-\subsubsection[PrimOps-comparison]{PrimOpInfo basic comparison ops}
+\subsubsection[PrimOp-comparison]{PrimOpInfo basic comparison ops}
%* *
%************************************************************************
primOpInfo CharNeOp = Compare SLIT("neChar#") charPrimTy
primOpInfo CharLtOp = Compare SLIT("ltChar#") charPrimTy
primOpInfo CharLeOp = Compare SLIT("leChar#") charPrimTy
-
+
primOpInfo IntGtOp = Compare SLIT("gtInt#") intPrimTy
primOpInfo IntGeOp = Compare SLIT("geInt#") intPrimTy
primOpInfo IntEqOp = Compare SLIT("eqInt#") intPrimTy
primOpInfo IntNeOp = Compare SLIT("neInt#") intPrimTy
primOpInfo IntLtOp = Compare SLIT("ltInt#") intPrimTy
primOpInfo IntLeOp = Compare SLIT("leInt#") intPrimTy
-
+
primOpInfo WordGtOp = Compare SLIT("gtWord#") wordPrimTy
primOpInfo WordGeOp = Compare SLIT("geWord#") wordPrimTy
primOpInfo WordEqOp = Compare SLIT("eqWord#") wordPrimTy
primOpInfo WordNeOp = Compare SLIT("neWord#") wordPrimTy
primOpInfo WordLtOp = Compare SLIT("ltWord#") wordPrimTy
primOpInfo WordLeOp = Compare SLIT("leWord#") wordPrimTy
-
+
primOpInfo AddrGtOp = Compare SLIT("gtAddr#") addrPrimTy
primOpInfo AddrGeOp = Compare SLIT("geAddr#") addrPrimTy
primOpInfo AddrEqOp = Compare SLIT("eqAddr#") addrPrimTy
primOpInfo AddrNeOp = Compare SLIT("neAddr#") addrPrimTy
primOpInfo AddrLtOp = Compare SLIT("ltAddr#") addrPrimTy
primOpInfo AddrLeOp = Compare SLIT("leAddr#") addrPrimTy
-
+
primOpInfo FloatGtOp = Compare SLIT("gtFloat#") floatPrimTy
primOpInfo FloatGeOp = Compare SLIT("geFloat#") floatPrimTy
primOpInfo FloatEqOp = Compare SLIT("eqFloat#") floatPrimTy
primOpInfo FloatNeOp = Compare SLIT("neFloat#") floatPrimTy
primOpInfo FloatLtOp = Compare SLIT("ltFloat#") floatPrimTy
primOpInfo FloatLeOp = Compare SLIT("leFloat#") floatPrimTy
-
+
primOpInfo DoubleGtOp = Compare SLIT("gtDouble#") doublePrimTy
primOpInfo DoubleGeOp = Compare SLIT("geDouble#") doublePrimTy
primOpInfo DoubleEqOp = Compare SLIT("eqDouble#") doublePrimTy
%************************************************************************
%* *
-\subsubsection[PrimOps-Char]{PrimOpInfo for @Char#@s}
+\subsubsection[PrimOp-Char]{PrimOpInfo for @Char#@s}
%* *
%************************************************************************
%************************************************************************
%* *
-\subsubsection[PrimOps-Int]{PrimOpInfo for @Int#@s}
+\subsubsection[PrimOp-Int]{PrimOpInfo for @Int#@s}
%* *
%************************************************************************
primOpInfo IntSubOp = Dyadic SLIT("minusInt#") intPrimTy
primOpInfo IntMulOp = Dyadic SLIT("timesInt#") intPrimTy
primOpInfo IntQuotOp = Dyadic SLIT("quotInt#") intPrimTy
---UNUSED:primOpInfo IntDivOp = Dyadic SLIT("divInt#") intPrimTy
primOpInfo IntRemOp = Dyadic SLIT("remInt#") intPrimTy
primOpInfo IntNegOp = Monadic SLIT("negateInt#") intPrimTy
%************************************************************************
%* *
-\subsubsection[PrimOps-Word]{PrimOpInfo for @Word#@s}
+\subsubsection[PrimOp-Word]{PrimOpInfo for @Word#@s}
%* *
%************************************************************************
primOpInfo NotOp = Monadic SLIT("not#") wordPrimTy
primOpInfo SllOp
- = PrimResult SLIT("shiftL#") [] [wordPrimTy, intPrimTy] wordPrimTyCon WordKind []
+ = PrimResult SLIT("shiftL#") [] [wordPrimTy, intPrimTy] wordPrimTyCon WordRep []
primOpInfo SraOp
- = PrimResult SLIT("shiftRA#") [] [wordPrimTy, intPrimTy] wordPrimTyCon WordKind []
+ = PrimResult SLIT("shiftRA#") [] [wordPrimTy, intPrimTy] wordPrimTyCon WordRep []
primOpInfo SrlOp
- = PrimResult SLIT("shiftRL#") [] [wordPrimTy, intPrimTy] wordPrimTyCon WordKind []
+ = PrimResult SLIT("shiftRL#") [] [wordPrimTy, intPrimTy] wordPrimTyCon WordRep []
primOpInfo ISllOp
- = PrimResult SLIT("iShiftL#") [] [intPrimTy, intPrimTy] intPrimTyCon IntKind []
+ = PrimResult SLIT("iShiftL#") [] [intPrimTy, intPrimTy] intPrimTyCon IntRep []
primOpInfo ISraOp
- = PrimResult SLIT("iShiftRA#") [] [intPrimTy, intPrimTy] intPrimTyCon IntKind []
+ = PrimResult SLIT("iShiftRA#") [] [intPrimTy, intPrimTy] intPrimTyCon IntRep []
primOpInfo ISrlOp
- = PrimResult SLIT("iShiftRL#") [] [intPrimTy, intPrimTy] intPrimTyCon IntKind []
+ = PrimResult SLIT("iShiftRL#") [] [intPrimTy, intPrimTy] intPrimTyCon IntRep []
primOpInfo Int2WordOp = Coerce SLIT("int2Word#") intPrimTy wordPrimTy
primOpInfo Word2IntOp = Coerce SLIT("word2Int#") wordPrimTy intPrimTy
%************************************************************************
%* *
-\subsubsection[PrimOps-Addr]{PrimOpInfo for @Addr#@s}
+\subsubsection[PrimOp-Addr]{PrimOpInfo for @Addr#@s}
%* *
%************************************************************************
%************************************************************************
%* *
-\subsubsection[PrimOps-Float]{PrimOpInfo for @Float#@s}
+\subsubsection[PrimOp-Float]{PrimOpInfo for @Float#@s}
%* *
%************************************************************************
%************************************************************************
%* *
-\subsubsection[PrimOps-Double]{PrimOpInfo for @Double#@s}
+\subsubsection[PrimOp-Double]{PrimOpInfo for @Double#@s}
%* *
%************************************************************************
%************************************************************************
%* *
-\subsubsection[PrimOps-Integer]{PrimOpInfo for @Integer@ (and related!)}
+\subsubsection[PrimOp-Integer]{PrimOpInfo for @Integer@ (and related!)}
%* *
%************************************************************************
primOpInfo IntegerDivModOp = integerDyadic2Results SLIT("divModInteger#")
primOpInfo Integer2IntOp
- = PrimResult SLIT("integer2Int#") [] one_Integer_ty intPrimTyCon IntKind []
+ = PrimResult SLIT("integer2Int#") [] one_Integer_ty intPrimTyCon IntRep []
primOpInfo Int2IntegerOp
= AlgResult SLIT("int2Integer#") [] [intPrimTy] integerTyCon []
\begin{code}
primOpInfo FloatEncodeOp
= PrimResult SLIT("encodeFloat#") [] an_Integer_and_Int_tys
- floatPrimTyCon FloatKind []
+ floatPrimTyCon FloatRep []
primOpInfo DoubleEncodeOp
= PrimResult SLIT("encodeDouble#") [] an_Integer_and_Int_tys
- doublePrimTyCon DoubleKind []
+ doublePrimTyCon DoubleRep []
primOpInfo FloatDecodeOp
= AlgResult SLIT("decodeFloat#") [] [floatPrimTy] returnIntAndGMPTyCon []
%************************************************************************
%* *
-\subsubsection[PrimOps-Arrays]{PrimOpInfo for primitive arrays}
+\subsubsection[PrimOp-Arrays]{PrimOpInfo for primitive arrays}
%* *
%************************************************************************
\begin{code}
primOpInfo NewArrayOp
= let {
- elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
} in
AlgResult SLIT("newArray#") [s_tv, elt_tv] [intPrimTy, elt, mkStatePrimTy s]
stateAndMutableArrayPrimTyCon [s, elt]
primOpInfo (NewByteArrayOp kind)
= let
- s = alpha; s_tv = alpha_tv
+ s = alphaTy; s_tv = alphaTyVar
- (str, _, prim_tycon) = getKindInfo kind
+ (str, _, prim_tycon) = getPrimRepInfo kind
op_str = _PK_ ("new" ++ str ++ "Array#")
in
- AlgResult op_str [s_tv]
- [intPrimTy, mkStatePrimTy s]
+ AlgResult op_str [s_tv]
+ [intPrimTy, mkStatePrimTy s]
stateAndMutableByteArrayPrimTyCon [s]
---------------------------------------------------------------------------
primOpInfo SameMutableArrayOp
= let {
- elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv;
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
mut_arr_ty = mkMutableArrayPrimTy s elt
} in
AlgResult SLIT("sameMutableArray#") [s_tv, elt_tv] [mut_arr_ty, mut_arr_ty]
primOpInfo SameMutableByteArrayOp
= let {
- s = alpha; s_tv = alpha_tv;
+ s = alphaTy; s_tv = alphaTyVar;
mut_arr_ty = mkMutableByteArrayPrimTy s
} in
AlgResult SLIT("sameMutableByteArray#") [s_tv] [mut_arr_ty, mut_arr_ty]
primOpInfo ReadArrayOp
= let {
- elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
} in
AlgResult SLIT("readArray#") [s_tv, elt_tv]
[mkMutableArrayPrimTy s elt, intPrimTy, mkStatePrimTy s]
primOpInfo WriteArrayOp
= let {
- elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
} in
PrimResult SLIT("writeArray#") [s_tv, elt_tv]
[mkMutableArrayPrimTy s elt, intPrimTy, elt, mkStatePrimTy s]
- statePrimTyCon VoidKind [s]
+ statePrimTyCon VoidRep [s]
primOpInfo IndexArrayOp
- = let { elt = alpha; elt_tv = alpha_tv } in
+ = let { elt = alphaTy; elt_tv = alphaTyVar } in
AlgResult SLIT("indexArray#") [elt_tv] [mkArrayPrimTy elt, intPrimTy]
liftTyCon [elt]
primOpInfo (ReadByteArrayOp kind)
= let
- s = alpha; s_tv = alpha_tv
+ s = alphaTy; s_tv = alphaTyVar
- (str, _, prim_tycon) = getKindInfo kind
+ (str, _, prim_tycon) = getPrimRepInfo kind
op_str = _PK_ ("read" ++ str ++ "Array#")
relevant_tycon = assoc "primOpInfo" tbl kind
[mkMutableByteArrayPrimTy s, intPrimTy, mkStatePrimTy s]
relevant_tycon [s]
where
- tbl = [ (CharKind, stateAndCharPrimTyCon),
- (IntKind, stateAndIntPrimTyCon),
- (AddrKind, stateAndAddrPrimTyCon),
- (FloatKind, stateAndFloatPrimTyCon),
- (DoubleKind, stateAndDoublePrimTyCon) ]
+ tbl = [ (CharRep, stateAndCharPrimTyCon),
+ (IntRep, stateAndIntPrimTyCon),
+ (AddrRep, stateAndAddrPrimTyCon),
+ (FloatRep, stateAndFloatPrimTyCon),
+ (DoubleRep, stateAndDoublePrimTyCon) ]
-- How come there's no Word byte arrays? ADR
primOpInfo (WriteByteArrayOp kind)
= let
- s = alpha; s_tv = alpha_tv
+ s = alphaTy; s_tv = alphaTyVar
- (str, prim_ty, _) = getKindInfo kind
+ (str, prim_ty, _) = getPrimRepInfo kind
op_str = _PK_ ("write" ++ str ++ "Array#")
in
-- NB: *Prim*Result --
PrimResult op_str [s_tv]
[mkMutableByteArrayPrimTy s, intPrimTy, prim_ty, mkStatePrimTy s]
- statePrimTyCon VoidKind [s]
+ statePrimTyCon VoidRep [s]
primOpInfo (IndexByteArrayOp kind)
= let
- (str, _, prim_tycon) = getKindInfo kind
+ (str, _, prim_tycon) = getPrimRepInfo kind
op_str = _PK_ ("index" ++ str ++ "Array#")
in
-- NB: *Prim*Result --
primOpInfo (IndexOffAddrOp kind)
= let
- (str, _, prim_tycon) = getKindInfo kind
+ (str, _, prim_tycon) = getPrimRepInfo kind
op_str = _PK_ ("index" ++ str ++ "OffAddr#")
in
PrimResult op_str [] [addrPrimTy, intPrimTy] prim_tycon kind []
---------------------------------------------------------------------------
primOpInfo UnsafeFreezeArrayOp
= let {
- elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
} in
AlgResult SLIT("unsafeFreezeArray#") [s_tv, elt_tv]
[mkMutableArrayPrimTy s elt, mkStatePrimTy s]
stateAndArrayPrimTyCon [s, elt]
primOpInfo UnsafeFreezeByteArrayOp
- = let { s = alpha; s_tv = alpha_tv } in
+ = let { s = alphaTy; s_tv = alphaTyVar } in
AlgResult SLIT("unsafeFreezeByteArray#") [s_tv]
[mkMutableByteArrayPrimTy s, mkStatePrimTy s]
stateAndByteArrayPrimTyCon [s]
%************************************************************************
%* *
-\subsubsection[PrimOps-SynchVars]{PrimOpInfo for synchronizing Variables}
+\subsubsection[PrimOp-SynchVars]{PrimOpInfo for synchronizing Variables}
%* *
%************************************************************************
\begin{code}
primOpInfo NewSynchVarOp
= let {
- elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
} in
AlgResult SLIT("newSynchVar#") [s_tv, elt_tv] [mkStatePrimTy s]
stateAndSynchVarPrimTyCon [s, elt]
primOpInfo TakeMVarOp
= let {
- elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
} in
AlgResult SLIT("takeMVar#") [s_tv, elt_tv]
[mkSynchVarPrimTy s elt, mkStatePrimTy s]
primOpInfo PutMVarOp
= let {
- elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
} in
AlgResult SLIT("putMVar#") [s_tv, elt_tv]
[mkSynchVarPrimTy s elt, elt, mkStatePrimTy s]
primOpInfo ReadIVarOp
= let {
- elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
} in
AlgResult SLIT("readIVar#") [s_tv, elt_tv]
[mkSynchVarPrimTy s elt, mkStatePrimTy s]
primOpInfo WriteIVarOp
= let {
- elt = alpha; elt_tv = alpha_tv; s = beta; s_tv = beta_tv
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
} in
AlgResult SLIT("writeIVar#") [s_tv, elt_tv]
[mkSynchVarPrimTy s elt, elt, mkStatePrimTy s]
%************************************************************************
%* *
-\subsubsection[PrimOps-Wait]{PrimOpInfo for delay/wait operations}
+\subsubsection[PrimOp-Wait]{PrimOpInfo for delay/wait operations}
%* *
%************************************************************************
primOpInfo DelayOp
= let {
- s = alpha; s_tv = alpha_tv
+ s = alphaTy; s_tv = alphaTyVar
} in
PrimResult SLIT("delay#") [s_tv]
[intPrimTy, mkStatePrimTy s]
- statePrimTyCon VoidKind [s]
+ statePrimTyCon VoidRep [s]
primOpInfo WaitOp
= let {
- s = alpha; s_tv = alpha_tv
+ s = alphaTy; s_tv = alphaTyVar
} in
PrimResult SLIT("wait#") [s_tv]
[intPrimTy, mkStatePrimTy s]
- statePrimTyCon VoidKind [s]
+ statePrimTyCon VoidRep [s]
\end{code}
%************************************************************************
%* *
-\subsubsection[PrimOps-stable-pointers]{PrimOpInfo for ``stable pointers''}
+\subsubsection[PrimOp-stable-pointers]{PrimOpInfo for ``stable pointers''}
%* *
%************************************************************************
\begin{code}
primOpInfo MakeStablePtrOp
- = AlgResult SLIT("makeStablePtr#") [alpha_tv]
- [alpha, realWorldStatePrimTy]
- stateAndStablePtrPrimTyCon [realWorldTy, alpha]
+ = AlgResult SLIT("makeStablePtr#") [alphaTyVar]
+ [alphaTy, realWorldStatePrimTy]
+ stateAndStablePtrPrimTyCon [realWorldTy, alphaTy]
primOpInfo DeRefStablePtrOp
- = AlgResult SLIT("deRefStablePtr#") [alpha_tv]
- [mkStablePtrPrimTy alpha, realWorldStatePrimTy]
- stateAndPtrPrimTyCon [realWorldTy, alpha]
+ = AlgResult SLIT("deRefStablePtr#") [alphaTyVar]
+ [mkStablePtrPrimTy alphaTy, realWorldStatePrimTy]
+ stateAndPtrPrimTyCon [realWorldTy, alphaTy]
\end{code}
%************************************************************************
%* *
-\subsubsection[PrimOps-unsafePointerEquality]{PrimOpInfo for Pointer Equality}
+\subsubsection[PrimOp-unsafePointerEquality]{PrimOpInfo for Pointer Equality}
%* *
%************************************************************************
\begin{code}
primOpInfo ReallyUnsafePtrEqualityOp
- = PrimResult SLIT("reallyUnsafePtrEquality#") [alpha_tv]
- [alpha, alpha] intPrimTyCon IntKind []
+ = PrimResult SLIT("reallyUnsafePtrEquality#") [alphaTyVar]
+ [alphaTy, alphaTy] intPrimTyCon IntRep []
\end{code}
%************************************************************************
%* *
-\subsubsection[PrimOps-parallel]{PrimOpInfo for parallelism op(s)}
+\subsubsection[PrimOp-parallel]{PrimOpInfo for parallelism op(s)}
%* *
%************************************************************************
\begin{code}
primOpInfo SeqOp -- seq# :: a -> Int#
- = PrimResult SLIT("seq#") [alpha_tv] [alpha] intPrimTyCon IntKind []
+ = PrimResult SLIT("seq#") [alphaTyVar] [alphaTy] intPrimTyCon IntRep []
primOpInfo ParOp -- par# :: a -> Int#
- = PrimResult SLIT("par#") [alpha_tv] [alpha] intPrimTyCon IntKind []
+ = PrimResult SLIT("par#") [alphaTyVar] [alphaTy] intPrimTyCon IntRep []
primOpInfo ForkOp -- fork# :: a -> Int#
- = PrimResult SLIT("fork#") [alpha_tv] [alpha] intPrimTyCon IntKind []
+ = PrimResult SLIT("fork#") [alphaTyVar] [alphaTy] intPrimTyCon IntRep []
\end{code}
#ifdef GRAN
primOpInfo ParGlobalOp -- parGlobal# :: Int -> a -> b -> b
- = AlgResult SLIT("parGlobal#") [alpha_tv,beta_tv] [intPrimTy,alpha,beta] liftTyCon [beta]
+ = AlgResult SLIT("parGlobal#") [alphaTyVar,betaTyVar] [intPrimTy,alphaTy,betaTy] liftTyCon [betaTy]
primOpInfo ParLocalOp -- parLocal# :: Int -> a -> b -> b
- = AlgResult SLIT("parLocal#") [alpha_tv,beta_tv] [intPrimTy,alpha,beta] liftTyCon [beta]
+ = AlgResult SLIT("parLocal#") [alphaTyVar,betaTyVar] [intPrimTy,alphaTy,betaTy] liftTyCon [betaTy]
primOpInfo ParAtOp -- parAt# :: Int -> a -> b -> c -> c
- = AlgResult SLIT("parAt#") [alpha_tv,beta_tv,gamma_tv] [intPrimTy,alpha,beta,gamma] liftTyCon [gamma]
+ = AlgResult SLIT("parAt#") [alphaTyVar,betaTyVar,gammaTyVar] [intPrimTy,alphaTy,betaTy,gammaTy] liftTyCon [gammaTy]
primOpInfo ParAtForNowOp -- parAtForNow# :: Int -> a -> b -> c -> c
- = AlgResult SLIT("parAtForNow#") [alpha_tv,beta_tv,gamma_tv] [intPrimTy,alpha,beta,gamma] liftTyCon [gamma]
+ = AlgResult SLIT("parAtForNow#") [alphaTyVar,betaTyVar,gammaTyVar] [intPrimTy,alphaTy,betaTy,gammaTy] liftTyCon [gammaTy]
primOpInfo CopyableOp -- copyable# :: a -> a
- = AlgResult SLIT("copyable#") [alpha_tv] [alpha] liftTyCon [alpha]
+ = AlgResult SLIT("copyable#") [alphaTyVar] [alphaTy] liftTyCon [alphaTy]
primOpInfo NoFollowOp -- noFollow# :: a -> a
- = AlgResult SLIT("noFollow#") [alpha_tv] [alpha] liftTyCon [alpha]
+ = AlgResult SLIT("noFollow#") [alphaTyVar] [alphaTy] liftTyCon [alphaTy]
#endif {-GRAN-}
\end{code}
%************************************************************************
%* *
-\subsubsection[PrimOps-errorIO]{PrimOpInfo for @errorIO#@}
+\subsubsection[PrimOp-errorIO]{PrimOpInfo for @errorIO#@}
%* *
%************************************************************************
primOpInfo ErrorIOPrimOp -- errorIO# :: PrimIO () -> State# RealWorld#
= PrimResult SLIT("errorIO#") []
[mkPrimIoTy unitTy]
- statePrimTyCon VoidKind [realWorldTy]
+ statePrimTyCon VoidRep [realWorldTy]
\end{code}
%************************************************************************
%* *
-\subsubsection[PrimOps-IO-etc]{PrimOpInfo for C calls, and I/O-ish things}
+\subsubsection[PrimOp-IO-etc]{PrimOpInfo for C calls, and I/O-ish things}
%* *
%************************************************************************
primOpInfo (CCallOp _ _ _ arg_tys result_ty)
= AlgResult SLIT("ccall#") [] arg_tys result_tycon tys_applied
where
- (result_tycon, tys_applied, _) = getUniDataTyCon result_ty
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[PrimOps-DPH]{PrimOpInfo for Data Parallel Haskell}
-%* *
-%************************************************************************
-
-\begin{code}
-#ifdef DPH
--- ToDo:DPH: various things need doing here
-
-primOpInfo (Int2PodNOp d) = Coerce ("int2Pod" ++ show d)
- IntKind
- (PodNKind d IntKind)
-
-primOpInfo (Char2PodNOp d) = Coerce ("char2Pod" ++ show d)
- CharKind
- (PodNKind d CharKind)
-
-primOpInfo (Float2PodNOp d) = Coerce ("float2Pod" ++ show d)
- FloatKind
- (PodNKind d FloatKind)
-
-primOpInfo (Double2PodNOp d) = Coerce ("double2Pod" ++ show d)
- DoubleKind
- (PodNKind d DoubleKind)
-
-{-
-primOpInfo (Integer2PodNOp d) = Coerce ("integer2Pod" ++ show d)
- IntegerKind
- (PodNKind d IntegerKind)
--}
-
-primOpInfo (String2PodNOp d) = Coerce ("string2Pod" ++ show d)
- LitStringKind
- (PodNKind d LitStringKind)
-
-primOpInfo (PodNPrimOp d p) = PodNInfo d (primOpInfo p)
-#endif {- Data Parallel Haskell -}
+ (result_tycon, tys_applied, _) = getAppDataTyCon result_ty
\end{code}
%************************************************************************
%* *
-\subsection[PrimOps-utils]{Utilities for @PrimitiveOps@}
+\subsection[PrimOp-utils]{Utilities for @PrimitiveOps@}
%* *
%************************************************************************
a fixed amount of heap is required, and the needs of the @PrimOp@ can
be combined with the rest of the heap usage in the basic block. For an
unfortunate few, some unknown amount of heap is required (these are the
-ops which can trigger GC).
+ops which can trigger GC).
\begin{code}
-data HeapRequirement
- = NoHeapRequired
- | FixedHeapRequired HeapOffset
+{- MOVE:
+data HeapRequirement
+ = NoHeapRequired
+ | FixedHeapRequired HeapOffset
| VariableHeapRequired
primOpHeapReq :: PrimOp -> HeapRequirement
primOpHeapReq IntegerQuotRemOp = VariableHeapRequired
primOpHeapReq IntegerDivModOp = VariableHeapRequired
primOpHeapReq IntegerNegOp = VariableHeapRequired
-primOpHeapReq Int2IntegerOp = FixedHeapRequired
+primOpHeapReq Int2IntegerOp = FixedHeapRequired
(addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
(intOff mIN_MP_INT_SIZE))
-primOpHeapReq Word2IntegerOp = FixedHeapRequired
+primOpHeapReq Word2IntegerOp = FixedHeapRequired
(addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
(intOff mIN_MP_INT_SIZE))
primOpHeapReq Addr2IntegerOp = VariableHeapRequired
-primOpHeapReq FloatDecodeOp = FixedHeapRequired
- (addOff (intOff (getKindSize IntKind + mP_STRUCT_SIZE))
+primOpHeapReq FloatDecodeOp = FixedHeapRequired
+ (addOff (intOff (getPrimRepSize IntRep + mP_STRUCT_SIZE))
(addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
(intOff mIN_MP_INT_SIZE)))
-primOpHeapReq DoubleDecodeOp = FixedHeapRequired
- (addOff (intOff (getKindSize IntKind + mP_STRUCT_SIZE))
+primOpHeapReq DoubleDecodeOp = FixedHeapRequired
+ (addOff (intOff (getPrimRepSize IntRep + mP_STRUCT_SIZE))
(addOff (totHdrSize (DataRep mIN_MP_INT_SIZE))
(intOff mIN_MP_INT_SIZE)))
else NoHeapRequired
where
returnsMallocPtr
- = case (getUniDataTyCon_maybe return_ty) of
+ = case (maybeAppDataTyCon return_ty) of
Nothing -> False
Just (tycon, _, _) -> tycon == stateAndMallocPtrPrimTyCon
primOpHeapReq DoubleEncodeOp = FixedHeapRequired (intOff mP_STRUCT_SIZE)
-- a NewSynchVarOp creates a three-word mutuple in the heap.
-primOpHeapReq NewSynchVarOp = FixedHeapRequired
+primOpHeapReq NewSynchVarOp = FixedHeapRequired
(addOff (totHdrSize (MuTupleRep 3)) (intOff 3))
-- Sparking ops no longer allocate any heap; however, _fork_ may
#endif {-GRAN-}
primOpHeapReq other_op = NoHeapRequired
+-}
\end{code}
Primops which can trigger GC have to be called carefully.
-In particular, their arguments are guaranteed to be in registers,
+In particular, their arguments are guaranteed to be in registers,
and a liveness mask tells which regs are live.
\begin{code}
-primOpCanTriggerGC op =
+{- MOVE:
+primOpCanTriggerGC op =
case op of
TakeMVarOp -> True
ReadIVarOp -> True
DelayOp -> True
WaitOp -> True
- _ ->
- case primOpHeapReq op of
+ _ ->
+ case primOpHeapReq op of
VariableHeapRequired -> True
_ -> False
-
+-}
\end{code}
Sometimes we may choose to execute a PrimOp even though it isn't
of by data dependencies.
\begin{code}
+{- MOVE:
primOpOkForSpeculation :: PrimOp -> Bool
-- Int.
---UNUSED:primOpOkForSpeculation IntDivOp = False -- Divide by zero
primOpOkForSpeculation IntQuotOp = False -- Divide by zero
primOpOkForSpeculation IntRemOp = False -- Divide by zero
-- The default is "yes it's ok for speculation"
primOpOkForSpeculation other_op = True
+-}
\end{code}
@primOpIsCheap@, as used in \tr{SimplUtils.lhs}. For now (HACK
WARNING), we just borrow some other predicates for a
what-should-be-good-enough test.
\begin{code}
+{-MOVE:
primOpIsCheap op
= primOpOkForSpeculation op && not (primOpCanTriggerGC op)
+-}
\end{code}
And some primops have side-effects and so, for example, must not be
duplicated.
\begin{code}
+{- MOVE:
fragilePrimOp :: PrimOp -> Bool
fragilePrimOp ParOp = True
#endif {-GRAN-}
fragilePrimOp other = False
+-}
\end{code}
Primitive operations that perform calls need wrappers to save any live variables
that are stored in caller-saves registers
\begin{code}
+{- MOVE:
primOpNeedsWrapper :: PrimOp -> Bool
primOpNeedsWrapper (CCallOp _ _ _ _ _) = True
---UNUSED:primOpNeedsWrapper IntDivOp = True
-
primOpNeedsWrapper NewArrayOp = True -- ToDo: for nativeGen only!(JSM)
primOpNeedsWrapper (NewByteArrayOp _) = True
primOpNeedsWrapper WaitOp = True
primOpNeedsWrapper other_op = False
+-}
\end{code}
\begin{code}
-primOpId :: PrimOp -> Id
-primOpNameInfo :: PrimOp -> (FAST_STRING, Name)
-
--- the *NameInfo ones are trivial:
-
-primOpNameInfo op = (primOp_str op, WiredInVal (primOpId op))
-
primOp_str op
= case (primOpInfo op) of
Dyadic str _ -> str
Monadic str _ -> str
Compare str _ -> str
- Coerce str _ _ -> str
+ Coerce str _ _ -> str
PrimResult str _ _ _ _ _ -> str
AlgResult str _ _ _ _ -> str
-#ifdef DPH
- PodNInfo d i -> case i of
- Dyadic str _ -> (str ++ ".POD" ++ show d ++ "#")
- Monadic str _ -> (str ++ ".POD" ++ show d ++ "#")
- Compare str _ -> (str ++ ".POD" ++ show d ++ "#")
- Coerce str _ _ -> (str ++ ".POD" ++ show d ++ "#")
- PrimResult str _ _ _ _ _ -> (str ++ ".POD" ++ show d)
- AlgResult str _ _ _ _ -> (str ++ ".POD" ++ show d)
-#endif {- Data Parallel Haskell -}
\end{code}
-@typeOfPrimOp@ duplicates some work of @primOpId@, but since we
+@primOpType@ duplicates some work of @primOpId@, but since we
grab types pretty often...
\begin{code}
-typeOfPrimOp :: PrimOp -> UniType
+primOpType :: PrimOp -> Type
-#ifdef DPH
-typeOfPrimOp (PodNPrimOp d p)
- = mkPodizedPodNTy d (typeOfPrimOp p)
-#endif {- Data Parallel Haskell -}
-
-typeOfPrimOp op
+primOpType op
= case (primOpInfo op) of
Dyadic str ty -> dyadic_fun_ty ty
Monadic str ty -> monadic_fun_ty ty
- Compare str ty -> prim_compare_fun_ty ty
- Coerce str ty1 ty2 -> UniFun ty1 ty2
-
- PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
- mkForallTy tyvars (glueTyArgs arg_tys (applyTyCon prim_tycon res_tys))
-
- AlgResult str tyvars arg_tys tycon res_tys ->
- mkForallTy tyvars (glueTyArgs arg_tys (applyTyCon tycon res_tys))
-\end{code}
-
-\begin{code}
-primOpId op
- = case (primOpInfo op) of
- Dyadic str ty ->
- mk_prim_Id op pRELUDE_BUILTIN str [] [ty,ty] (dyadic_fun_ty ty) 2
-
- Monadic str ty ->
- mk_prim_Id op pRELUDE_BUILTIN str [] [ty] (monadic_fun_ty ty) 1
-
- Compare str ty ->
- mk_prim_Id op pRELUDE_BUILTIN str [] [ty,ty] (prim_compare_fun_ty ty) 2
-
- Coerce str ty1 ty2 ->
- mk_prim_Id op pRELUDE_BUILTIN str [] [ty1] (UniFun ty1 ty2) 1
+ Compare str ty -> compare_fun_ty ty
+ Coerce str ty1 ty2 -> mkFunTys [ty1] ty2
PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
- mk_prim_Id op pRELUDE_BUILTIN str
- tyvars
- arg_tys
- (mkForallTy tyvars (glueTyArgs arg_tys (applyTyCon prim_tycon res_tys)))
- (length arg_tys) -- arity
+ mkForAllTys tyvars (glueTyArgs arg_tys (applyTyCon prim_tycon res_tys))
AlgResult str tyvars arg_tys tycon res_tys ->
- mk_prim_Id op pRELUDE_BUILTIN str
- tyvars
- arg_tys
- (mkForallTy tyvars (glueTyArgs arg_tys (applyTyCon tycon res_tys)))
- (length arg_tys) -- arity
-
-#ifdef DPH
- PodNInfo d i -> panic "primOpId : Oi lazy, PodNInfo needs sorting out"
-#endif {- Data Parallel Haskell -}
- where
- mk_prim_Id prim_op mod name tyvar_tmpls arg_tys ty arity
- = mkPreludeId
- (mkPrimOpIdUnique prim_op)
- (mkPreludeCoreName mod name)
- ty
- (noIdInfo
- `addInfo` (mkArityInfo arity)
- `addInfo_UF` (mkUnfolding EssentialUnfolding
- (mk_prim_unfold prim_op tyvar_tmpls arg_tys)))
-\end{code}
-
-The functions to make common unfoldings are tedious.
-
-\begin{code}
-mk_prim_unfold :: PrimOp -> [TyVarTemplate] -> [UniType] -> PlainCoreExpr{-template-}
-
-mk_prim_unfold prim_op tv_tmpls arg_tys
- = let
- (inst_env, tyvars, tyvar_tys) = instantiateTyVarTemplates tv_tmpls (map getTheUnique tv_tmpls)
- inst_arg_tys = map (instantiateTauTy inst_env) arg_tys
- vars = mkTemplateLocals inst_arg_tys
- in
- foldr CoTyLam (mkCoLam vars
- (CoPrim prim_op tyvar_tys [CoVarAtom v | v <- vars]))
- tyvars
+ mkForAllTys tyvars (glueTyArgs arg_tys (applyTyCon tycon res_tys))
\end{code}
\begin{code}
data PrimOpResultInfo
- = ReturnsPrim PrimKind
+ = ReturnsPrim PrimRep
| ReturnsAlg TyCon
-- ToDo: Deal with specialised PrimOps
getPrimOpResultInfo op
= case (primOpInfo op) of
- Dyadic _ ty -> ReturnsPrim (kindFromType ty)
- Monadic _ ty -> ReturnsPrim (kindFromType ty)
+ Dyadic _ ty -> ReturnsPrim (primRepFromType ty)
+ Monadic _ ty -> ReturnsPrim (primRepFromType ty)
Compare _ ty -> ReturnsAlg boolTyCon
- Coerce _ _ ty -> ReturnsPrim (kindFromType ty)
+ Coerce _ _ ty -> ReturnsPrim (primRepFromType ty)
PrimResult _ _ _ _ kind _ -> ReturnsPrim kind
AlgResult _ _ _ tycon _ -> ReturnsAlg tycon
-#ifdef DPH
- PodNInfo d i -> panic "getPrimOpResultInfo:PodNInfo"
-#endif {- Data Parallel Haskell -}
isCompareOp :: PrimOp -> Bool
Utils:
\begin{code}
-dyadic_fun_ty ty = ty `UniFun` (ty `UniFun` ty)
-monadic_fun_ty ty = ty `UniFun` ty
-
-compare_fun_ty ty = ty `UniFun` (ty `UniFun` boolTy)
-prim_compare_fun_ty ty = ty `UniFun` (ty `UniFun` boolTy)
+dyadic_fun_ty ty = mkFunTys [ty, ty] ty
+monadic_fun_ty ty = mkFunTys [ty] ty
+compare_fun_ty ty = mkFunTys [ty, ty] boolTy
\end{code}
Output stuff:
pp_tys
= ppBesides [ppStr " { [",
- ppIntersperse pp'SP{-'-} (map (pprParendUniType sty) arg_tys),
- ppRbrack, ppSP, pprParendUniType sty res_ty, ppStr " })"]
+ ppIntersperse pp'SP{-'-} (map (pprParendType sty) arg_tys),
+ ppRbrack, ppSP, pprParendType sty res_ty, ppStr " })"]
in
ppBesides [ppStr before, ppPStr fun, after, pp_tys]
-#ifdef DPH
- = fun -- Comment buggers up machine code :-) -- ToDo:DPH
-#endif {- Data Parallel Haskell -}
pprPrimOp sty other_op
= let
projects / ghc-hetmet.git / blobdiff