diff options
author | Simon Marlow <simonmar@microsoft.com> | 2006-04-07 02:05:11 +0000 |
---|---|---|
committer | Simon Marlow <simonmar@microsoft.com> | 2006-04-07 02:05:11 +0000 |
commit | 0065d5ab628975892cea1ec7303f968c3338cbe1 (patch) | |
tree | 8e2afe0ab48ee33cf95009809d67c9649573ef92 /compiler/prelude | |
parent | 28a464a75e14cece5db40f2765a29348273ff2d2 (diff) | |
download | haskell-0065d5ab628975892cea1ec7303f968c3338cbe1.tar.gz |
Reorganisation of the source tree
Most of the other users of the fptools build system have migrated to
Cabal, and with the move to darcs we can now flatten the source tree
without losing history, so here goes.
The main change is that the ghc/ subdir is gone, and most of what it
contained is now at the top level. The build system now makes no
pretense at being multi-project, it is just the GHC build system.
No doubt this will break many things, and there will be a period of
instability while we fix the dependencies. A straightforward build
should work, but I haven't yet fixed binary/source distributions.
Changes to the Building Guide will follow, too.
Diffstat (limited to 'compiler/prelude')
-rw-r--r-- | compiler/prelude/ForeignCall.lhs | 423 | ||||
-rw-r--r-- | compiler/prelude/PrelInfo.lhs | 139 | ||||
-rw-r--r-- | compiler/prelude/PrelNames.lhs | 1063 | ||||
-rw-r--r-- | compiler/prelude/PrelRules.lhs | 447 | ||||
-rw-r--r-- | compiler/prelude/PrimOp.lhs | 461 | ||||
-rw-r--r-- | compiler/prelude/TysPrim.lhs | 392 | ||||
-rw-r--r-- | compiler/prelude/TysWiredIn.lhs | 549 | ||||
-rw-r--r-- | compiler/prelude/primops.txt.pp | 1687 |
8 files changed, 5161 insertions, 0 deletions
diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs new file mode 100644 index 0000000000..2c90a7dc6e --- /dev/null +++ b/compiler/prelude/ForeignCall.lhs @@ -0,0 +1,423 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[Foreign]{Foreign calls} + +\begin{code} +module ForeignCall ( + ForeignCall(..), + Safety(..), playSafe, playThreadSafe, + + CExportSpec(..), CLabelString, isCLabelString, pprCLabelString, + CCallSpec(..), + CCallTarget(..), isDynamicTarget, + CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute, + + DNCallSpec(..), DNKind(..), DNType(..), + withDNTypes + ) where + +#include "HsVersions.h" + +import FastString ( FastString, unpackFS ) +import Char ( isAlphaNum ) +import Binary +import Outputable +\end{code} + + +%************************************************************************ +%* * +\subsubsection{Data types} +%* * +%************************************************************************ + +\begin{code} +data ForeignCall + = CCall CCallSpec + | DNCall DNCallSpec + deriving( Eq ) -- We compare them when seeing if an interface + -- has changed (for versioning purposes) + {-! derive: Binary !-} + +-- We may need more clues to distinguish foreign calls +-- but this simple printer will do for now +instance Outputable ForeignCall where + ppr (CCall cc) = ppr cc + ppr (DNCall dn) = ppr dn +\end{code} + + +\begin{code} +data Safety + = PlaySafe -- Might invoke Haskell GC, or do a call back, or + -- switch threads, etc. So make sure things are + -- tidy before the call + Bool -- => True, external function is also re-entrant. + -- [if supported, RTS arranges for the external call + -- to be executed by a separate OS thread, i.e., + -- _concurrently_ to the execution of other Haskell threads.] + + | PlayRisky -- None of the above can happen; the call will return + -- without interacting with the runtime system at all + deriving( Eq, Show ) + -- Show used just for Show Lex.Token, I think + {-! derive: Binary !-} + +instance Outputable Safety where + ppr (PlaySafe False) = ptext SLIT("safe") + ppr (PlaySafe True) = ptext SLIT("threadsafe") + ppr PlayRisky = ptext SLIT("unsafe") + +playSafe :: Safety -> Bool +playSafe PlaySafe{} = True +playSafe PlayRisky = False + +playThreadSafe :: Safety -> Bool +playThreadSafe (PlaySafe x) = x +playThreadSafe _ = False +\end{code} + + +%************************************************************************ +%* * +\subsubsection{Calling C} +%* * +%************************************************************************ + +\begin{code} +data CExportSpec + = CExportStatic -- foreign export ccall foo :: ty + CLabelString -- C Name of exported function + CCallConv + {-! derive: Binary !-} + +data CCallSpec + = CCallSpec CCallTarget -- What to call + CCallConv -- Calling convention to use. + Safety + deriving( Eq ) + {-! derive: Binary !-} +\end{code} + +The call target: + +\begin{code} +data CCallTarget + = StaticTarget CLabelString -- An "unboxed" ccall# to `fn'. + | DynamicTarget -- First argument (an Addr#) is the function pointer + deriving( Eq ) + {-! derive: Binary !-} + +isDynamicTarget :: CCallTarget -> Bool +isDynamicTarget DynamicTarget = True +isDynamicTarget other = False +\end{code} + + +Stuff to do with calling convention: + +ccall: Caller allocates parameters, *and* deallocates them. + +stdcall: Caller allocates parameters, callee deallocates. + Function name has @N after it, where N is number of arg bytes + e.g. _Foo@8 + +ToDo: The stdcall calling convention is x86 (win32) specific, +so perhaps we should emit a warning if it's being used on other +platforms. + +\begin{code} +data CCallConv = CCallConv | StdCallConv + deriving (Eq) + {-! derive: Binary !-} + +instance Outputable CCallConv where + ppr StdCallConv = ptext SLIT("stdcall") + ppr CCallConv = ptext SLIT("ccall") + +defaultCCallConv :: CCallConv +defaultCCallConv = CCallConv + +ccallConvToInt :: CCallConv -> Int +ccallConvToInt StdCallConv = 0 +ccallConvToInt CCallConv = 1 +\end{code} + +Generate the gcc attribute corresponding to the given +calling convention (used by PprAbsC): + +\begin{code} +ccallConvAttribute :: CCallConv -> String +ccallConvAttribute StdCallConv = "__attribute__((__stdcall__))" +ccallConvAttribute CCallConv = "" +\end{code} + +\begin{code} +type CLabelString = FastString -- A C label, completely unencoded + +pprCLabelString :: CLabelString -> SDoc +pprCLabelString lbl = ftext lbl + +isCLabelString :: CLabelString -> Bool -- Checks to see if this is a valid C label +isCLabelString lbl + = all ok (unpackFS lbl) + where + ok c = isAlphaNum c || c == '_' || c == '.' + -- The '.' appears in e.g. "foo.so" in the + -- module part of a ExtName. Maybe it should be separate +\end{code} + + +Printing into C files: + +\begin{code} +instance Outputable CExportSpec where + ppr (CExportStatic str _) = pprCLabelString str + +instance Outputable CCallSpec where + ppr (CCallSpec fun cconv safety) + = hcat [ ifPprDebug callconv, ppr_fun fun ] + where + callconv = text "{-" <> ppr cconv <> text "-}" + + gc_suf | playSafe safety = text "_GC" + | otherwise = empty + + ppr_fun DynamicTarget = text "__dyn_ccall" <> gc_suf <+> text "\"\"" + ppr_fun (StaticTarget fn) = text "__ccall" <> gc_suf <+> pprCLabelString fn +\end{code} + + +%************************************************************************ +%* * +\subsubsection{.NET interop} +%* * +%************************************************************************ + +\begin{code} +data DNCallSpec = + DNCallSpec Bool -- True => static method/field + DNKind -- what type of access + String -- assembly + String -- fully qualified method/field name. + [DNType] -- argument types. + DNType -- result type. + deriving ( Eq ) + {-! derive: Binary !-} + +data DNKind + = DNMethod + | DNField + | DNConstructor + deriving ( Eq ) + {-! derive: Binary !-} + +data DNType + = DNByte + | DNBool + | DNChar + | DNDouble + | DNFloat + | DNInt + | DNInt8 + | DNInt16 + | DNInt32 + | DNInt64 + | DNWord8 + | DNWord16 + | DNWord32 + | DNWord64 + | DNPtr + | DNUnit + | DNObject + | DNString + deriving ( Eq ) + {-! derive: Binary !-} + +withDNTypes :: DNCallSpec -> [DNType] -> DNType -> DNCallSpec +withDNTypes (DNCallSpec isStatic k assem nm _ _) argTys resTy + = DNCallSpec isStatic k assem nm argTys resTy + +instance Outputable DNCallSpec where + ppr (DNCallSpec isStatic kind ass nm _ _ ) + = char '"' <> + (if isStatic then text "static" else empty) <+> + (text (case kind of { DNMethod -> "method" ; DNField -> "field"; DNConstructor -> "ctor" })) <+> + (if null ass then char ' ' else char '[' <> text ass <> char ']') <> + text nm <> + char '"' +\end{code} + + + +%************************************************************************ +%* * +\subsubsection{Misc} +%* * +%************************************************************************ + +\begin{code} +{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-} +instance Binary ForeignCall where + put_ bh (CCall aa) = do + putByte bh 0 + put_ bh aa + put_ bh (DNCall ab) = do + putByte bh 1 + put_ bh ab + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (CCall aa) + _ -> do ab <- get bh + return (DNCall ab) + +instance Binary Safety where + put_ bh (PlaySafe aa) = do + putByte bh 0 + put_ bh aa + put_ bh PlayRisky = do + putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (PlaySafe aa) + _ -> do return PlayRisky + +instance Binary CExportSpec where + put_ bh (CExportStatic aa ab) = do + put_ bh aa + put_ bh ab + get bh = do + aa <- get bh + ab <- get bh + return (CExportStatic aa ab) + +instance Binary CCallSpec where + put_ bh (CCallSpec aa ab ac) = do + put_ bh aa + put_ bh ab + put_ bh ac + get bh = do + aa <- get bh + ab <- get bh + ac <- get bh + return (CCallSpec aa ab ac) + +instance Binary CCallTarget where + put_ bh (StaticTarget aa) = do + putByte bh 0 + put_ bh aa + put_ bh DynamicTarget = do + putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (StaticTarget aa) + _ -> do return DynamicTarget + +instance Binary CCallConv where + put_ bh CCallConv = do + putByte bh 0 + put_ bh StdCallConv = do + putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> do return CCallConv + _ -> do return StdCallConv + +instance Binary DNCallSpec where + put_ bh (DNCallSpec isStatic kind ass nm _ _) = do + put_ bh isStatic + put_ bh kind + put_ bh ass + put_ bh nm + get bh = do + isStatic <- get bh + kind <- get bh + ass <- get bh + nm <- get bh + return (DNCallSpec isStatic kind ass nm [] undefined) + +instance Binary DNKind where + put_ bh DNMethod = do + putByte bh 0 + put_ bh DNField = do + putByte bh 1 + put_ bh DNConstructor = do + putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> do return DNMethod + 1 -> do return DNField + _ -> do return DNConstructor + +instance Binary DNType where + put_ bh DNByte = do + putByte bh 0 + put_ bh DNBool = do + putByte bh 1 + put_ bh DNChar = do + putByte bh 2 + put_ bh DNDouble = do + putByte bh 3 + put_ bh DNFloat = do + putByte bh 4 + put_ bh DNInt = do + putByte bh 5 + put_ bh DNInt8 = do + putByte bh 6 + put_ bh DNInt16 = do + putByte bh 7 + put_ bh DNInt32 = do + putByte bh 8 + put_ bh DNInt64 = do + putByte bh 9 + put_ bh DNWord8 = do + putByte bh 10 + put_ bh DNWord16 = do + putByte bh 11 + put_ bh DNWord32 = do + putByte bh 12 + put_ bh DNWord64 = do + putByte bh 13 + put_ bh DNPtr = do + putByte bh 14 + put_ bh DNUnit = do + putByte bh 15 + put_ bh DNObject = do + putByte bh 16 + put_ bh DNString = do + putByte bh 17 + + get bh = do + h <- getByte bh + case h of + 0 -> return DNByte + 1 -> return DNBool + 2 -> return DNChar + 3 -> return DNDouble + 4 -> return DNFloat + 5 -> return DNInt + 6 -> return DNInt8 + 7 -> return DNInt16 + 8 -> return DNInt32 + 9 -> return DNInt64 + 10 -> return DNWord8 + 11 -> return DNWord16 + 12 -> return DNWord32 + 13 -> return DNWord64 + 14 -> return DNPtr + 15 -> return DNUnit + 16 -> return DNObject + 17 -> return DNString + +-- Imported from other files :- + +\end{code} diff --git a/compiler/prelude/PrelInfo.lhs b/compiler/prelude/PrelInfo.lhs new file mode 100644 index 0000000000..31457b2b63 --- /dev/null +++ b/compiler/prelude/PrelInfo.lhs @@ -0,0 +1,139 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[PrelInfo]{The @PrelInfo@ interface to the compiler's prelude knowledge} + +\begin{code} +module PrelInfo ( + module MkId, + + ghcPrimExports, + wiredInThings, basicKnownKeyNames, + primOpId, + + -- Random other things + maybeCharLikeCon, maybeIntLikeCon, + + -- Class categories + isNumericClass, isStandardClass + + ) where + +#include "HsVersions.h" + +import PrelNames ( basicKnownKeyNames, + hasKey, charDataConKey, intDataConKey, + numericClassKeys, standardClassKeys ) + +import PrimOp ( PrimOp, allThePrimOps, primOpOcc, primOpTag, maxPrimOpTag ) +import DataCon ( DataCon ) +import Id ( Id, idName ) +import MkId ( mkPrimOpId, wiredInIds ) +import MkId -- All of it, for re-export +import Name ( nameOccName ) +import TysPrim ( primTyCons ) +import TysWiredIn ( wiredInTyCons ) +import HscTypes ( TyThing(..), implicitTyThings, GenAvailInfo(..), RdrAvailInfo ) +import Class ( Class, classKey ) +import Type ( funTyCon ) +import TyCon ( tyConName ) +import Util ( isIn ) + +import Array ( Array, array, (!) ) +\end{code} + +%************************************************************************ +%* * +\subsection[builtinNameInfo]{Lookup built-in names} +%* * +%************************************************************************ + +We have two ``builtin name funs,'' one to look up @TyCons@ and +@Classes@, the other to look up values. + +\begin{code} +wiredInThings :: [TyThing] +wiredInThings + = concat + [ -- Wired in TyCons and their implicit Ids + tycon_things + , concatMap implicitTyThings tycon_things + + -- Wired in Ids + , map AnId wiredInIds + + -- PrimOps + , map (AnId . mkPrimOpId) allThePrimOps + ] + where + tycon_things = map ATyCon ([funTyCon] ++ primTyCons ++ wiredInTyCons) +\end{code} + +We let a lot of "non-standard" values be visible, so that we can make +sense of them in interface pragmas. It's cool, though they all have +"non-standard" names, so they won't get past the parser in user code. + +%************************************************************************ +%* * + PrimOpIds +%* * +%************************************************************************ + +\begin{code} +primOpIds :: Array Int Id -- Indexed by PrimOp tag +primOpIds = array (1,maxPrimOpTag) [ (primOpTag op, mkPrimOpId op) + | op <- allThePrimOps] + +primOpId :: PrimOp -> Id +primOpId op = primOpIds ! primOpTag op +\end{code} + + +%************************************************************************ +%* * +\subsection{Export lists for pseudo-modules (GHC.Prim)} +%* * +%************************************************************************ + +GHC.Prim "exports" all the primops and primitive types, some +wired-in Ids. + +\begin{code} +ghcPrimExports :: [RdrAvailInfo] +ghcPrimExports + = map (Avail . nameOccName . idName) ghcPrimIds ++ + map (Avail . primOpOcc) allThePrimOps ++ + [ AvailTC occ [occ] | + n <- funTyCon : primTyCons, let occ = nameOccName (tyConName n) + ] +\end{code} + + +%************************************************************************ +%* * +\subsection{Built-in keys} +%* * +%************************************************************************ + +ToDo: make it do the ``like'' part properly (as in 0.26 and before). + +\begin{code} +maybeCharLikeCon, maybeIntLikeCon :: DataCon -> Bool +maybeCharLikeCon con = con `hasKey` charDataConKey +maybeIntLikeCon con = con `hasKey` intDataConKey +\end{code} + + +%************************************************************************ +%* * +\subsection{Class predicates} +%* * +%************************************************************************ + +\begin{code} +isNumericClass, isStandardClass :: Class -> Bool + +isNumericClass clas = classKey clas `is_elem` numericClassKeys +isStandardClass clas = classKey clas `is_elem` standardClassKeys +is_elem = isIn "is_X_Class" +\end{code} diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs new file mode 100644 index 0000000000..d656fbf18e --- /dev/null +++ b/compiler/prelude/PrelNames.lhs @@ -0,0 +1,1063 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[PrelNames]{Definitions of prelude modules and names} + + +Nota Bene: all Names defined in here should come from the base package + +* ModuleNames for prelude modules, + e.g. pREL_BASE_Name :: ModuleName + +* Modules for prelude modules + e.g. pREL_Base :: Module + +* Uniques for Ids, DataCons, TyCons and Classes that the compiler + "knows about" in some way + e.g. intTyConKey :: Unique + minusClassOpKey :: Unique + +* Names for Ids, DataCons, TyCons and Classes that the compiler + "knows about" in some way + e.g. intTyConName :: Name + minusName :: Name + One of these Names contains + (a) the module and occurrence name of the thing + (b) its Unique + The may way the compiler "knows about" one of these things is + where the type checker or desugarer needs to look it up. For + example, when desugaring list comprehensions the desugarer + needs to conjure up 'foldr'. It does this by looking up + foldrName in the environment. + +* RdrNames for Ids, DataCons etc that the compiler may emit into + generated code (e.g. for deriving). It's not necessary to know + the uniques for these guys, only their names + + +\begin{code} +module PrelNames ( + Unique, Uniquable(..), hasKey, -- Re-exported for convenience + + ----------------------------------------------------------- + module PrelNames, -- A huge bunch of (a) Names, e.g. intTyConName + -- (b) Uniques e.g. intTyConKey + -- (c) Groups of classes and types + -- (d) miscellaneous things + -- So many that we export them all + ) where + +#include "HsVersions.h" + +import Module ( Module, mkModule ) +import OccName ( dataName, tcName, clsName, varName, mkOccNameFS, + mkVarOccFS ) +import RdrName ( RdrName, nameRdrName, mkOrig, rdrNameOcc, mkUnqual ) +import Unique ( Unique, Uniquable(..), hasKey, + mkPreludeMiscIdUnique, mkPreludeDataConUnique, + mkPreludeTyConUnique, mkPreludeClassUnique, + mkTupleTyConUnique + ) +import BasicTypes ( Boxity(..), Arity ) +import Name ( Name, mkInternalName, mkExternalName, nameModule ) +import SrcLoc ( noSrcLoc ) +import FastString +\end{code} + + +%************************************************************************ +%* * +\subsection{Local Names} +%* * +%************************************************************************ + +This *local* name is used by the interactive stuff + +\begin{code} +itName uniq = mkInternalName uniq (mkOccNameFS varName FSLIT("it")) noSrcLoc +\end{code} + +\begin{code} +-- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly +-- during compiler debugging. +mkUnboundName :: RdrName -> Name +mkUnboundName rdr_name = mkInternalName unboundKey (rdrNameOcc rdr_name) noSrcLoc + +isUnboundName :: Name -> Bool +isUnboundName name = name `hasKey` unboundKey +\end{code} + + +%************************************************************************ +%* * +\subsection{Known key Names} +%* * +%************************************************************************ + +This section tells what the compiler knows about the assocation of +names with uniques. These ones are the *non* wired-in ones. The +wired in ones are defined in TysWiredIn etc. + +\begin{code} +basicKnownKeyNames :: [Name] +basicKnownKeyNames + = genericTyConNames + ++ typeableClassNames + ++ [ -- Type constructors (synonyms especially) + ioTyConName, ioDataConName, + runMainIOName, + orderingTyConName, + rationalTyConName, + ratioDataConName, + ratioTyConName, + byteArrayTyConName, + mutableByteArrayTyConName, + integerTyConName, smallIntegerDataConName, largeIntegerDataConName, + + -- Classes. *Must* include: + -- classes that are grabbed by key (e.g., eqClassKey) + -- classes in "Class.standardClassKeys" (quite a few) + eqClassName, -- mentioned, derivable + ordClassName, -- derivable + boundedClassName, -- derivable + numClassName, -- mentioned, numeric + enumClassName, -- derivable + monadClassName, + functorClassName, + realClassName, -- numeric + integralClassName, -- numeric + fractionalClassName, -- numeric + floatingClassName, -- numeric + realFracClassName, -- numeric + realFloatClassName, -- numeric + dataClassName, + + -- Numeric stuff + negateName, minusName, + fromRationalName, fromIntegerName, + geName, eqName, + + -- Enum stuff + enumFromName, enumFromThenName, + enumFromThenToName, enumFromToName, + enumFromToPName, enumFromThenToPName, + + -- Monad stuff + thenIOName, bindIOName, returnIOName, failIOName, + failMName, bindMName, thenMName, returnMName, + + -- MonadRec stuff + mfixName, + + -- Arrow stuff + arrAName, composeAName, firstAName, + appAName, choiceAName, loopAName, + + -- Ix stuff + ixClassName, + + -- Show stuff + showClassName, + + -- Read stuff + readClassName, + + -- Stable pointers + newStablePtrName, + + -- Strings and lists + unpackCStringName, unpackCStringAppendName, + unpackCStringFoldrName, unpackCStringUtf8Name, + + -- List operations + concatName, filterName, + zipName, foldrName, buildName, augmentName, appendName, + + -- Parallel array operations + nullPName, lengthPName, replicatePName, mapPName, + filterPName, zipPName, crossPName, indexPName, + toPName, bpermutePName, bpermuteDftPName, indexOfPName, + + -- FFI primitive types that are not wired-in. + stablePtrTyConName, ptrTyConName, funPtrTyConName, addrTyConName, + int8TyConName, int16TyConName, int32TyConName, int64TyConName, + wordTyConName, word8TyConName, word16TyConName, word32TyConName, word64TyConName, + + -- Others + otherwiseIdName, + plusIntegerName, timesIntegerName, + eqStringName, assertName, breakpointName, assertErrorName, + runSTRepName, + printName, fstName, sndName, + + -- MonadFix + monadFixClassName, mfixName, + + -- Splittable class + splittableClassName, splitName, + + -- Other classes + randomClassName, randomGenClassName, monadPlusClassName, + + -- Booleans + andName, orName + + -- The Either type + , eitherTyConName, leftDataConName, rightDataConName + + -- dotnet interop + , objectTyConName, marshalObjectName, unmarshalObjectName + , marshalStringName, unmarshalStringName, checkDotnetResName + ] + +genericTyConNames :: [Name] +genericTyConNames = [crossTyConName, plusTyConName, genUnitTyConName] +\end{code} + + +%************************************************************************ +%* * +\subsection{Module names} +%* * +%************************************************************************ + + +--MetaHaskell Extension Add a new module here +\begin{code} +pRELUDE = mkModule "Prelude" +gHC_PRIM = mkModule "GHC.Prim" -- Primitive types and values +pREL_BASE = mkModule "GHC.Base" +pREL_ENUM = mkModule "GHC.Enum" +pREL_SHOW = mkModule "GHC.Show" +pREL_READ = mkModule "GHC.Read" +pREL_NUM = mkModule "GHC.Num" +pREL_LIST = mkModule "GHC.List" +pREL_PARR = mkModule "GHC.PArr" +pREL_TUP = mkModule "Data.Tuple" +pREL_EITHER = mkModule "Data.Either" +pREL_PACK = mkModule "GHC.Pack" +pREL_CONC = mkModule "GHC.Conc" +pREL_IO_BASE = mkModule "GHC.IOBase" +pREL_ST = mkModule "GHC.ST" +pREL_ARR = mkModule "GHC.Arr" +pREL_BYTEARR = mkModule "PrelByteArr" +pREL_STABLE = mkModule "GHC.Stable" +pREL_ADDR = mkModule "GHC.Addr" +pREL_PTR = mkModule "GHC.Ptr" +pREL_ERR = mkModule "GHC.Err" +pREL_REAL = mkModule "GHC.Real" +pREL_FLOAT = mkModule "GHC.Float" +pREL_TOP_HANDLER= mkModule "GHC.TopHandler" +sYSTEM_IO = mkModule "System.IO" +dYNAMIC = mkModule "Data.Dynamic" +tYPEABLE = mkModule "Data.Typeable" +gENERICS = mkModule "Data.Generics.Basics" +dOTNET = mkModule "GHC.Dotnet" + +rEAD_PREC = mkModule "Text.ParserCombinators.ReadPrec" +lEX = mkModule "Text.Read.Lex" + +mAIN = mkModule "Main" +pREL_INT = mkModule "GHC.Int" +pREL_WORD = mkModule "GHC.Word" +mONAD = mkModule "Control.Monad" +mONAD_FIX = mkModule "Control.Monad.Fix" +aRROW = mkModule "Control.Arrow" +aDDR = mkModule "Addr" +rANDOM = mkModule "System.Random" + +gLA_EXTS = mkModule "GHC.Exts" +rOOT_MAIN = mkModule ":Main" -- Root module for initialisation + -- The ':xxx' makes a module name that the user can never + -- use himself. The z-encoding for ':' is "ZC", so the z-encoded + -- module name still starts with a capital letter, which keeps + -- the z-encoded version consistent. + +iNTERACTIVE = mkModule ":Interactive" +thFAKE = mkModule ":THFake" +\end{code} + +%************************************************************************ +%* * +\subsection{Constructing the names of tuples +%* * +%************************************************************************ + +\begin{code} +mkTupleModule :: Boxity -> Arity -> Module +mkTupleModule Boxed 0 = pREL_BASE +mkTupleModule Boxed _ = pREL_TUP +mkTupleModule Unboxed _ = gHC_PRIM +\end{code} + + +%************************************************************************ +%* * + RdrNames +%* * +%************************************************************************ + +\begin{code} +main_RDR_Unqual = mkUnqual varName FSLIT("main") + -- We definitely don't want an Orig RdrName, because + -- main might, in principle, be imported into module Main + +eq_RDR = nameRdrName eqName +ge_RDR = nameRdrName geName +ne_RDR = varQual_RDR pREL_BASE FSLIT("/=") +le_RDR = varQual_RDR pREL_BASE FSLIT("<=") +gt_RDR = varQual_RDR pREL_BASE FSLIT(">") +compare_RDR = varQual_RDR pREL_BASE FSLIT("compare") +ltTag_RDR = dataQual_RDR pREL_BASE FSLIT("LT") +eqTag_RDR = dataQual_RDR pREL_BASE FSLIT("EQ") +gtTag_RDR = dataQual_RDR pREL_BASE FSLIT("GT") + +eqClass_RDR = nameRdrName eqClassName +numClass_RDR = nameRdrName numClassName +ordClass_RDR = nameRdrName ordClassName +enumClass_RDR = nameRdrName enumClassName +monadClass_RDR = nameRdrName monadClassName + +map_RDR = varQual_RDR pREL_BASE FSLIT("map") +append_RDR = varQual_RDR pREL_BASE FSLIT("++") + +foldr_RDR = nameRdrName foldrName +build_RDR = nameRdrName buildName +returnM_RDR = nameRdrName returnMName +bindM_RDR = nameRdrName bindMName +failM_RDR = nameRdrName failMName + +and_RDR = nameRdrName andName + +left_RDR = nameRdrName leftDataConName +right_RDR = nameRdrName rightDataConName + +fromEnum_RDR = varQual_RDR pREL_ENUM FSLIT("fromEnum") +toEnum_RDR = varQual_RDR pREL_ENUM FSLIT("toEnum") + +enumFrom_RDR = nameRdrName enumFromName +enumFromTo_RDR = nameRdrName enumFromToName +enumFromThen_RDR = nameRdrName enumFromThenName +enumFromThenTo_RDR = nameRdrName enumFromThenToName + +ratioDataCon_RDR = nameRdrName ratioDataConName +plusInteger_RDR = nameRdrName plusIntegerName +timesInteger_RDR = nameRdrName timesIntegerName + +ioDataCon_RDR = nameRdrName ioDataConName + +eqString_RDR = nameRdrName eqStringName +unpackCString_RDR = nameRdrName unpackCStringName +unpackCStringFoldr_RDR = nameRdrName unpackCStringFoldrName +unpackCStringUtf8_RDR = nameRdrName unpackCStringUtf8Name + +newStablePtr_RDR = nameRdrName newStablePtrName +addrDataCon_RDR = dataQual_RDR aDDR FSLIT("A#") +wordDataCon_RDR = dataQual_RDR pREL_WORD FSLIT("W#") + +bindIO_RDR = nameRdrName bindIOName +returnIO_RDR = nameRdrName returnIOName + +fromInteger_RDR = nameRdrName fromIntegerName +fromRational_RDR = nameRdrName fromRationalName +minus_RDR = nameRdrName minusName +times_RDR = varQual_RDR pREL_NUM FSLIT("*") +plus_RDR = varQual_RDR pREL_NUM FSLIT("+") + +compose_RDR = varQual_RDR pREL_BASE FSLIT(".") + +not_RDR = varQual_RDR pREL_BASE FSLIT("not") +getTag_RDR = varQual_RDR pREL_BASE FSLIT("getTag") +succ_RDR = varQual_RDR pREL_ENUM FSLIT("succ") +pred_RDR = varQual_RDR pREL_ENUM FSLIT("pred") +minBound_RDR = varQual_RDR pREL_ENUM FSLIT("minBound") +maxBound_RDR = varQual_RDR pREL_ENUM FSLIT("maxBound") +range_RDR = varQual_RDR pREL_ARR FSLIT("range") +inRange_RDR = varQual_RDR pREL_ARR FSLIT("inRange") +index_RDR = varQual_RDR pREL_ARR FSLIT("index") +unsafeIndex_RDR = varQual_RDR pREL_ARR FSLIT("unsafeIndex") +unsafeRangeSize_RDR = varQual_RDR pREL_ARR FSLIT("unsafeRangeSize") + +readList_RDR = varQual_RDR pREL_READ FSLIT("readList") +readListDefault_RDR = varQual_RDR pREL_READ FSLIT("readListDefault") +readListPrec_RDR = varQual_RDR pREL_READ FSLIT("readListPrec") +readListPrecDefault_RDR = varQual_RDR pREL_READ FSLIT("readListPrecDefault") +readPrec_RDR = varQual_RDR pREL_READ FSLIT("readPrec") +parens_RDR = varQual_RDR pREL_READ FSLIT("parens") +choose_RDR = varQual_RDR pREL_READ FSLIT("choose") +lexP_RDR = varQual_RDR pREL_READ FSLIT("lexP") + +punc_RDR = dataQual_RDR lEX FSLIT("Punc") +ident_RDR = dataQual_RDR lEX FSLIT("Ident") +symbol_RDR = dataQual_RDR lEX FSLIT("Symbol") + +step_RDR = varQual_RDR rEAD_PREC FSLIT("step") +alt_RDR = varQual_RDR rEAD_PREC FSLIT("+++") +reset_RDR = varQual_RDR rEAD_PREC FSLIT("reset") +prec_RDR = varQual_RDR rEAD_PREC FSLIT("prec") + +showList_RDR = varQual_RDR pREL_SHOW FSLIT("showList") +showList___RDR = varQual_RDR pREL_SHOW FSLIT("showList__") +showsPrec_RDR = varQual_RDR pREL_SHOW FSLIT("showsPrec") +showString_RDR = varQual_RDR pREL_SHOW FSLIT("showString") +showSpace_RDR = varQual_RDR pREL_SHOW FSLIT("showSpace") +showParen_RDR = varQual_RDR pREL_SHOW FSLIT("showParen") + +typeOf_RDR = varQual_RDR tYPEABLE FSLIT("typeOf") +mkTypeRep_RDR = varQual_RDR tYPEABLE FSLIT("mkTyConApp") +mkTyConRep_RDR = varQual_RDR tYPEABLE FSLIT("mkTyCon") + +undefined_RDR = varQual_RDR pREL_ERR FSLIT("undefined") + +crossDataCon_RDR = dataQual_RDR pREL_BASE FSLIT(":*:") +inlDataCon_RDR = dataQual_RDR pREL_BASE FSLIT("Inl") +inrDataCon_RDR = dataQual_RDR pREL_BASE FSLIT("Inr") +genUnitDataCon_RDR = dataQual_RDR pREL_BASE FSLIT("Unit") + +---------------------- +varQual_RDR mod str = mkOrig mod (mkOccNameFS varName str) +tcQual_RDR mod str = mkOrig mod (mkOccNameFS tcName str) +clsQual_RDR mod str = mkOrig mod (mkOccNameFS clsName str) +dataQual_RDR mod str = mkOrig mod (mkOccNameFS dataName str) +\end{code} + +%************************************************************************ +%* * +\subsection{Known-key names} +%* * +%************************************************************************ + +Many of these Names are not really "built in", but some parts of the +compiler (notably the deriving mechanism) need to mention their names, +and it's convenient to write them all down in one place. + +--MetaHaskell Extension add the constrs and the lower case case +-- guys as well (perhaps) e.g. see trueDataConName below + + +\begin{code} +runMainIOName = varQual pREL_TOP_HANDLER FSLIT("runMainIO") runMainKey + +orderingTyConName = tcQual pREL_BASE FSLIT("Ordering") orderingTyConKey + +eitherTyConName = tcQual pREL_EITHER FSLIT("Either") eitherTyConKey +leftDataConName = conName eitherTyConName FSLIT("Left") leftDataConKey +rightDataConName = conName eitherTyConName FSLIT("Right") rightDataConKey + +-- Generics +crossTyConName = tcQual pREL_BASE FSLIT(":*:") crossTyConKey +plusTyConName = tcQual pREL_BASE FSLIT(":+:") plusTyConKey +genUnitTyConName = tcQual pREL_BASE FSLIT("Unit") genUnitTyConKey + +-- Base strings Strings +unpackCStringName = varQual pREL_BASE FSLIT("unpackCString#") unpackCStringIdKey +unpackCStringAppendName = varQual pREL_BASE FSLIT("unpackAppendCString#") unpackCStringAppendIdKey +unpackCStringFoldrName = varQual pREL_BASE FSLIT("unpackFoldrCString#") unpackCStringFoldrIdKey +unpackCStringUtf8Name = varQual pREL_BASE FSLIT("unpackCStringUtf8#") unpackCStringUtf8IdKey +eqStringName = varQual pREL_BASE FSLIT("eqString") eqStringIdKey + +-- Base classes (Eq, Ord, Functor) +eqClassName = clsQual pREL_BASE FSLIT("Eq") eqClassKey +eqName = methName eqClassName FSLIT("==") eqClassOpKey +ordClassName = clsQual pREL_BASE FSLIT("Ord") ordClassKey +geName = methName ordClassName FSLIT(">=") geClassOpKey +functorClassName = clsQual pREL_BASE FSLIT("Functor") functorClassKey + +-- Class Monad +monadClassName = clsQual pREL_BASE FSLIT("Monad") monadClassKey +thenMName = methName monadClassName FSLIT(">>") thenMClassOpKey +bindMName = methName monadClassName FSLIT(">>=") bindMClassOpKey +returnMName = methName monadClassName FSLIT("return") returnMClassOpKey +failMName = methName monadClassName FSLIT("fail") failMClassOpKey + +-- Random PrelBase functions +otherwiseIdName = varQual pREL_BASE FSLIT("otherwise") otherwiseIdKey +foldrName = varQual pREL_BASE FSLIT("foldr") foldrIdKey +buildName = varQual pREL_BASE FSLIT("build") buildIdKey +augmentName = varQual pREL_BASE FSLIT("augment") augmentIdKey +appendName = varQual pREL_BASE FSLIT("++") appendIdKey +andName = varQual pREL_BASE FSLIT("&&") andIdKey +orName = varQual pREL_BASE FSLIT("||") orIdKey +assertName = varQual pREL_BASE FSLIT("assert") assertIdKey +breakpointName = varQual pREL_BASE FSLIT("breakpoint") breakpointIdKey +breakpointJumpName + = mkInternalName + breakpointJumpIdKey + (mkOccNameFS varName FSLIT("breakpointJump")) + noSrcLoc + +-- PrelTup +fstName = varQual pREL_TUP FSLIT("fst") fstIdKey +sndName = varQual pREL_TUP FSLIT("snd") sndIdKey + +-- Module PrelNum +numClassName = clsQual pREL_NUM FSLIT("Num") numClassKey +fromIntegerName = methName numClassName FSLIT("fromInteger") fromIntegerClassOpKey +minusName = methName numClassName FSLIT("-") minusClassOpKey +negateName = methName numClassName FSLIT("negate") negateClassOpKey +plusIntegerName = varQual pREL_NUM FSLIT("plusInteger") plusIntegerIdKey +timesIntegerName = varQual pREL_NUM FSLIT("timesInteger") timesIntegerIdKey +integerTyConName = tcQual pREL_NUM FSLIT("Integer") integerTyConKey +smallIntegerDataConName = conName integerTyConName FSLIT("S#") smallIntegerDataConKey +largeIntegerDataConName = conName integerTyConName FSLIT("J#") largeIntegerDataConKey + +-- PrelReal types and classes +rationalTyConName = tcQual pREL_REAL FSLIT("Rational") rationalTyConKey +ratioTyConName = tcQual pREL_REAL FSLIT("Ratio") ratioTyConKey +ratioDataConName = conName ratioTyConName FSLIT(":%") ratioDataConKey +realClassName = clsQual pREL_REAL FSLIT("Real") realClassKey +integralClassName = clsQual pREL_REAL FSLIT("Integral") integralClassKey +realFracClassName = clsQual pREL_REAL FSLIT("RealFrac") realFracClassKey +fractionalClassName = clsQual pREL_REAL FSLIT("Fractional") fractionalClassKey +fromRationalName = methName fractionalClassName FSLIT("fromRational") fromRationalClassOpKey + +-- PrelFloat classes +floatingClassName = clsQual pREL_FLOAT FSLIT("Floating") floatingClassKey +realFloatClassName = clsQual pREL_FLOAT FSLIT("RealFloat") realFloatClassKey + +-- Class Ix +ixClassName = clsQual pREL_ARR FSLIT("Ix") ixClassKey + +-- Class Typeable +typeableClassName = clsQual tYPEABLE FSLIT("Typeable") typeableClassKey +typeable1ClassName = clsQual tYPEABLE FSLIT("Typeable1") typeable1ClassKey +typeable2ClassName = clsQual tYPEABLE FSLIT("Typeable2") typeable2ClassKey +typeable3ClassName = clsQual tYPEABLE FSLIT("Typeable3") typeable3ClassKey +typeable4ClassName = clsQual tYPEABLE FSLIT("Typeable4") typeable4ClassKey +typeable5ClassName = clsQual tYPEABLE FSLIT("Typeable5") typeable5ClassKey +typeable6ClassName = clsQual tYPEABLE FSLIT("Typeable6") typeable6ClassKey +typeable7ClassName = clsQual tYPEABLE FSLIT("Typeable7") typeable7ClassKey + +typeableClassNames = [ typeableClassName, typeable1ClassName, typeable2ClassName + , typeable3ClassName, typeable4ClassName, typeable5ClassName + , typeable6ClassName, typeable7ClassName ] + +-- Class Data +dataClassName = clsQual gENERICS FSLIT("Data") dataClassKey + +-- Error module +assertErrorName = varQual pREL_ERR FSLIT("assertError") assertErrorIdKey + +-- Enum module (Enum, Bounded) +enumClassName = clsQual pREL_ENUM FSLIT("Enum") enumClassKey +enumFromName = methName enumClassName FSLIT("enumFrom") enumFromClassOpKey +enumFromToName = methName enumClassName FSLIT("enumFromTo") enumFromToClassOpKey +enumFromThenName = methName enumClassName FSLIT("enumFromThen") enumFromThenClassOpKey +enumFromThenToName = methName enumClassName FSLIT("enumFromThenTo") enumFromThenToClassOpKey +boundedClassName = clsQual pREL_ENUM FSLIT("Bounded") boundedClassKey + +-- List functions +concatName = varQual pREL_LIST FSLIT("concat") concatIdKey +filterName = varQual pREL_LIST FSLIT("filter") filterIdKey +zipName = varQual pREL_LIST FSLIT("zip") zipIdKey + +-- Class Show +showClassName = clsQual pREL_SHOW FSLIT("Show") showClassKey + +-- Class Read +readClassName = clsQual pREL_READ FSLIT("Read") readClassKey + +-- parallel array types and functions +enumFromToPName = varQual pREL_PARR FSLIT("enumFromToP") enumFromToPIdKey +enumFromThenToPName= varQual pREL_PARR FSLIT("enumFromThenToP") enumFromThenToPIdKey +nullPName = varQual pREL_PARR FSLIT("nullP") nullPIdKey +lengthPName = varQual pREL_PARR FSLIT("lengthP") lengthPIdKey +replicatePName = varQual pREL_PARR FSLIT("replicateP") replicatePIdKey +mapPName = varQual pREL_PARR FSLIT("mapP") mapPIdKey +filterPName = varQual pREL_PARR FSLIT("filterP") filterPIdKey +zipPName = varQual pREL_PARR FSLIT("zipP") zipPIdKey +crossPName = varQual pREL_PARR FSLIT("crossP") crossPIdKey +indexPName = varQual pREL_PARR FSLIT("!:") indexPIdKey +toPName = varQual pREL_PARR FSLIT("toP") toPIdKey +bpermutePName = varQual pREL_PARR FSLIT("bpermuteP") bpermutePIdKey +bpermuteDftPName = varQual pREL_PARR FSLIT("bpermuteDftP") bpermuteDftPIdKey +indexOfPName = varQual pREL_PARR FSLIT("indexOfP") indexOfPIdKey + +-- IOBase things +ioTyConName = tcQual pREL_IO_BASE FSLIT("IO") ioTyConKey +ioDataConName = conName ioTyConName FSLIT("IO") ioDataConKey +thenIOName = varQual pREL_IO_BASE FSLIT("thenIO") thenIOIdKey +bindIOName = varQual pREL_IO_BASE FSLIT("bindIO") bindIOIdKey +returnIOName = varQual pREL_IO_BASE FSLIT("returnIO") returnIOIdKey +failIOName = varQual pREL_IO_BASE FSLIT("failIO") failIOIdKey + +-- IO things +printName = varQual sYSTEM_IO FSLIT("print") printIdKey + +-- Int, Word, and Addr things +int8TyConName = tcQual pREL_INT FSLIT("Int8") int8TyConKey +int16TyConName = tcQual pREL_INT FSLIT("Int16") int16TyConKey +int32TyConName = tcQual pREL_INT FSLIT("Int32") int32TyConKey +int64TyConName = tcQual pREL_INT FSLIT("Int64") int64TyConKey + +-- Word module +word8TyConName = tcQual pREL_WORD FSLIT("Word8") word8TyConKey +word16TyConName = tcQual pREL_WORD FSLIT("Word16") word16TyConKey +word32TyConName = tcQual pREL_WORD FSLIT("Word32") word32TyConKey +word64TyConName = tcQual pREL_WORD FSLIT("Word64") word64TyConKey +wordTyConName = tcQual pREL_WORD FSLIT("Word") wordTyConKey +wordDataConName = conName wordTyConName FSLIT("W#") wordDataConKey + +-- Addr module +addrTyConName = tcQual aDDR FSLIT("Addr") addrTyConKey + +-- PrelPtr module +ptrTyConName = tcQual pREL_PTR FSLIT("Ptr") ptrTyConKey +funPtrTyConName = tcQual pREL_PTR FSLIT("FunPtr") funPtrTyConKey + +-- Byte array types +byteArrayTyConName = tcQual pREL_BYTEARR FSLIT("ByteArray") byteArrayTyConKey +mutableByteArrayTyConName = tcQual pREL_BYTEARR FSLIT("MutableByteArray") mutableByteArrayTyConKey + +-- Foreign objects and weak pointers +stablePtrTyConName = tcQual pREL_STABLE FSLIT("StablePtr") stablePtrTyConKey +newStablePtrName = varQual pREL_STABLE FSLIT("newStablePtr") newStablePtrIdKey + +-- PrelST module +runSTRepName = varQual pREL_ST FSLIT("runSTRep") runSTRepIdKey + +-- The "split" Id for splittable implicit parameters +splittableClassName = clsQual gLA_EXTS FSLIT("Splittable") splittableClassKey +splitName = methName splittableClassName FSLIT("split") splitIdKey + +-- Recursive-do notation +monadFixClassName = clsQual mONAD_FIX FSLIT("MonadFix") monadFixClassKey +mfixName = methName monadFixClassName FSLIT("mfix") mfixIdKey + +-- Arrow notation +arrAName = varQual aRROW FSLIT("arr") arrAIdKey +composeAName = varQual aRROW FSLIT(">>>") composeAIdKey +firstAName = varQual aRROW FSLIT("first") firstAIdKey +appAName = varQual aRROW FSLIT("app") appAIdKey +choiceAName = varQual aRROW FSLIT("|||") choiceAIdKey +loopAName = varQual aRROW FSLIT("loop") loopAIdKey + +-- Other classes, needed for type defaulting +monadPlusClassName = clsQual mONAD FSLIT("MonadPlus") monadPlusClassKey +randomClassName = clsQual rANDOM FSLIT("Random") randomClassKey +randomGenClassName = clsQual rANDOM FSLIT("RandomGen") randomGenClassKey + +-- dotnet interop +objectTyConName = tcQual dOTNET FSLIT("Object") objectTyConKey + -- objectTyConName was "wTcQual", but that's gone now, and + -- I can't see why it was wired in anyway... +unmarshalObjectName = varQual dOTNET FSLIT("unmarshalObject") unmarshalObjectIdKey +marshalObjectName = varQual dOTNET FSLIT("marshalObject") marshalObjectIdKey +marshalStringName = varQual dOTNET FSLIT("marshalString") marshalStringIdKey +unmarshalStringName = varQual dOTNET FSLIT("unmarshalString") unmarshalStringIdKey +checkDotnetResName = varQual dOTNET FSLIT("checkResult") checkDotnetResNameIdKey +\end{code} + +%************************************************************************ +%* * +\subsection{Local helpers} +%* * +%************************************************************************ + +All these are original names; hence mkOrig + +\begin{code} +varQual = mk_known_key_name varName +tcQual = mk_known_key_name tcName +clsQual = mk_known_key_name clsName + +mk_known_key_name space mod str uniq + = mkExternalName uniq mod (mkOccNameFS space str) + Nothing noSrcLoc + +conName :: Name -> FastString -> Unique -> Name +conName tycon occ uniq + = mkExternalName uniq (nameModule tycon) (mkOccNameFS dataName occ) + (Just tycon) noSrcLoc + +methName :: Name -> FastString -> Unique -> Name +methName cls occ uniq + = mkExternalName uniq (nameModule cls) (mkVarOccFS occ) + (Just cls) noSrcLoc +\end{code} + +%************************************************************************ +%* * +\subsubsection[Uniques-prelude-Classes]{@Uniques@ for wired-in @Classes@} +%* * +%************************************************************************ +--MetaHaskell extension hand allocate keys here + +\begin{code} +boundedClassKey = mkPreludeClassUnique 1 +enumClassKey = mkPreludeClassUnique 2 +eqClassKey = mkPreludeClassUnique 3 +floatingClassKey = mkPreludeClassUnique 5 +fractionalClassKey = mkPreludeClassUnique 6 +integralClassKey = mkPreludeClassUnique 7 +monadClassKey = mkPreludeClassUnique 8 +dataClassKey = mkPreludeClassUnique 9 +functorClassKey = mkPreludeClassUnique 10 +numClassKey = mkPreludeClassUnique 11 +ordClassKey = mkPreludeClassUnique 12 +readClassKey = mkPreludeClassUnique 13 +realClassKey = mkPreludeClassUnique 14 +realFloatClassKey = mkPreludeClassUnique 15 +realFracClassKey = mkPreludeClassUnique 16 +showClassKey = mkPreludeClassUnique 17 +ixClassKey = mkPreludeClassUnique 18 + +typeableClassKey = mkPreludeClassUnique 20 +typeable1ClassKey = mkPreludeClassUnique 21 +typeable2ClassKey = mkPreludeClassUnique 22 +typeable3ClassKey = mkPreludeClassUnique 23 +typeable4ClassKey = mkPreludeClassUnique 24 +typeable5ClassKey = mkPreludeClassUnique 25 +typeable6ClassKey = mkPreludeClassUnique 26 +typeable7ClassKey = mkPreludeClassUnique 27 + +monadFixClassKey = mkPreludeClassUnique 28 +splittableClassKey = mkPreludeClassUnique 29 + +monadPlusClassKey = mkPreludeClassUnique 30 +randomClassKey = mkPreludeClassUnique 31 +randomGenClassKey = mkPreludeClassUnique 32 +\end{code} + +%************************************************************************ +%* * +\subsubsection[Uniques-prelude-TyCons]{@Uniques@ for wired-in @TyCons@} +%* * +%************************************************************************ + +\begin{code} +addrPrimTyConKey = mkPreludeTyConUnique 1 +addrTyConKey = mkPreludeTyConUnique 2 +arrayPrimTyConKey = mkPreludeTyConUnique 3 +boolTyConKey = mkPreludeTyConUnique 4 +byteArrayPrimTyConKey = mkPreludeTyConUnique 5 +charPrimTyConKey = mkPreludeTyConUnique 7 +charTyConKey = mkPreludeTyConUnique 8 +doublePrimTyConKey = mkPreludeTyConUnique 9 +doubleTyConKey = mkPreludeTyConUnique 10 +floatPrimTyConKey = mkPreludeTyConUnique 11 +floatTyConKey = mkPreludeTyConUnique 12 +funTyConKey = mkPreludeTyConUnique 13 +intPrimTyConKey = mkPreludeTyConUnique 14 +intTyConKey = mkPreludeTyConUnique 15 +int8TyConKey = mkPreludeTyConUnique 16 +int16TyConKey = mkPreludeTyConUnique 17 +int32PrimTyConKey = mkPreludeTyConUnique 18 +int32TyConKey = mkPreludeTyConUnique 19 +int64PrimTyConKey = mkPreludeTyConUnique 20 +int64TyConKey = mkPreludeTyConUnique 21 +integerTyConKey = mkPreludeTyConUnique 22 +listTyConKey = mkPreludeTyConUnique 23 +foreignObjPrimTyConKey = mkPreludeTyConUnique 24 +weakPrimTyConKey = mkPreludeTyConUnique 27 +mutableArrayPrimTyConKey = mkPreludeTyConUnique 28 +mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 29 +orderingTyConKey = mkPreludeTyConUnique 30 +mVarPrimTyConKey = mkPreludeTyConUnique 31 +ratioTyConKey = mkPreludeTyConUnique 32 +rationalTyConKey = mkPreludeTyConUnique 33 +realWorldTyConKey = mkPreludeTyConUnique 34 +stablePtrPrimTyConKey = mkPreludeTyConUnique 35 +stablePtrTyConKey = mkPreludeTyConUnique 36 +statePrimTyConKey = mkPreludeTyConUnique 50 +stableNamePrimTyConKey = mkPreludeTyConUnique 51 +stableNameTyConKey = mkPreludeTyConUnique 52 +mutableByteArrayTyConKey = mkPreludeTyConUnique 53 +mutVarPrimTyConKey = mkPreludeTyConUnique 55 +ioTyConKey = mkPreludeTyConUnique 56 +byteArrayTyConKey = mkPreludeTyConUnique 57 +wordPrimTyConKey = mkPreludeTyConUnique 58 +wordTyConKey = mkPreludeTyConUnique 59 +word8TyConKey = mkPreludeTyConUnique 60 +word16TyConKey = mkPreludeTyConUnique 61 +word32PrimTyConKey = mkPreludeTyConUnique 62 +word32TyConKey = mkPreludeTyConUnique 63 +word64PrimTyConKey = mkPreludeTyConUnique 64 +word64TyConKey = mkPreludeTyConUnique 65 +liftedConKey = mkPreludeTyConUnique 66 +unliftedConKey = mkPreludeTyConUnique 67 +anyBoxConKey = mkPreludeTyConUnique 68 +kindConKey = mkPreludeTyConUnique 69 +boxityConKey = mkPreludeTyConUnique 70 +typeConKey = mkPreludeTyConUnique 71 +threadIdPrimTyConKey = mkPreludeTyConUnique 72 +bcoPrimTyConKey = mkPreludeTyConUnique 73 +ptrTyConKey = mkPreludeTyConUnique 74 +funPtrTyConKey = mkPreludeTyConUnique 75 +tVarPrimTyConKey = mkPreludeTyConUnique 76 + +-- Generic Type Constructors +crossTyConKey = mkPreludeTyConUnique 79 +plusTyConKey = mkPreludeTyConUnique 80 +genUnitTyConKey = mkPreludeTyConUnique 81 + +-- Parallel array type constructor +parrTyConKey = mkPreludeTyConUnique 82 + +-- dotnet interop +objectTyConKey = mkPreludeTyConUnique 83 + +eitherTyConKey = mkPreludeTyConUnique 84 + +---------------- Template Haskell ------------------- +-- USES TyConUniques 100-129 +----------------------------------------------------- + +unitTyConKey = mkTupleTyConUnique Boxed 0 +\end{code} + +%************************************************************************ +%* * +\subsubsection[Uniques-prelude-DataCons]{@Uniques@ for wired-in @DataCons@} +%* * +%************************************************************************ + +\begin{code} +charDataConKey = mkPreludeDataConUnique 1 +consDataConKey = mkPreludeDataConUnique 2 +doubleDataConKey = mkPreludeDataConUnique 3 +falseDataConKey = mkPreludeDataConUnique 4 +floatDataConKey = mkPreludeDataConUnique 5 +intDataConKey = mkPreludeDataConUnique 6 +smallIntegerDataConKey = mkPreludeDataConUnique 7 +largeIntegerDataConKey = mkPreludeDataConUnique 8 +nilDataConKey = mkPreludeDataConUnique 11 +ratioDataConKey = mkPreludeDataConUnique 12 +stableNameDataConKey = mkPreludeDataConUnique 14 +trueDataConKey = mkPreludeDataConUnique 15 +wordDataConKey = mkPreludeDataConUnique 16 +ioDataConKey = mkPreludeDataConUnique 17 + +-- Generic data constructors +crossDataConKey = mkPreludeDataConUnique 20 +inlDataConKey = mkPreludeDataConUnique 21 +inrDataConKey = mkPreludeDataConUnique 22 +genUnitDataConKey = mkPreludeDataConUnique 23 + +-- Data constructor for parallel arrays +parrDataConKey = mkPreludeDataConUnique 24 + +leftDataConKey = mkPreludeDataConUnique 25 +rightDataConKey = mkPreludeDataConUnique 26 +\end{code} + +%************************************************************************ +%* * +\subsubsection[Uniques-prelude-Ids]{@Uniques@ for wired-in @Ids@ (except @DataCons@)} +%* * +%************************************************************************ + +\begin{code} +absentErrorIdKey = mkPreludeMiscIdUnique 1 +augmentIdKey = mkPreludeMiscIdUnique 3 +appendIdKey = mkPreludeMiscIdUnique 4 +buildIdKey = mkPreludeMiscIdUnique 5 +errorIdKey = mkPreludeMiscIdUnique 6 +foldlIdKey = mkPreludeMiscIdUnique 7 +foldrIdKey = mkPreludeMiscIdUnique 8 +recSelErrorIdKey = mkPreludeMiscIdUnique 9 +integerMinusOneIdKey = mkPreludeMiscIdUnique 10 +integerPlusOneIdKey = mkPreludeMiscIdUnique 11 +integerPlusTwoIdKey = mkPreludeMiscIdUnique 12 +integerZeroIdKey = mkPreludeMiscIdUnique 13 +int2IntegerIdKey = mkPreludeMiscIdUnique 14 +seqIdKey = mkPreludeMiscIdUnique 15 +irrefutPatErrorIdKey = mkPreludeMiscIdUnique 16 +eqStringIdKey = mkPreludeMiscIdUnique 17 +noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 18 +nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 19 +runtimeErrorIdKey = mkPreludeMiscIdUnique 20 +parErrorIdKey = mkPreludeMiscIdUnique 21 +parIdKey = mkPreludeMiscIdUnique 22 +patErrorIdKey = mkPreludeMiscIdUnique 23 +realWorldPrimIdKey = mkPreludeMiscIdUnique 24 +recConErrorIdKey = mkPreludeMiscIdUnique 25 +recUpdErrorIdKey = mkPreludeMiscIdUnique 26 +traceIdKey = mkPreludeMiscIdUnique 27 +unpackCStringUtf8IdKey = mkPreludeMiscIdUnique 28 +unpackCStringAppendIdKey = mkPreludeMiscIdUnique 29 +unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 30 +unpackCStringIdKey = mkPreludeMiscIdUnique 31 + +unsafeCoerceIdKey = mkPreludeMiscIdUnique 32 +concatIdKey = mkPreludeMiscIdUnique 33 +filterIdKey = mkPreludeMiscIdUnique 34 +zipIdKey = mkPreludeMiscIdUnique 35 +bindIOIdKey = mkPreludeMiscIdUnique 36 +returnIOIdKey = mkPreludeMiscIdUnique 37 +deRefStablePtrIdKey = mkPreludeMiscIdUnique 38 +newStablePtrIdKey = mkPreludeMiscIdUnique 39 +plusIntegerIdKey = mkPreludeMiscIdUnique 41 +timesIntegerIdKey = mkPreludeMiscIdUnique 42 +printIdKey = mkPreludeMiscIdUnique 43 +failIOIdKey = mkPreludeMiscIdUnique 44 +nullAddrIdKey = mkPreludeMiscIdUnique 46 +voidArgIdKey = mkPreludeMiscIdUnique 47 +splitIdKey = mkPreludeMiscIdUnique 48 +fstIdKey = mkPreludeMiscIdUnique 49 +sndIdKey = mkPreludeMiscIdUnique 50 +otherwiseIdKey = mkPreludeMiscIdUnique 51 +assertIdKey = mkPreludeMiscIdUnique 53 +runSTRepIdKey = mkPreludeMiscIdUnique 54 + +rootMainKey = mkPreludeMiscIdUnique 55 +runMainKey = mkPreludeMiscIdUnique 56 + +andIdKey = mkPreludeMiscIdUnique 57 +orIdKey = mkPreludeMiscIdUnique 58 +thenIOIdKey = mkPreludeMiscIdUnique 59 +lazyIdKey = mkPreludeMiscIdUnique 60 +assertErrorIdKey = mkPreludeMiscIdUnique 61 + +breakpointIdKey = mkPreludeMiscIdUnique 62 +breakpointJumpIdKey = mkPreludeMiscIdUnique 63 + +-- Parallel array functions +nullPIdKey = mkPreludeMiscIdUnique 80 +lengthPIdKey = mkPreludeMiscIdUnique 81 +replicatePIdKey = mkPreludeMiscIdUnique 82 +mapPIdKey = mkPreludeMiscIdUnique 83 +filterPIdKey = mkPreludeMiscIdUnique 84 +zipPIdKey = mkPreludeMiscIdUnique 85 +crossPIdKey = mkPreludeMiscIdUnique 86 +indexPIdKey = mkPreludeMiscIdUnique 87 +toPIdKey = mkPreludeMiscIdUnique 88 +enumFromToPIdKey = mkPreludeMiscIdUnique 89 +enumFromThenToPIdKey = mkPreludeMiscIdUnique 90 +bpermutePIdKey = mkPreludeMiscIdUnique 91 +bpermuteDftPIdKey = mkPreludeMiscIdUnique 92 +indexOfPIdKey = mkPreludeMiscIdUnique 93 + +-- dotnet interop +unmarshalObjectIdKey = mkPreludeMiscIdUnique 94 +marshalObjectIdKey = mkPreludeMiscIdUnique 95 +marshalStringIdKey = mkPreludeMiscIdUnique 96 +unmarshalStringIdKey = mkPreludeMiscIdUnique 97 +checkDotnetResNameIdKey = mkPreludeMiscIdUnique 98 + +\end{code} + +Certain class operations from Prelude classes. They get their own +uniques so we can look them up easily when we want to conjure them up +during type checking. + +\begin{code} + -- Just a place holder for unbound variables produced by the renamer: +unboundKey = mkPreludeMiscIdUnique 101 + +fromIntegerClassOpKey = mkPreludeMiscIdUnique 102 +minusClassOpKey = mkPreludeMiscIdUnique 103 +fromRationalClassOpKey = mkPreludeMiscIdUnique 104 +enumFromClassOpKey = mkPreludeMiscIdUnique 105 +enumFromThenClassOpKey = mkPreludeMiscIdUnique 106 +enumFromToClassOpKey = mkPreludeMiscIdUnique 107 +enumFromThenToClassOpKey = mkPreludeMiscIdUnique 108 +eqClassOpKey = mkPreludeMiscIdUnique 109 +geClassOpKey = mkPreludeMiscIdUnique 110 +negateClassOpKey = mkPreludeMiscIdUnique 111 +failMClassOpKey = mkPreludeMiscIdUnique 112 +bindMClassOpKey = mkPreludeMiscIdUnique 113 -- (>>=) +thenMClassOpKey = mkPreludeMiscIdUnique 114 -- (>>) +returnMClassOpKey = mkPreludeMiscIdUnique 117 + +-- Recursive do notation +mfixIdKey = mkPreludeMiscIdUnique 118 + +-- Arrow notation +arrAIdKey = mkPreludeMiscIdUnique 119 +composeAIdKey = mkPreludeMiscIdUnique 120 -- >>> +firstAIdKey = mkPreludeMiscIdUnique 121 +appAIdKey = mkPreludeMiscIdUnique 122 +choiceAIdKey = mkPreludeMiscIdUnique 123 -- ||| +loopAIdKey = mkPreludeMiscIdUnique 124 + +---------------- Template Haskell ------------------- +-- USES IdUniques 200-399 +----------------------------------------------------- +\end{code} + + +%************************************************************************ +%* * +\subsection{Standard groups of types} +%* * +%************************************************************************ + +\begin{code} +numericTyKeys = + [ addrTyConKey + , wordTyConKey + , intTyConKey + , integerTyConKey + , doubleTyConKey + , floatTyConKey + ] + + -- Renamer always imports these data decls replete with constructors + -- so that desugarer can always see their constructors. Ugh! +cCallishTyKeys = + [ addrTyConKey + , wordTyConKey + , byteArrayTyConKey + , mutableByteArrayTyConKey + , stablePtrTyConKey + , int8TyConKey + , int16TyConKey + , int32TyConKey + , int64TyConKey + , word8TyConKey + , word16TyConKey + , word32TyConKey + , word64TyConKey + ] +\end{code} + + +%************************************************************************ +%* * +\subsection[Class-std-groups]{Standard groups of Prelude classes} +%* * +%************************************************************************ + +NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@ +even though every numeric class has these two as a superclass, +because the list of ambiguous dictionaries hasn't been simplified. + +\begin{code} +numericClassKeys = + [ numClassKey + , realClassKey + , integralClassKey + ] + ++ fractionalClassKeys + +fractionalClassKeys = + [ fractionalClassKey + , floatingClassKey + , realFracClassKey + , realFloatClassKey + ] + + -- the strictness analyser needs to know about numeric types + -- (see SaAbsInt.lhs) +needsDataDeclCtxtClassKeys = -- see comments in TcDeriv + [ readClassKey + ] + +-- The "standard classes" are used in defaulting (Haskell 98 report 4.3.4), +-- and are: "classes defined in the Prelude or a standard library" +standardClassKeys = derivableClassKeys ++ numericClassKeys + ++ [randomClassKey, randomGenClassKey, + functorClassKey, + monadClassKey, monadPlusClassKey] +\end{code} + +@derivableClassKeys@ is also used in checking \tr{deriving} constructs +(@TcDeriv@). + +\begin{code} +derivableClassKeys + = [ eqClassKey, ordClassKey, enumClassKey, ixClassKey, + boundedClassKey, showClassKey, readClassKey ] +\end{code} + diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs new file mode 100644 index 0000000000..9cdddc9065 --- /dev/null +++ b/compiler/prelude/PrelRules.lhs @@ -0,0 +1,447 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[ConFold]{Constant Folder} + +Conceptually, constant folding should be parameterized with the kind +of target machine to get identical behaviour during compilation time +and runtime. We cheat a little bit here... + +ToDo: + check boundaries before folding, e.g. we can fold the Float addition + (i1 + i2) only if it results in a valid Float. + +\begin{code} + +{-# OPTIONS -optc-DNON_POSIX_SOURCE #-} + +module PrelRules ( primOpRules, builtinRules ) where + +#include "HsVersions.h" + +import CoreSyn +import Id ( mkWildId, isPrimOpId_maybe ) +import Literal ( Literal(..), mkMachInt, mkMachWord + , literalType + , word2IntLit, int2WordLit + , narrow8IntLit, narrow16IntLit, narrow32IntLit + , narrow8WordLit, narrow16WordLit, narrow32WordLit + , char2IntLit, int2CharLit + , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit + , float2DoubleLit, double2FloatLit + ) +import PrimOp ( PrimOp(..), primOpOcc ) +import TysWiredIn ( boolTy, trueDataConId, falseDataConId ) +import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon ) +import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG ) +import CoreUtils ( cheapEqExpr, exprIsConApp_maybe ) +import Type ( tyConAppTyCon, coreEqType ) +import OccName ( occNameFS ) +import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey, + eqStringName, unpackCStringIdKey ) +import Maybes ( orElse ) +import Name ( Name ) +import Outputable +import FastString +import StaticFlags ( opt_SimplExcessPrecision ) + +import DATA_BITS ( Bits(..) ) +#if __GLASGOW_HASKELL__ >= 500 +import DATA_WORD ( Word ) +#else +import DATA_WORD ( Word64 ) +#endif +\end{code} + + +\begin{code} +primOpRules :: PrimOp -> Name -> [CoreRule] +primOpRules op op_name = primop_rule op + where + rule_name = occNameFS (primOpOcc op) + rule_name_case = rule_name `appendFS` FSLIT("->case") + + -- A useful shorthand + one_rule rule_fn = [BuiltinRule { ru_name = rule_name, + ru_fn = op_name, + ru_try = rule_fn }] + case_rule rule_fn = [BuiltinRule { ru_name = rule_name_case, + ru_fn = op_name, + ru_try = rule_fn }] + + -- ToDo: something for integer-shift ops? + -- NotOp + + primop_rule TagToEnumOp = one_rule tagToEnumRule + primop_rule DataToTagOp = one_rule dataToTagRule + + -- Int operations + primop_rule IntAddOp = one_rule (twoLits (intOp2 (+))) + primop_rule IntSubOp = one_rule (twoLits (intOp2 (-))) + primop_rule IntMulOp = one_rule (twoLits (intOp2 (*))) + primop_rule IntQuotOp = one_rule (twoLits (intOp2Z quot)) + primop_rule IntRemOp = one_rule (twoLits (intOp2Z rem)) + primop_rule IntNegOp = one_rule (oneLit negOp) + + -- Word operations +#if __GLASGOW_HASKELL__ >= 500 + primop_rule WordAddOp = one_rule (twoLits (wordOp2 (+))) + primop_rule WordSubOp = one_rule (twoLits (wordOp2 (-))) + primop_rule WordMulOp = one_rule (twoLits (wordOp2 (*))) +#endif + primop_rule WordQuotOp = one_rule (twoLits (wordOp2Z quot)) + primop_rule WordRemOp = one_rule (twoLits (wordOp2Z rem)) +#if __GLASGOW_HASKELL__ >= 407 + primop_rule AndOp = one_rule (twoLits (wordBitOp2 (.&.))) + primop_rule OrOp = one_rule (twoLits (wordBitOp2 (.|.))) + primop_rule XorOp = one_rule (twoLits (wordBitOp2 xor)) +#endif + + -- coercions + primop_rule Word2IntOp = one_rule (oneLit (litCoerce word2IntLit)) + primop_rule Int2WordOp = one_rule (oneLit (litCoerce int2WordLit)) + primop_rule Narrow8IntOp = one_rule (oneLit (litCoerce narrow8IntLit)) + primop_rule Narrow16IntOp = one_rule (oneLit (litCoerce narrow16IntLit)) + primop_rule Narrow32IntOp = one_rule (oneLit (litCoerce narrow32IntLit)) + primop_rule Narrow8WordOp = one_rule (oneLit (litCoerce narrow8WordLit)) + primop_rule Narrow16WordOp = one_rule (oneLit (litCoerce narrow16WordLit)) + primop_rule Narrow32WordOp = one_rule (oneLit (litCoerce narrow32WordLit)) + primop_rule OrdOp = one_rule (oneLit (litCoerce char2IntLit)) + primop_rule ChrOp = one_rule (oneLit (litCoerce int2CharLit)) + primop_rule Float2IntOp = one_rule (oneLit (litCoerce float2IntLit)) + primop_rule Int2FloatOp = one_rule (oneLit (litCoerce int2FloatLit)) + primop_rule Double2IntOp = one_rule (oneLit (litCoerce double2IntLit)) + primop_rule Int2DoubleOp = one_rule (oneLit (litCoerce int2DoubleLit)) + -- SUP: Not sure what the standard says about precision in the following 2 cases + primop_rule Float2DoubleOp = one_rule (oneLit (litCoerce float2DoubleLit)) + primop_rule Double2FloatOp = one_rule (oneLit (litCoerce double2FloatLit)) + + -- Float + primop_rule FloatAddOp = one_rule (twoLits (floatOp2 (+))) + primop_rule FloatSubOp = one_rule (twoLits (floatOp2 (-))) + primop_rule FloatMulOp = one_rule (twoLits (floatOp2 (*))) + primop_rule FloatDivOp = one_rule (twoLits (floatOp2Z (/))) + primop_rule FloatNegOp = one_rule (oneLit negOp) + + -- Double + primop_rule DoubleAddOp = one_rule (twoLits (doubleOp2 (+))) + primop_rule DoubleSubOp = one_rule (twoLits (doubleOp2 (-))) + primop_rule DoubleMulOp = one_rule (twoLits (doubleOp2 (*))) + primop_rule DoubleDivOp = one_rule (twoLits (doubleOp2Z (/))) + primop_rule DoubleNegOp = one_rule (oneLit negOp) + + -- Relational operators + primop_rule IntEqOp = one_rule (relop (==)) ++ case_rule (litEq True) + primop_rule IntNeOp = one_rule (relop (/=)) ++ case_rule (litEq False) + primop_rule CharEqOp = one_rule (relop (==)) ++ case_rule (litEq True) + primop_rule CharNeOp = one_rule (relop (/=)) ++ case_rule (litEq False) + + primop_rule IntGtOp = one_rule (relop (>)) + primop_rule IntGeOp = one_rule (relop (>=)) + primop_rule IntLeOp = one_rule (relop (<=)) + primop_rule IntLtOp = one_rule (relop (<)) + + primop_rule CharGtOp = one_rule (relop (>)) + primop_rule CharGeOp = one_rule (relop (>=)) + primop_rule CharLeOp = one_rule (relop (<=)) + primop_rule CharLtOp = one_rule (relop (<)) + + primop_rule FloatGtOp = one_rule (relop (>)) + primop_rule FloatGeOp = one_rule (relop (>=)) + primop_rule FloatLeOp = one_rule (relop (<=)) + primop_rule FloatLtOp = one_rule (relop (<)) + primop_rule FloatEqOp = one_rule (relop (==)) + primop_rule FloatNeOp = one_rule (relop (/=)) + + primop_rule DoubleGtOp = one_rule (relop (>)) + primop_rule DoubleGeOp = one_rule (relop (>=)) + primop_rule DoubleLeOp = one_rule (relop (<=)) + primop_rule DoubleLtOp = one_rule (relop (<)) + primop_rule DoubleEqOp = one_rule (relop (==)) + primop_rule DoubleNeOp = one_rule (relop (/=)) + + primop_rule WordGtOp = one_rule (relop (>)) + primop_rule WordGeOp = one_rule (relop (>=)) + primop_rule WordLeOp = one_rule (relop (<=)) + primop_rule WordLtOp = one_rule (relop (<)) + primop_rule WordEqOp = one_rule (relop (==)) + primop_rule WordNeOp = one_rule (relop (/=)) + + primop_rule other = [] + + + relop cmp = twoLits (cmpOp (\ord -> ord `cmp` EQ)) + -- Cunning. cmpOp compares the values to give an Ordering. + -- It applies its argument to that ordering value to turn + -- the ordering into a boolean value. (`cmp` EQ) is just the job. +\end{code} + +%************************************************************************ +%* * +\subsection{Doing the business} +%* * +%************************************************************************ + +ToDo: the reason these all return Nothing is because there used to be +the possibility of an argument being a litlit. Litlits are now gone, +so this could be cleaned up. + +\begin{code} +-------------------------- +litCoerce :: (Literal -> Literal) -> Literal -> Maybe CoreExpr +litCoerce fn lit = Just (Lit (fn lit)) + +-------------------------- +cmpOp :: (Ordering -> Bool) -> Literal -> Literal -> Maybe CoreExpr +cmpOp cmp l1 l2 + = go l1 l2 + where + done res | cmp res = Just trueVal + | otherwise = Just falseVal + + -- These compares are at different types + go (MachChar i1) (MachChar i2) = done (i1 `compare` i2) + go (MachInt i1) (MachInt i2) = done (i1 `compare` i2) + go (MachInt64 i1) (MachInt64 i2) = done (i1 `compare` i2) + go (MachWord i1) (MachWord i2) = done (i1 `compare` i2) + go (MachWord64 i1) (MachWord64 i2) = done (i1 `compare` i2) + go (MachFloat i1) (MachFloat i2) = done (i1 `compare` i2) + go (MachDouble i1) (MachDouble i2) = done (i1 `compare` i2) + go l1 l2 = Nothing + +-------------------------- + +negOp (MachFloat 0.0) = Nothing -- can't represent -0.0 as a Rational +negOp (MachFloat f) = Just (mkFloatVal (-f)) +negOp (MachDouble 0.0) = Nothing +negOp (MachDouble d) = Just (mkDoubleVal (-d)) +negOp (MachInt i) = intResult (-i) +negOp l = Nothing + +-------------------------- +intOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` i2) +intOp2 op l1 l2 = Nothing -- Could find LitLit + +intOp2Z op (MachInt i1) (MachInt i2) + | i2 /= 0 = Just (mkIntVal (i1 `op` i2)) +intOp2Z op l1 l2 = Nothing -- LitLit or zero dividend + +-------------------------- +#if __GLASGOW_HASKELL__ >= 500 +wordOp2 op (MachWord w1) (MachWord w2) + = wordResult (w1 `op` w2) +wordOp2 op l1 l2 = Nothing -- Could find LitLit +#endif + +wordOp2Z op (MachWord w1) (MachWord w2) + | w2 /= 0 = Just (mkWordVal (w1 `op` w2)) +wordOp2Z op l1 l2 = Nothing -- LitLit or zero dividend + +#if __GLASGOW_HASKELL__ >= 500 +wordBitOp2 op l1@(MachWord w1) l2@(MachWord w2) + = Just (mkWordVal (w1 `op` w2)) +#else +-- Integer is not an instance of Bits, so we operate on Word64 +wordBitOp2 op l1@(MachWord w1) l2@(MachWord w2) + = Just (mkWordVal ((fromIntegral::Word64->Integer) (fromIntegral w1 `op` fromIntegral w2))) +#endif +wordBitOp2 op l1 l2 = Nothing -- Could find LitLit + +-------------------------- +floatOp2 op (MachFloat f1) (MachFloat f2) + = Just (mkFloatVal (f1 `op` f2)) +floatOp2 op l1 l2 = Nothing + +floatOp2Z op (MachFloat f1) (MachFloat f2) + | f2 /= 0 = Just (mkFloatVal (f1 `op` f2)) +floatOp2Z op l1 l2 = Nothing + +-------------------------- +doubleOp2 op (MachDouble f1) (MachDouble f2) + = Just (mkDoubleVal (f1 `op` f2)) +doubleOp2 op l1 l2 = Nothing + +doubleOp2Z op (MachDouble f1) (MachDouble f2) + | f2 /= 0 = Just (mkDoubleVal (f1 `op` f2)) +doubleOp2Z op l1 l2 = Nothing + + +-------------------------- + -- This stuff turns + -- n ==# 3# + -- into + -- case n of + -- 3# -> True + -- m -> False + -- + -- This is a Good Thing, because it allows case-of case things + -- to happen, and case-default absorption to happen. For + -- example: + -- + -- if (n ==# 3#) || (n ==# 4#) then e1 else e2 + -- will transform to + -- case n of + -- 3# -> e1 + -- 4# -> e1 + -- m -> e2 + -- (modulo the usual precautions to avoid duplicating e1) + +litEq :: Bool -- True <=> equality, False <=> inequality + -> RuleFun +litEq is_eq [Lit lit, expr] = do_lit_eq is_eq lit expr +litEq is_eq [expr, Lit lit] = do_lit_eq is_eq lit expr +litEq is_eq other = Nothing + +do_lit_eq is_eq lit expr + = Just (Case expr (mkWildId (literalType lit)) boolTy + [(DEFAULT, [], val_if_neq), + (LitAlt lit, [], val_if_eq)]) + where + val_if_eq | is_eq = trueVal + | otherwise = falseVal + val_if_neq | is_eq = falseVal + | otherwise = trueVal + +-- Note that we *don't* warn the user about overflow. It's not done at +-- runtime either, and compilation of completely harmless things like +-- ((124076834 :: Word32) + (2147483647 :: Word32)) +-- would yield a warning. Instead we simply squash the value into the +-- Int range, but not in a way suitable for cross-compiling... :-( +intResult :: Integer -> Maybe CoreExpr +intResult result + = Just (mkIntVal (toInteger (fromInteger result :: Int))) + +#if __GLASGOW_HASKELL__ >= 500 +wordResult :: Integer -> Maybe CoreExpr +wordResult result + = Just (mkWordVal (toInteger (fromInteger result :: Word))) +#endif +\end{code} + + +%************************************************************************ +%* * +\subsection{Vaguely generic functions +%* * +%************************************************************************ + +\begin{code} +type RuleFun = [CoreExpr] -> Maybe CoreExpr + +twoLits :: (Literal -> Literal -> Maybe CoreExpr) -> RuleFun +twoLits rule [Lit l1, Lit l2] = rule (convFloating l1) (convFloating l2) +twoLits rule _ = Nothing + +oneLit :: (Literal -> Maybe CoreExpr) -> RuleFun +oneLit rule [Lit l1] = rule (convFloating l1) +oneLit rule _ = Nothing + +-- When excess precision is not requested, cut down the precision of the +-- Rational value to that of Float/Double. We confuse host architecture +-- and target architecture here, but it's convenient (and wrong :-). +convFloating :: Literal -> Literal +convFloating (MachFloat f) | not opt_SimplExcessPrecision = + MachFloat (toRational ((fromRational f) :: Float )) +convFloating (MachDouble d) | not opt_SimplExcessPrecision = + MachDouble (toRational ((fromRational d) :: Double)) +convFloating l = l + + +trueVal = Var trueDataConId +falseVal = Var falseDataConId +mkIntVal i = Lit (mkMachInt i) +mkWordVal w = Lit (mkMachWord w) +mkFloatVal f = Lit (convFloating (MachFloat f)) +mkDoubleVal d = Lit (convFloating (MachDouble d)) +\end{code} + + +%************************************************************************ +%* * +\subsection{Special rules for seq, tagToEnum, dataToTag} +%* * +%************************************************************************ + +\begin{code} +tagToEnumRule [Type ty, Lit (MachInt i)] + = ASSERT( isEnumerationTyCon tycon ) + case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of + + + [] -> Nothing -- Abstract type + (dc:rest) -> ASSERT( null rest ) + Just (Var (dataConWorkId dc)) + where + correct_tag dc = (dataConTag dc - fIRST_TAG) == tag + tag = fromInteger i + tycon = tyConAppTyCon ty + +tagToEnumRule other = Nothing +\end{code} + +For dataToTag#, we can reduce if either + + (a) the argument is a constructor + (b) the argument is a variable whose unfolding is a known constructor + +\begin{code} +dataToTagRule [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] + | Just TagToEnumOp <- isPrimOpId_maybe tag_to_enum + , ty1 `coreEqType` ty2 + = Just tag -- dataToTag (tagToEnum x) ==> x + +dataToTagRule [_, val_arg] + | Just (dc,_) <- exprIsConApp_maybe val_arg + = ASSERT( not (isNewTyCon (dataConTyCon dc)) ) + Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG))) + +dataToTagRule other = Nothing +\end{code} + +%************************************************************************ +%* * +\subsection{Built in rules} +%* * +%************************************************************************ + +\begin{code} +builtinRules :: [CoreRule] +-- Rules for non-primops that can't be expressed using a RULE pragma +builtinRules + = [ BuiltinRule FSLIT("AppendLitString") unpackCStringFoldrName match_append_lit, + BuiltinRule FSLIT("EqString") eqStringName match_eq_string + ] + + +-- The rule is this: +-- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) = unpackFoldrCString# "foobaz" c n + +match_append_lit [Type ty1, + Lit (MachStr s1), + c1, + Var unpk `App` Type ty2 + `App` Lit (MachStr s2) + `App` c2 + `App` n + ] + | unpk `hasKey` unpackCStringFoldrIdKey && + c1 `cheapEqExpr` c2 + = ASSERT( ty1 `coreEqType` ty2 ) + Just (Var unpk `App` Type ty1 + `App` Lit (MachStr (s1 `appendFS` s2)) + `App` c1 + `App` n) + +match_append_lit other = Nothing + +-- The rule is this: +-- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2 + +match_eq_string [Var unpk1 `App` Lit (MachStr s1), + Var unpk2 `App` Lit (MachStr s2)] + | unpk1 `hasKey` unpackCStringIdKey, + unpk2 `hasKey` unpackCStringIdKey + = Just (if s1 == s2 then trueVal else falseVal) + +match_eq_string other = Nothing +\end{code} diff --git a/compiler/prelude/PrimOp.lhs b/compiler/prelude/PrimOp.lhs new file mode 100644 index 0000000000..a650352280 --- /dev/null +++ b/compiler/prelude/PrimOp.lhs @@ -0,0 +1,461 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[PrimOp]{Primitive operations (machine-level)} + +\begin{code} +module PrimOp ( + PrimOp(..), allThePrimOps, + primOpType, primOpSig, + primOpTag, maxPrimOpTag, primOpOcc, + + primOpOutOfLine, primOpNeedsWrapper, + primOpOkForSpeculation, primOpIsCheap, primOpIsDupable, + + getPrimOpResultInfo, PrimOpResultInfo(..) + ) where + +#include "HsVersions.h" + +import TysPrim +import TysWiredIn + +import NewDemand +import Var ( TyVar ) +import OccName ( OccName, pprOccName, mkVarOccFS ) +import TyCon ( TyCon, isPrimTyCon, tyConPrimRep, PrimRep(..) ) +import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, tyConAppTyCon, + typePrimRep ) +import BasicTypes ( Arity, Boxity(..) ) +import Outputable +import FastTypes +\end{code} + +%************************************************************************ +%* * +\subsection[PrimOp-datatype]{Datatype for @PrimOp@ (an enumeration)} +%* * +%************************************************************************ + +These are in \tr{state-interface.verb} order. + +\begin{code} + +-- supplies: +-- data PrimOp = ... +#include "primop-data-decl.hs-incl" +\end{code} + +Used for the Ord instance + +\begin{code} +primOpTag :: PrimOp -> Int +primOpTag op = iBox (tagOf_PrimOp op) + +-- supplies +-- tagOf_PrimOp :: PrimOp -> FastInt +#include "primop-tag.hs-incl" + + +instance Eq PrimOp where + op1 == op2 = tagOf_PrimOp op1 ==# tagOf_PrimOp op2 + +instance Ord PrimOp where + op1 < op2 = tagOf_PrimOp op1 <# tagOf_PrimOp op2 + op1 <= op2 = tagOf_PrimOp op1 <=# tagOf_PrimOp op2 + op1 >= op2 = tagOf_PrimOp op1 >=# tagOf_PrimOp op2 + op1 > op2 = tagOf_PrimOp op1 ># tagOf_PrimOp op2 + op1 `compare` op2 | op1 < op2 = LT + | op1 == op2 = EQ + | otherwise = GT + +instance Outputable PrimOp where + ppr op = pprPrimOp op + +instance Show PrimOp where + showsPrec p op = showsPrecSDoc p (pprPrimOp op) +\end{code} + +An @Enum@-derived list would be better; meanwhile... (ToDo) + +\begin{code} +allThePrimOps :: [PrimOp] +allThePrimOps = +#include "primop-list.hs-incl" +\end{code} + +%************************************************************************ +%* * +\subsection[PrimOp-info]{The essential info about each @PrimOp@} +%* * +%************************************************************************ + +The @String@ in the @PrimOpInfos@ is the ``base name'' by which the user may +refer to the primitive operation. The conventional \tr{#}-for- +unboxed ops is added on later. + +The reason for the funny characters in the names is so we do not +interfere with the programmer's Haskell name spaces. + +We use @PrimKinds@ for the ``type'' information, because they're +(slightly) more convenient to use than @TyCons@. +\begin{code} +data PrimOpInfo + = Dyadic OccName -- string :: T -> T -> T + Type + | Monadic OccName -- string :: T -> T + Type + | Compare OccName -- string :: T -> T -> Bool + Type + + | GenPrimOp OccName -- string :: \/a1..an . T1 -> .. -> Tk -> T + [TyVar] + [Type] + Type + +mkDyadic str ty = Dyadic (mkVarOccFS str) ty +mkMonadic str ty = Monadic (mkVarOccFS str) ty +mkCompare str ty = Compare (mkVarOccFS str) ty +mkGenPrimOp str tvs tys ty = GenPrimOp (mkVarOccFS str) tvs tys ty +\end{code} + +%************************************************************************ +%* * +\subsubsection{Strictness} +%* * +%************************************************************************ + +Not all primops are strict! + +\begin{code} +primOpStrictness :: PrimOp -> Arity -> StrictSig + -- See Demand.StrictnessInfo for discussion of what the results + -- The arity should be the arity of the primop; that's why + -- this function isn't exported. +#include "primop-strictness.hs-incl" +\end{code} + +%************************************************************************ +%* * +\subsubsection[PrimOp-comparison]{PrimOpInfo basic comparison ops} +%* * +%************************************************************************ + +@primOpInfo@ gives all essential information (from which everything +else, notably a type, can be constructed) for each @PrimOp@. + +\begin{code} +primOpInfo :: PrimOp -> PrimOpInfo +#include "primop-primop-info.hs-incl" +\end{code} + +Here are a load of comments from the old primOp info: + +A @Word#@ is an unsigned @Int#@. + +@decodeFloat#@ is given w/ Integer-stuff (it's similar). + +@decodeDouble#@ is given w/ Integer-stuff (it's similar). + +Decoding of floating-point numbers is sorta Integer-related. Encoding +is done with plain ccalls now (see PrelNumExtra.lhs). + +A @Weak@ Pointer is created by the @mkWeak#@ primitive: + + mkWeak# :: k -> v -> f -> State# RealWorld + -> (# State# RealWorld, Weak# v #) + +In practice, you'll use the higher-level + + data Weak v = Weak# v + mkWeak :: k -> v -> IO () -> IO (Weak v) + +The following operation dereferences a weak pointer. The weak pointer +may have been finalized, so the operation returns a result code which +must be inspected before looking at the dereferenced value. + + deRefWeak# :: Weak# v -> State# RealWorld -> + (# State# RealWorld, v, Int# #) + +Only look at v if the Int# returned is /= 0 !! + +The higher-level op is + + deRefWeak :: Weak v -> IO (Maybe v) + +Weak pointers can be finalized early by using the finalize# operation: + + finalizeWeak# :: Weak# v -> State# RealWorld -> + (# State# RealWorld, Int#, IO () #) + +The Int# returned is either + + 0 if the weak pointer has already been finalized, or it has no + finalizer (the third component is then invalid). + + 1 if the weak pointer is still alive, with the finalizer returned + as the third component. + +A {\em stable name/pointer} is an index into a table of stable name +entries. Since the garbage collector is told about stable pointers, +it is safe to pass a stable pointer to external systems such as C +routines. + +\begin{verbatim} +makeStablePtr# :: a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #) +freeStablePtr :: StablePtr# a -> State# RealWorld -> State# RealWorld +deRefStablePtr# :: StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #) +eqStablePtr# :: StablePtr# a -> StablePtr# a -> Int# +\end{verbatim} + +It may seem a bit surprising that @makeStablePtr#@ is a @IO@ +operation since it doesn't (directly) involve IO operations. The +reason is that if some optimisation pass decided to duplicate calls to +@makeStablePtr#@ and we only pass one of the stable pointers over, a +massive space leak can result. Putting it into the IO monad +prevents this. (Another reason for putting them in a monad is to +ensure correct sequencing wrt the side-effecting @freeStablePtr@ +operation.) + +An important property of stable pointers is that if you call +makeStablePtr# twice on the same object you get the same stable +pointer back. + +Note that we can implement @freeStablePtr#@ using @_ccall_@ (and, +besides, it's not likely to be used from Haskell) so it's not a +primop. + +Question: Why @RealWorld@ - won't any instance of @_ST@ do the job? [ADR] + +Stable Names +~~~~~~~~~~~~ + +A stable name is like a stable pointer, but with three important differences: + + (a) You can't deRef one to get back to the original object. + (b) You can convert one to an Int. + (c) You don't need to 'freeStableName' + +The existence of a stable name doesn't guarantee to keep the object it +points to alive (unlike a stable pointer), hence (a). + +Invariants: + + (a) makeStableName always returns the same value for a given + object (same as stable pointers). + + (b) if two stable names are equal, it implies that the objects + from which they were created were the same. + + (c) stableNameToInt always returns the same Int for a given + stable name. + + +-- HWL: The first 4 Int# in all par... annotations denote: +-- name, granularity info, size of result, degree of parallelism +-- Same structure as _seq_ i.e. returns Int# +-- KSW: v, the second arg in parAt# and parAtForNow#, is used only to determine +-- `the processor containing the expression v'; it is not evaluated + +These primops are pretty wierd. + + dataToTag# :: a -> Int (arg must be an evaluated data type) + tagToEnum# :: Int -> a (result type must be an enumerated type) + +The constraints aren't currently checked by the front end, but the +code generator will fall over if they aren't satisfied. + +\begin{code} +#ifdef DEBUG +primOpInfo op = pprPanic "primOpInfo:" (ppr op) +#endif +\end{code} + +%************************************************************************ +%* * +\subsubsection[PrimOp-ool]{Which PrimOps are out-of-line} +%* * +%************************************************************************ + +Some PrimOps need to be called out-of-line because they either need to +perform a heap check or they block. + + +\begin{code} +primOpOutOfLine :: PrimOp -> Bool +#include "primop-out-of-line.hs-incl" +\end{code} + + +primOpOkForSpeculation +~~~~~~~~~~~~~~~~~~~~~~ +Sometimes we may choose to execute a PrimOp even though it isn't +certain that its result will be required; ie execute them +``speculatively''. The same thing as ``cheap eagerness.'' Usually +this is OK, because PrimOps are usually cheap, but it isn't OK for +(a)~expensive PrimOps and (b)~PrimOps which can fail. + +PrimOps that have side effects also should not be executed speculatively. + +Ok-for-speculation also means that it's ok *not* to execute the +primop. For example + case op a b of + r -> 3 +Here the result is not used, so we can discard the primop. Anything +that has side effects mustn't be dicarded in this way, of course! + +See also @primOpIsCheap@ (below). + + +\begin{code} +primOpOkForSpeculation :: PrimOp -> Bool + -- See comments with CoreUtils.exprOkForSpeculation +primOpOkForSpeculation op + = not (primOpHasSideEffects op || primOpOutOfLine op || primOpCanFail op) +\end{code} + + +primOpIsCheap +~~~~~~~~~~~~~ +@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. "Cheap" means willing to call it more +than once, and/or push it inside a lambda. The latter could change the +behaviour of 'seq' for primops that can fail, so we don't treat them as cheap. + +\begin{code} +primOpIsCheap :: PrimOp -> Bool +primOpIsCheap op = primOpOkForSpeculation op +-- In March 2001, we changed this to +-- primOpIsCheap op = False +-- thereby making *no* primops seem cheap. But this killed eta +-- expansion on case (x ==# y) of True -> \s -> ... +-- which is bad. In particular a loop like +-- doLoop n = loop 0 +-- where +-- loop i | i == n = return () +-- | otherwise = bar i >> loop (i+1) +-- allocated a closure every time round because it doesn't eta expand. +-- +-- The problem that originally gave rise to the change was +-- let x = a +# b *# c in x +# x +-- were we don't want to inline x. But primopIsCheap doesn't control +-- that (it's exprIsDupable that does) so the problem doesn't occur +-- even if primOpIsCheap sometimes says 'True'. +\end{code} + +primOpIsDupable +~~~~~~~~~~~~~~~ +primOpIsDupable means that the use of the primop is small enough to +duplicate into different case branches. See CoreUtils.exprIsDupable. + +\begin{code} +primOpIsDupable :: PrimOp -> Bool + -- See comments with CoreUtils.exprIsDupable + -- We say it's dupable it isn't implemented by a C call with a wrapper +primOpIsDupable op = not (primOpNeedsWrapper op) +\end{code} + + +\begin{code} +primOpCanFail :: PrimOp -> Bool +#include "primop-can-fail.hs-incl" +\end{code} + +And some primops have side-effects and so, for example, must not be +duplicated. + +\begin{code} +primOpHasSideEffects :: PrimOp -> Bool +#include "primop-has-side-effects.hs-incl" +\end{code} + +Inline primitive operations that perform calls need wrappers to save +any live variables that are stored in caller-saves registers. + +\begin{code} +primOpNeedsWrapper :: PrimOp -> Bool +#include "primop-needs-wrapper.hs-incl" +\end{code} + +\begin{code} +primOpType :: PrimOp -> Type -- you may want to use primOpSig instead +primOpType op + = case (primOpInfo op) of + Dyadic occ ty -> dyadic_fun_ty ty + Monadic occ ty -> monadic_fun_ty ty + Compare occ ty -> compare_fun_ty ty + + GenPrimOp occ tyvars arg_tys res_ty -> + mkForAllTys tyvars (mkFunTys arg_tys res_ty) + +primOpOcc :: PrimOp -> OccName +primOpOcc op = case (primOpInfo op) of + Dyadic occ _ -> occ + Monadic occ _ -> occ + Compare occ _ -> occ + GenPrimOp occ _ _ _ -> occ + +-- primOpSig is like primOpType but gives the result split apart: +-- (type variables, argument types, result type) +-- It also gives arity, strictness info + +primOpSig :: PrimOp -> ([TyVar], [Type], Type, Arity, StrictSig) +primOpSig op + = (tyvars, arg_tys, res_ty, arity, primOpStrictness op arity) + where + arity = length arg_tys + (tyvars, arg_tys, res_ty) + = case (primOpInfo op) of + Monadic occ ty -> ([], [ty], ty ) + Dyadic occ ty -> ([], [ty,ty], ty ) + Compare occ ty -> ([], [ty,ty], boolTy) + GenPrimOp occ tyvars arg_tys res_ty + -> (tyvars, arg_tys, res_ty) +\end{code} + +\begin{code} +data PrimOpResultInfo + = ReturnsPrim PrimRep + | ReturnsAlg TyCon + +-- Some PrimOps need not return a manifest primitive or algebraic value +-- (i.e. they might return a polymorphic value). These PrimOps *must* +-- be out of line, or the code generator won't work. + +getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo +getPrimOpResultInfo op + = case (primOpInfo op) of + Dyadic _ ty -> ReturnsPrim (typePrimRep ty) + Monadic _ ty -> ReturnsPrim (typePrimRep ty) + Compare _ ty -> ReturnsAlg boolTyCon + GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep tc) + | otherwise -> ReturnsAlg tc + where + tc = tyConAppTyCon ty + -- All primops return a tycon-app result + -- The tycon can be an unboxed tuple, though, which + -- gives rise to a ReturnAlg +\end{code} + +The commutable ops are those for which we will try to move constants +to the right hand side for strength reduction. + +\begin{code} +commutableOp :: PrimOp -> Bool +#include "primop-commutable.hs-incl" +\end{code} + +Utils: +\begin{code} +dyadic_fun_ty ty = mkFunTys [ty, ty] ty +monadic_fun_ty ty = mkFunTy ty ty +compare_fun_ty ty = mkFunTys [ty, ty] boolTy +\end{code} + +Output stuff: +\begin{code} +pprPrimOp :: PrimOp -> SDoc +pprPrimOp other_op = pprOccName (primOpOcc other_op) +\end{code} + diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs new file mode 100644 index 0000000000..2f6168bafb --- /dev/null +++ b/compiler/prelude/TysPrim.lhs @@ -0,0 +1,392 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1998 +% +\section[TysPrim]{Wired-in knowledge about primitive types} + +\begin{code} +module TysPrim( + alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, + alphaTy, betaTy, gammaTy, deltaTy, + openAlphaTy, openAlphaTyVar, openAlphaTyVars, + + primTyCons, + + charPrimTyCon, charPrimTy, + intPrimTyCon, intPrimTy, + wordPrimTyCon, wordPrimTy, + addrPrimTyCon, addrPrimTy, + floatPrimTyCon, floatPrimTy, + doublePrimTyCon, doublePrimTy, + + statePrimTyCon, mkStatePrimTy, + realWorldTyCon, realWorldTy, realWorldStatePrimTy, + + arrayPrimTyCon, mkArrayPrimTy, + byteArrayPrimTyCon, byteArrayPrimTy, + mutableArrayPrimTyCon, mkMutableArrayPrimTy, + mutableByteArrayPrimTyCon, mkMutableByteArrayPrimTy, + mutVarPrimTyCon, mkMutVarPrimTy, + + mVarPrimTyCon, mkMVarPrimTy, + tVarPrimTyCon, mkTVarPrimTy, + stablePtrPrimTyCon, mkStablePtrPrimTy, + stableNamePrimTyCon, mkStableNamePrimTy, + bcoPrimTyCon, bcoPrimTy, + weakPrimTyCon, mkWeakPrimTy, + threadIdPrimTyCon, threadIdPrimTy, + + int32PrimTyCon, int32PrimTy, + word32PrimTyCon, word32PrimTy, + + int64PrimTyCon, int64PrimTy, + word64PrimTyCon, word64PrimTy + ) where + +#include "HsVersions.h" + +import Var ( TyVar, mkTyVar ) +import Name ( Name, BuiltInSyntax(..), mkInternalName, mkWiredInName ) +import OccName ( mkOccNameFS, tcName, mkTyVarOcc ) +import TyCon ( TyCon, ArgVrcs, mkPrimTyCon, mkLiftedPrimTyCon, + PrimRep(..) ) +import Type ( mkTyConApp, mkTyConTy, mkTyVarTys, mkTyVarTy, + unliftedTypeKind, liftedTypeKind, openTypeKind, + Kind, mkArrowKinds, + TyThing(..) + ) +import SrcLoc ( noSrcLoc ) +import Unique ( mkAlphaTyVarUnique ) +import PrelNames +import FastString ( FastString, mkFastString ) +import Outputable + +import Char ( ord, chr ) +\end{code} + +%************************************************************************ +%* * +\subsection{Primitive type constructors} +%* * +%************************************************************************ + +\begin{code} +primTyCons :: [TyCon] +primTyCons + = [ addrPrimTyCon + , arrayPrimTyCon + , byteArrayPrimTyCon + , charPrimTyCon + , doublePrimTyCon + , floatPrimTyCon + , intPrimTyCon + , int32PrimTyCon + , int64PrimTyCon + , bcoPrimTyCon + , weakPrimTyCon + , mutableArrayPrimTyCon + , mutableByteArrayPrimTyCon + , mVarPrimTyCon + , tVarPrimTyCon + , mutVarPrimTyCon + , realWorldTyCon + , stablePtrPrimTyCon + , stableNamePrimTyCon + , statePrimTyCon + , threadIdPrimTyCon + , wordPrimTyCon + , word32PrimTyCon + , word64PrimTyCon + ] + +mkPrimTc :: FastString -> Unique -> TyCon -> Name +mkPrimTc fs uniq tycon + = mkWiredInName gHC_PRIM (mkOccNameFS tcName fs) + uniq + Nothing -- No parent object + (ATyCon tycon) -- Relevant TyCon + UserSyntax -- None are built-in syntax + +charPrimTyConName = mkPrimTc FSLIT("Char#") charPrimTyConKey charPrimTyCon +intPrimTyConName = mkPrimTc FSLIT("Int#") intPrimTyConKey intPrimTyCon +int32PrimTyConName = mkPrimTc FSLIT("Int32#") int32PrimTyConKey int32PrimTyCon +int64PrimTyConName = mkPrimTc FSLIT("Int64#") int64PrimTyConKey int64PrimTyCon +wordPrimTyConName = mkPrimTc FSLIT("Word#") wordPrimTyConKey wordPrimTyCon +word32PrimTyConName = mkPrimTc FSLIT("Word32#") word32PrimTyConKey word32PrimTyCon +word64PrimTyConName = mkPrimTc FSLIT("Word64#") word64PrimTyConKey word64PrimTyCon +addrPrimTyConName = mkPrimTc FSLIT("Addr#") addrPrimTyConKey addrPrimTyCon +floatPrimTyConName = mkPrimTc FSLIT("Float#") floatPrimTyConKey floatPrimTyCon +doublePrimTyConName = mkPrimTc FSLIT("Double#") doublePrimTyConKey doublePrimTyCon +statePrimTyConName = mkPrimTc FSLIT("State#") statePrimTyConKey statePrimTyCon +realWorldTyConName = mkPrimTc FSLIT("RealWorld") realWorldTyConKey realWorldTyCon +arrayPrimTyConName = mkPrimTc FSLIT("Array#") arrayPrimTyConKey arrayPrimTyCon +byteArrayPrimTyConName = mkPrimTc FSLIT("ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon +mutableArrayPrimTyConName = mkPrimTc FSLIT("MutableArray#") mutableArrayPrimTyConKey mutableArrayPrimTyCon +mutableByteArrayPrimTyConName = mkPrimTc FSLIT("MutableByteArray#") mutableByteArrayPrimTyConKey mutableByteArrayPrimTyCon +mutVarPrimTyConName = mkPrimTc FSLIT("MutVar#") mutVarPrimTyConKey mutVarPrimTyCon +mVarPrimTyConName = mkPrimTc FSLIT("MVar#") mVarPrimTyConKey mVarPrimTyCon +tVarPrimTyConName = mkPrimTc FSLIT("TVar#") tVarPrimTyConKey tVarPrimTyCon +stablePtrPrimTyConName = mkPrimTc FSLIT("StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon +stableNamePrimTyConName = mkPrimTc FSLIT("StableName#") stableNamePrimTyConKey stableNamePrimTyCon +bcoPrimTyConName = mkPrimTc FSLIT("BCO#") bcoPrimTyConKey bcoPrimTyCon +weakPrimTyConName = mkPrimTc FSLIT("Weak#") weakPrimTyConKey weakPrimTyCon +threadIdPrimTyConName = mkPrimTc FSLIT("ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon +\end{code} + +%************************************************************************ +%* * +\subsection{Support code} +%* * +%************************************************************************ + +alphaTyVars is a list of type variables for use in templates: + ["a", "b", ..., "z", "t1", "t2", ... ] + +\begin{code} +tyVarList :: Kind -> [TyVar] +tyVarList kind = [ mkTyVar (mkInternalName (mkAlphaTyVarUnique u) + (mkTyVarOcc (mkFastString name)) + noSrcLoc) kind + | u <- [2..], + let name | c <= 'z' = [c] + | otherwise = 't':show u + where c = chr (u-2 + ord 'a') + ] + +alphaTyVars :: [TyVar] +alphaTyVars = tyVarList liftedTypeKind + +betaTyVars = tail alphaTyVars + +alphaTyVar, betaTyVar, gammaTyVar :: TyVar +(alphaTyVar:betaTyVar:gammaTyVar:deltaTyVar:_) = alphaTyVars + +alphaTys = mkTyVarTys alphaTyVars +(alphaTy:betaTy:gammaTy:deltaTy:_) = alphaTys + + -- openAlphaTyVar is prepared to be instantiated + -- to a lifted or unlifted type variable. It's used for the + -- result type for "error", so that we can have (error Int# "Help") +openAlphaTyVars :: [TyVar] +openAlphaTyVars@(openAlphaTyVar:_) = tyVarList openTypeKind + +openAlphaTy = mkTyVarTy openAlphaTyVar + +vrcPos,vrcZero :: (Bool,Bool) +vrcPos = (True,False) +vrcZero = (False,False) + +vrcsP,vrcsZ,vrcsZP :: ArgVrcs +vrcsP = [vrcPos] +vrcsZ = [vrcZero] +vrcsZP = [vrcZero,vrcPos] +\end{code} + + +%************************************************************************ +%* * +\subsection[TysPrim-basic]{Basic primitive types (@Char#@, @Int#@, etc.)} +%* * +%************************************************************************ + +\begin{code} +-- only used herein +pcPrimTyCon :: Name -> ArgVrcs -> PrimRep -> TyCon +pcPrimTyCon name arg_vrcs rep + = mkPrimTyCon name kind arity arg_vrcs rep + where + arity = length arg_vrcs + kind = mkArrowKinds (replicate arity liftedTypeKind) result_kind + result_kind = unliftedTypeKind -- all primitive types are unlifted + +pcPrimTyCon0 :: Name -> PrimRep -> TyCon +pcPrimTyCon0 name rep + = mkPrimTyCon name result_kind 0 [] rep + where + result_kind = unliftedTypeKind -- all primitive types are unlifted + +charPrimTy = mkTyConTy charPrimTyCon +charPrimTyCon = pcPrimTyCon0 charPrimTyConName WordRep + +intPrimTy = mkTyConTy intPrimTyCon +intPrimTyCon = pcPrimTyCon0 intPrimTyConName IntRep + +int32PrimTy = mkTyConTy int32PrimTyCon +int32PrimTyCon = pcPrimTyCon0 int32PrimTyConName IntRep + +int64PrimTy = mkTyConTy int64PrimTyCon +int64PrimTyCon = pcPrimTyCon0 int64PrimTyConName Int64Rep + +wordPrimTy = mkTyConTy wordPrimTyCon +wordPrimTyCon = pcPrimTyCon0 wordPrimTyConName WordRep + +word32PrimTy = mkTyConTy word32PrimTyCon +word32PrimTyCon = pcPrimTyCon0 word32PrimTyConName WordRep + +word64PrimTy = mkTyConTy word64PrimTyCon +word64PrimTyCon = pcPrimTyCon0 word64PrimTyConName Word64Rep + +addrPrimTy = mkTyConTy addrPrimTyCon +addrPrimTyCon = pcPrimTyCon0 addrPrimTyConName AddrRep + +floatPrimTy = mkTyConTy floatPrimTyCon +floatPrimTyCon = pcPrimTyCon0 floatPrimTyConName FloatRep + +doublePrimTy = mkTyConTy doublePrimTyCon +doublePrimTyCon = pcPrimTyCon0 doublePrimTyConName DoubleRep +\end{code} + + +%************************************************************************ +%* * +\subsection[TysPrim-state]{The @State#@ type (and @_RealWorld@ types)} +%* * +%************************************************************************ + +State# is the primitive, unlifted type of states. It has one type parameter, +thus + State# RealWorld +or + State# s + +where s is a type variable. The only purpose of the type parameter is to +keep different state threads separate. It is represented by nothing at all. + +\begin{code} +mkStatePrimTy ty = mkTyConApp statePrimTyCon [ty] +statePrimTyCon = pcPrimTyCon statePrimTyConName vrcsZ VoidRep +\end{code} + +RealWorld is deeply magical. It is *primitive*, but it is not +*unlifted* (hence ptrArg). We never manipulate values of type +RealWorld; it's only used in the type system, to parameterise State#. + +\begin{code} +realWorldTyCon = mkLiftedPrimTyCon realWorldTyConName liftedTypeKind 0 [] PtrRep +realWorldTy = mkTyConTy realWorldTyCon +realWorldStatePrimTy = mkStatePrimTy realWorldTy -- State# RealWorld +\end{code} + +Note: the ``state-pairing'' types are not truly primitive, so they are +defined in \tr{TysWiredIn.lhs}, not here. + + +%************************************************************************ +%* * +\subsection[TysPrim-arrays]{The primitive array types} +%* * +%************************************************************************ + +\begin{code} +arrayPrimTyCon = pcPrimTyCon arrayPrimTyConName vrcsP PtrRep +mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConName vrcsZP PtrRep +mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConName vrcsZ PtrRep +byteArrayPrimTyCon = pcPrimTyCon0 byteArrayPrimTyConName PtrRep + +mkArrayPrimTy elt = mkTyConApp arrayPrimTyCon [elt] +byteArrayPrimTy = mkTyConTy byteArrayPrimTyCon +mkMutableArrayPrimTy s elt = mkTyConApp mutableArrayPrimTyCon [s, elt] +mkMutableByteArrayPrimTy s = mkTyConApp mutableByteArrayPrimTyCon [s] +\end{code} + +%************************************************************************ +%* * +\subsection[TysPrim-mut-var]{The mutable variable type} +%* * +%************************************************************************ + +\begin{code} +mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName vrcsZP PtrRep + +mkMutVarPrimTy s elt = mkTyConApp mutVarPrimTyCon [s, elt] +\end{code} + +%************************************************************************ +%* * +\subsection[TysPrim-synch-var]{The synchronizing variable type} +%* * +%************************************************************************ + +\begin{code} +mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName vrcsZP PtrRep + +mkMVarPrimTy s elt = mkTyConApp mVarPrimTyCon [s, elt] +\end{code} + +%************************************************************************ +%* * +\subsection[TysPrim-stm-var]{The transactional variable type} +%* * +%************************************************************************ + +\begin{code} +tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName vrcsZP PtrRep + +mkTVarPrimTy s elt = mkTyConApp tVarPrimTyCon [s, elt] +\end{code} + +%************************************************************************ +%* * +\subsection[TysPrim-stable-ptrs]{The stable-pointer type} +%* * +%************************************************************************ + +\begin{code} +stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName vrcsP AddrRep + +mkStablePtrPrimTy ty = mkTyConApp stablePtrPrimTyCon [ty] +\end{code} + +%************************************************************************ +%* * +\subsection[TysPrim-stable-names]{The stable-name type} +%* * +%************************************************************************ + +\begin{code} +stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName vrcsP PtrRep + +mkStableNamePrimTy ty = mkTyConApp stableNamePrimTyCon [ty] +\end{code} + +%************************************************************************ +%* * +\subsection[TysPrim-BCOs]{The ``bytecode object'' type} +%* * +%************************************************************************ + +\begin{code} +bcoPrimTy = mkTyConTy bcoPrimTyCon +bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName PtrRep +\end{code} + +%************************************************************************ +%* * +\subsection[TysPrim-Weak]{The ``weak pointer'' type} +%* * +%************************************************************************ + +\begin{code} +weakPrimTyCon = pcPrimTyCon weakPrimTyConName vrcsP PtrRep + +mkWeakPrimTy v = mkTyConApp weakPrimTyCon [v] +\end{code} + +%************************************************************************ +%* * +\subsection[TysPrim-thread-ids]{The ``thread id'' type} +%* * +%************************************************************************ + +A thread id is represented by a pointer to the TSO itself, to ensure +that they are always unique and we can always find the TSO for a given +thread id. However, this has the unfortunate consequence that a +ThreadId# for a given thread is treated as a root by the garbage +collector and can keep TSOs around for too long. + +Hence the programmer API for thread manipulation uses a weak pointer +to the thread id internally. + +\begin{code} +threadIdPrimTy = mkTyConTy threadIdPrimTyCon +threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName PtrRep +\end{code} diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs new file mode 100644 index 0000000000..ceb4df550a --- /dev/null +++ b/compiler/prelude/TysWiredIn.lhs @@ -0,0 +1,549 @@ +% +% (c) The GRASP Project, Glasgow University, 1994-1998 +% +\section[TysWiredIn]{Wired-in knowledge about {\em non-primitive} types} + +This module is about types that can be defined in Haskell, but which +must be wired into the compiler nonetheless. + +This module tracks the ``state interface'' document, ``GHC prelude: +types and operations.'' + +\begin{code} +module TysWiredIn ( + wiredInTyCons, + + boolTy, boolTyCon, boolTyCon_RDR, boolTyConName, + trueDataCon, trueDataConId, true_RDR, + falseDataCon, falseDataConId, false_RDR, + + charTyCon, charDataCon, charTyCon_RDR, + charTy, stringTy, charTyConName, + + + doubleTyCon, doubleDataCon, doubleTy, doubleTyConName, + + floatTyCon, floatDataCon, floatTy, floatTyConName, + + intTyCon, intDataCon, intTyCon_RDR, intDataCon_RDR, intTyConName, + intTy, + + listTyCon, nilDataCon, consDataCon, + listTyCon_RDR, consDataCon_RDR, listTyConName, + mkListTy, + + -- tuples + mkTupleTy, + tupleTyCon, tupleCon, + unitTyCon, unitDataCon, unitDataConId, pairTyCon, + unboxedSingletonTyCon, unboxedSingletonDataCon, + unboxedPairTyCon, unboxedPairDataCon, + + unitTy, + voidTy, + + -- parallel arrays + mkPArrTy, + parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon, + parrTyCon_RDR, parrTyConName + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} MkId( mkDataConIds ) + +-- friends: +import PrelNames +import TysPrim + +-- others: +import Constants ( mAX_TUPLE_SIZE ) +import Module ( Module ) +import RdrName ( nameRdrName ) +import Name ( Name, BuiltInSyntax(..), nameUnique, nameOccName, + nameModule, mkWiredInName ) +import OccName ( mkOccNameFS, tcName, dataName, mkTupleOcc, + mkDataConWorkerOcc ) +import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity ) +import Var ( TyVar, tyVarKind ) +import TyCon ( TyCon, AlgTyConRhs(DataTyCon), tyConDataCons, + mkTupleTyCon, mkAlgTyCon, tyConName ) + +import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, + StrictnessMark(..) ) + +import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTy, mkTyVarTys, + TyThing(..) ) +import Kind ( mkArrowKinds, liftedTypeKind, ubxTupleKind ) +import Unique ( incrUnique, mkTupleTyConUnique, + mkTupleDataConUnique, mkPArrDataConUnique ) +import Array +import FastString +import Outputable + +alpha_tyvar = [alphaTyVar] +alpha_ty = [alphaTy] +\end{code} + + +%************************************************************************ +%* * +\subsection{Wired in type constructors} +%* * +%************************************************************************ + +If you change which things are wired in, make sure you change their +names in PrelNames, so they use wTcQual, wDataQual, etc + +\begin{code} +wiredInTyCons :: [TyCon] -- Excludes tuples +wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because + -- it's defined in GHC.Base, and there's only + -- one of it. We put it in wiredInTyCons so + -- that it'll pre-populate the name cache, so + -- the special case in lookupOrigNameCache + -- doesn't need to look out for it + , boolTyCon + , charTyCon + , doubleTyCon + , floatTyCon + , intTyCon + , listTyCon + , parrTyCon + ] +\end{code} + +\begin{code} +mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name +mkWiredInTyConName built_in mod fs uniq tycon + = mkWiredInName mod (mkOccNameFS tcName fs) uniq + Nothing -- No parent object + (ATyCon tycon) -- Relevant TyCon + built_in + +mkWiredInDataConName :: BuiltInSyntax -> Module -> FastString -> Unique -> DataCon -> Name -> Name +mkWiredInDataConName built_in mod fs uniq datacon parent + = mkWiredInName mod (mkOccNameFS dataName fs) uniq + (Just parent) -- Name of parent TyCon + (ADataCon datacon) -- Relevant DataCon + built_in + +charTyConName = mkWiredInTyConName UserSyntax pREL_BASE FSLIT("Char") charTyConKey charTyCon +charDataConName = mkWiredInDataConName UserSyntax pREL_BASE FSLIT("C#") charDataConKey charDataCon charTyConName +intTyConName = mkWiredInTyConName UserSyntax pREL_BASE FSLIT("Int") intTyConKey intTyCon +intDataConName = mkWiredInDataConName UserSyntax pREL_BASE FSLIT("I#") intDataConKey intDataCon intTyConName + +boolTyConName = mkWiredInTyConName UserSyntax pREL_BASE FSLIT("Bool") boolTyConKey boolTyCon +falseDataConName = mkWiredInDataConName UserSyntax pREL_BASE FSLIT("False") falseDataConKey falseDataCon boolTyConName +trueDataConName = mkWiredInDataConName UserSyntax pREL_BASE FSLIT("True") trueDataConKey trueDataCon boolTyConName +listTyConName = mkWiredInTyConName BuiltInSyntax pREL_BASE FSLIT("[]") listTyConKey listTyCon +nilDataConName = mkWiredInDataConName BuiltInSyntax pREL_BASE FSLIT("[]") nilDataConKey nilDataCon listTyConName +consDataConName = mkWiredInDataConName BuiltInSyntax pREL_BASE FSLIT(":") consDataConKey consDataCon listTyConName + +floatTyConName = mkWiredInTyConName UserSyntax pREL_FLOAT FSLIT("Float") floatTyConKey floatTyCon +floatDataConName = mkWiredInDataConName UserSyntax pREL_FLOAT FSLIT("F#") floatDataConKey floatDataCon floatTyConName +doubleTyConName = mkWiredInTyConName UserSyntax pREL_FLOAT FSLIT("Double") doubleTyConKey doubleTyCon +doubleDataConName = mkWiredInDataConName UserSyntax pREL_FLOAT FSLIT("D#") doubleDataConKey doubleDataCon doubleTyConName + +parrTyConName = mkWiredInTyConName BuiltInSyntax pREL_PARR FSLIT("[::]") parrTyConKey parrTyCon +parrDataConName = mkWiredInDataConName UserSyntax pREL_PARR FSLIT("PArr") parrDataConKey parrDataCon parrTyConName + +boolTyCon_RDR = nameRdrName boolTyConName +false_RDR = nameRdrName falseDataConName +true_RDR = nameRdrName trueDataConName +intTyCon_RDR = nameRdrName intTyConName +charTyCon_RDR = nameRdrName charTyConName +intDataCon_RDR = nameRdrName intDataConName +listTyCon_RDR = nameRdrName listTyConName +consDataCon_RDR = nameRdrName consDataConName +parrTyCon_RDR = nameRdrName parrTyConName +\end{code} + + +%************************************************************************ +%* * +\subsection{mkWiredInTyCon} +%* * +%************************************************************************ + +\begin{code} +pcNonRecDataTyCon = pcTyCon False NonRecursive +pcRecDataTyCon = pcTyCon False Recursive + +pcTyCon is_enum is_rec name tyvars argvrcs cons + = tycon + where + tycon = mkAlgTyCon name + (mkArrowKinds (map tyVarKind tyvars) liftedTypeKind) + tyvars + argvrcs + [] -- No stupid theta + (DataTyCon cons is_enum) + [] -- No record selectors + is_rec + True -- All the wired-in tycons have generics + +pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon +pcDataCon = pcDataConWithFixity False + +pcDataConWithFixity :: Bool -> Name -> [TyVar] -> [Type] -> TyCon -> DataCon +-- The Name should be in the DataName name space; it's the name +-- of the DataCon itself. +-- +-- The unique is the first of two free uniques; +-- the first is used for the datacon itself, +-- the second is used for the "worker name" + +pcDataConWithFixity declared_infix dc_name tyvars arg_tys tycon + = data_con + where + data_con = mkDataCon dc_name declared_infix True {- Vanilla -} + (map (const NotMarkedStrict) arg_tys) + [{- No labelled fields -}] + tyvars [] [] arg_tys tycon (mkTyVarTys tyvars) + (mkDataConIds bogus_wrap_name wrk_name data_con) + + + mod = nameModule dc_name + wrk_occ = mkDataConWorkerOcc (nameOccName dc_name) + wrk_key = incrUnique (nameUnique dc_name) + wrk_name = mkWiredInName mod wrk_occ wrk_key + (Just (tyConName tycon)) + (AnId (dataConWorkId data_con)) UserSyntax + bogus_wrap_name = pprPanic "Wired-in data wrapper id" (ppr dc_name) + -- Wired-in types are too simple to need wrappers +\end{code} + + +%************************************************************************ +%* * +\subsection[TysWiredIn-tuples]{The tuple types} +%* * +%************************************************************************ + +\begin{code} +tupleTyCon :: Boxity -> Arity -> TyCon +tupleTyCon boxity i | i > mAX_TUPLE_SIZE = fst (mk_tuple boxity i) -- Build one specially +tupleTyCon Boxed i = fst (boxedTupleArr ! i) +tupleTyCon Unboxed i = fst (unboxedTupleArr ! i) + +tupleCon :: Boxity -> Arity -> DataCon +tupleCon boxity i | i > mAX_TUPLE_SIZE = snd (mk_tuple boxity i) -- Build one specially +tupleCon Boxed i = snd (boxedTupleArr ! i) +tupleCon Unboxed i = snd (unboxedTupleArr ! i) + +boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon) +boxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Boxed i | i <- [0..mAX_TUPLE_SIZE]] +unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mAX_TUPLE_SIZE]] + +mk_tuple :: Boxity -> Int -> (TyCon,DataCon) +mk_tuple boxity arity = (tycon, tuple_con) + where + tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity gen_info + mod = mkTupleModule boxity arity + tc_name = mkWiredInName mod (mkTupleOcc tcName boxity arity) tc_uniq + Nothing (ATyCon tycon) BuiltInSyntax + tc_kind = mkArrowKinds (map tyVarKind tyvars) res_kind + res_kind | isBoxed boxity = liftedTypeKind + | otherwise = ubxTupleKind + + tyvars | isBoxed boxity = take arity alphaTyVars + | otherwise = take arity openAlphaTyVars + + tuple_con = pcDataCon dc_name tyvars tyvar_tys tycon + tyvar_tys = mkTyVarTys tyvars + dc_name = mkWiredInName mod (mkTupleOcc dataName boxity arity) dc_uniq + (Just tc_name) (ADataCon tuple_con) BuiltInSyntax + tc_uniq = mkTupleTyConUnique boxity arity + dc_uniq = mkTupleDataConUnique boxity arity + gen_info = True -- Tuples all have generics.. + -- hmm: that's a *lot* of code + +unitTyCon = tupleTyCon Boxed 0 +unitDataCon = head (tyConDataCons unitTyCon) +unitDataConId = dataConWorkId unitDataCon + +pairTyCon = tupleTyCon Boxed 2 + +unboxedSingletonTyCon = tupleTyCon Unboxed 1 +unboxedSingletonDataCon = tupleCon Unboxed 1 + +unboxedPairTyCon = tupleTyCon Unboxed 2 +unboxedPairDataCon = tupleCon Unboxed 2 +\end{code} + +%************************************************************************ +%* * +\subsection[TysWiredIn-boxed-prim]{The ``boxed primitive'' types (@Char@, @Int@, etc)} +%* * +%************************************************************************ + +\begin{code} +-- The Void type is represented as a data type with no constructors +-- It's a built in type (i.e. there's no way to define it in Haskell; +-- the nearest would be +-- +-- data Void = -- No constructors! +-- +-- ) It's lifted; there is only one value of this +-- type, namely "void", whose semantics is just bottom. +-- +-- Haskell 98 drops the definition of a Void type, so we just 'simulate' +-- voidTy using (). +voidTy = unitTy +\end{code} + + +\begin{code} +charTy = mkTyConTy charTyCon + +charTyCon = pcNonRecDataTyCon charTyConName [] [] [charDataCon] +charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon + +stringTy = mkListTy charTy -- convenience only +\end{code} + +\begin{code} +intTy = mkTyConTy intTyCon + +intTyCon = pcNonRecDataTyCon intTyConName [] [] [intDataCon] +intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon +\end{code} + +\begin{code} +floatTy = mkTyConTy floatTyCon + +floatTyCon = pcNonRecDataTyCon floatTyConName [] [] [floatDataCon] +floatDataCon = pcDataCon floatDataConName [] [floatPrimTy] floatTyCon +\end{code} + +\begin{code} +doubleTy = mkTyConTy doubleTyCon + +doubleTyCon = pcNonRecDataTyCon doubleTyConName [] [] [doubleDataCon] +doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon +\end{code} + + +%************************************************************************ +%* * +\subsection[TysWiredIn-Bool]{The @Bool@ type} +%* * +%************************************************************************ + +An ordinary enumeration type, but deeply wired in. There are no +magical operations on @Bool@ (just the regular Prelude code). + +{\em BEGIN IDLE SPECULATION BY SIMON} + +This is not the only way to encode @Bool@. A more obvious coding makes +@Bool@ just a boxed up version of @Bool#@, like this: +\begin{verbatim} +type Bool# = Int# +data Bool = MkBool Bool# +\end{verbatim} + +Unfortunately, this doesn't correspond to what the Report says @Bool@ +looks like! Furthermore, we get slightly less efficient code (I +think) with this coding. @gtInt@ would look like this: + +\begin{verbatim} +gtInt :: Int -> Int -> Bool +gtInt x y = case x of I# x# -> + case y of I# y# -> + case (gtIntPrim x# y#) of + b# -> MkBool b# +\end{verbatim} + +Notice that the result of the @gtIntPrim@ comparison has to be turned +into an integer (here called @b#@), and returned in a @MkBool@ box. + +The @if@ expression would compile to this: +\begin{verbatim} +case (gtInt x y) of + MkBool b# -> case b# of { 1# -> e1; 0# -> e2 } +\end{verbatim} + +I think this code is a little less efficient than the previous code, +but I'm not certain. At all events, corresponding with the Report is +important. The interesting thing is that the language is expressive +enough to describe more than one alternative; and that a type doesn't +necessarily need to be a straightforwardly boxed version of its +primitive counterpart. + +{\em END IDLE SPECULATION BY SIMON} + +\begin{code} +boolTy = mkTyConTy boolTyCon + +boolTyCon = pcTyCon True NonRecursive boolTyConName + [] [] [falseDataCon, trueDataCon] + +falseDataCon = pcDataCon falseDataConName [] [] boolTyCon +trueDataCon = pcDataCon trueDataConName [] [] boolTyCon + +falseDataConId = dataConWorkId falseDataCon +trueDataConId = dataConWorkId trueDataCon +\end{code} + +%************************************************************************ +%* * +\subsection[TysWiredIn-List]{The @List@ type (incl ``build'' magic)} +%* * +%************************************************************************ + +Special syntax, deeply wired in, but otherwise an ordinary algebraic +data types: +\begin{verbatim} +data [] a = [] | a : (List a) +data () = () +data (,) a b = (,,) a b +... +\end{verbatim} + +\begin{code} +mkListTy :: Type -> Type +mkListTy ty = mkTyConApp listTyCon [ty] + +listTyCon = pcRecDataTyCon listTyConName + alpha_tyvar [(True,False)] [nilDataCon, consDataCon] + +nilDataCon = pcDataCon nilDataConName alpha_tyvar [] listTyCon +consDataCon = pcDataConWithFixity True {- Declared infix -} + consDataConName + alpha_tyvar [alphaTy, mkTyConApp listTyCon alpha_ty] listTyCon +-- Interesting: polymorphic recursion would help here. +-- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy +-- gets the over-specific type (Type -> Type) +\end{code} + +%************************************************************************ +%* * +\subsection[TysWiredIn-Tuples]{The @Tuple@ types} +%* * +%************************************************************************ + +The tuple types are definitely magic, because they form an infinite +family. + +\begin{itemize} +\item +They have a special family of type constructors, of type @TyCon@ +These contain the tycon arity, but don't require a Unique. + +\item +They have a special family of constructors, of type +@Id@. Again these contain their arity but don't need a Unique. + +\item +There should be a magic way of generating the info tables and +entry code for all tuples. + +But at the moment we just compile a Haskell source +file\srcloc{lib/prelude/...} containing declarations like: +\begin{verbatim} +data Tuple0 = Tup0 +data Tuple2 a b = Tup2 a b +data Tuple3 a b c = Tup3 a b c +data Tuple4 a b c d = Tup4 a b c d +... +\end{verbatim} +The print-names associated with the magic @Id@s for tuple constructors +``just happen'' to be the same as those generated by these +declarations. + +\item +The instance environment should have a magic way to know +that each tuple type is an instances of classes @Eq@, @Ix@, @Ord@ and +so on. \ToDo{Not implemented yet.} + +\item +There should also be a way to generate the appropriate code for each +of these instances, but (like the info tables and entry code) it is +done by enumeration\srcloc{lib/prelude/InTup?.hs}. +\end{itemize} + +\begin{code} +mkTupleTy :: Boxity -> Int -> [Type] -> Type +mkTupleTy boxity arity tys = mkTyConApp (tupleTyCon boxity arity) tys + +unitTy = mkTupleTy Boxed 0 [] +\end{code} + +%************************************************************************ +%* * +\subsection[TysWiredIn-PArr]{The @[::]@ type} +%* * +%************************************************************************ + +Special syntax for parallel arrays needs some wired in definitions. + +\begin{code} +-- construct a type representing the application of the parallel array +-- constructor +-- +mkPArrTy :: Type -> Type +mkPArrTy ty = mkTyConApp parrTyCon [ty] + +-- represents the type constructor of parallel arrays +-- +-- * this must match the definition in `PrelPArr' +-- +-- NB: Although the constructor is given here, it will not be accessible in +-- user code as it is not in the environment of any compiled module except +-- `PrelPArr'. +-- +parrTyCon :: TyCon +parrTyCon = pcNonRecDataTyCon parrTyConName alpha_tyvar [(True, False)] [parrDataCon] + +parrDataCon :: DataCon +parrDataCon = pcDataCon + parrDataConName + alpha_tyvar -- forall'ed type variables + [intPrimTy, -- 1st argument: Int# + mkTyConApp -- 2nd argument: Array# a + arrayPrimTyCon + alpha_ty] + parrTyCon + +-- check whether a type constructor is the constructor for parallel arrays +-- +isPArrTyCon :: TyCon -> Bool +isPArrTyCon tc = tyConName tc == parrTyConName + +-- fake array constructors +-- +-- * these constructors are never really used to represent array values; +-- however, they are very convenient during desugaring (and, in particular, +-- in the pattern matching compiler) to treat array pattern just like +-- yet another constructor pattern +-- +parrFakeCon :: Arity -> DataCon +parrFakeCon i | i > mAX_TUPLE_SIZE = mkPArrFakeCon i -- build one specially +parrFakeCon i = parrFakeConArr!i + +-- pre-defined set of constructors +-- +parrFakeConArr :: Array Int DataCon +parrFakeConArr = array (0, mAX_TUPLE_SIZE) [(i, mkPArrFakeCon i) + | i <- [0..mAX_TUPLE_SIZE]] + +-- build a fake parallel array constructor for the given arity +-- +mkPArrFakeCon :: Int -> DataCon +mkPArrFakeCon arity = data_con + where + data_con = pcDataCon name [tyvar] tyvarTys parrTyCon + tyvar = head alphaTyVars + tyvarTys = replicate arity $ mkTyVarTy tyvar + nameStr = mkFastString ("MkPArr" ++ show arity) + name = mkWiredInName pREL_PARR (mkOccNameFS dataName nameStr) uniq + Nothing (ADataCon data_con) UserSyntax + uniq = mkPArrDataConUnique arity + +-- checks whether a data constructor is a fake constructor for parallel arrays +-- +isPArrFakeCon :: DataCon -> Bool +isPArrFakeCon dcon = dcon == parrFakeCon (dataConSourceArity dcon) +\end{code} + diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp new file mode 100644 index 0000000000..13b4b6c97d --- /dev/null +++ b/compiler/prelude/primops.txt.pp @@ -0,0 +1,1687 @@ +----------------------------------------------------------------------- +-- $Id: primops.txt.pp,v 1.37 2005/11/25 09:46:19 simonmar Exp $ +-- +-- Primitive Operations +-- +----------------------------------------------------------------------- + +-- This file is processed by the utility program genprimopcode to produce +-- a number of include files within the compiler and optionally to produce +-- human-readable documentation. +-- +-- It should first be preprocessed. +-- +-- To add a new primop, you currently need to update the following files: +-- +-- - this file (ghc/compiler/prelude/primops.txt.pp), which includes +-- the type of the primop, and various other properties (its +-- strictness attributes, whether it is defined as a macro +-- or as out-of-line code, etc.) +-- +-- - if the primop is inline (i.e. a macro), then: +-- ghc/compiler/AbsCUtils.lhs (dscCOpStmt) +-- defines the translation of the primop into simpler +-- abstract C operations. +-- +-- - or, for an out-of-line primop: +-- ghc/includes/StgMiscClosures.h (just add the declaration) +-- ghc/rts/PrimOps.cmm (define it here) +-- ghc/rts/Linker.c (declare the symbol for GHCi) +-- +-- - the User's Guide +-- + +-- This file is divided into named sections, each containing or more +-- primop entries. Section headers have the format: +-- +-- section "section-name" {description} +-- +-- This information is used solely when producing documentation; it is +-- otherwise ignored. The description is optional. +-- +-- The format of each primop entry is as follows: +-- +-- primop internal-name "name-in-program-text" type category {description} attributes + +-- The default attribute values which apply if you don't specify +-- other ones. Attribute values can be True, False, or arbitrary +-- text between curly brackets. This is a kludge to enable +-- processors of this file to easily get hold of simple info +-- (eg, out_of_line), whilst avoiding parsing complex expressions +-- needed for strictness and usage info. + +defaults + has_side_effects = False + out_of_line = False + commutable = False + needs_wrapper = False + can_fail = False + strictness = { \ arity -> mkStrictSig (mkTopDmdType (replicate arity lazyDmd) TopRes) } + usage = { nomangle other } + +-- Currently, documentation is produced using latex, so contents of +-- description fields should be legal latex. Descriptions can contain +-- matched pairs of embedded curly brackets. + +#include "MachDeps.h" + +-- We need platform defines (tests for mingw32 below). However, we only +-- test the TARGET platform, which doesn't vary between stages, so the +-- stage1 platform defines are fine: +#include "../stage1/ghc_boot_platform.h" + +section "The word size story." + {Haskell98 specifies that signed integers (type {\tt Int}) + must contain at least 30 bits. GHC always implements {\tt + Int} using the primitive type {\tt Int\#}, whose size equals + the {\tt MachDeps.h} constant {\tt WORD\_SIZE\_IN\_BITS}. + This is normally set based on the {\tt config.h} parameter + {\tt SIZEOF\_HSWORD}, i.e., 32 bits on 32-bit machines, 64 + bits on 64-bit machines. However, it can also be explicitly + set to a smaller number, e.g., 31 bits, to allow the + possibility of using tag bits. Currently GHC itself has only + 32-bit and 64-bit variants, but 30 or 31-bit code can be + exported as an external core file for use in other back ends. + + GHC also implements a primitive unsigned integer type {\tt + Word\#} which always has the same number of bits as {\tt + Int\#}. + + In addition, GHC supports families of explicit-sized integers + and words at 8, 16, 32, and 64 bits, with the usual + arithmetic operations, comparisons, and a range of + conversions. The 8-bit and 16-bit sizes are always + represented as {\tt Int\#} and {\tt Word\#}, and the + operations implemented in terms of the the primops on these + types, with suitable range restrictions on the results (using + the {\tt narrow$n$Int\#} and {\tt narrow$n$Word\#} families + of primops. The 32-bit sizes are represented using {\tt + Int\#} and {\tt Word\#} when {\tt WORD\_SIZE\_IN\_BITS} + $\geq$ 32; otherwise, these are represented using distinct + primitive types {\tt Int32\#} and {\tt Word32\#}. These (when + needed) have a complete set of corresponding operations; + however, nearly all of these are implemented as external C + functions rather than as primops. Exactly the same story + applies to the 64-bit sizes. All of these details are hidden + under the {\tt PrelInt} and {\tt PrelWord} modules, which use + {\tt \#if}-defs to invoke the appropriate types and + operators. + + Word size also matters for the families of primops for + indexing/reading/writing fixed-size quantities at offsets + from an array base, address, or foreign pointer. Here, a + slightly different approach is taken. The names of these + primops are fixed, but their {\it types} vary according to + the value of {\tt WORD\_SIZE\_IN\_BITS}. For example, if word + size is at least 32 bits then an operator like + \texttt{indexInt32Array\#} has type {\tt ByteArr\# -> Int\# + -> Int\#}; otherwise it has type {\tt ByteArr\# -> Int\# -> + Int32\#}. This approach confines the necessary {\tt + \#if}-defs to this file; no conditional compilation is needed + in the files that expose these primops. + + Finally, there are strongly deprecated primops for coercing + between {\tt Addr\#}, the primitive type of machine + addresses, and {\tt Int\#}. These are pretty bogus anyway, + but will work on existing 32-bit and 64-bit GHC targets; they + are completely bogus when tag bits are used in {\tt Int\#}, + so are not available in this case. } + +-- Define synonyms for indexing ops. + +#if WORD_SIZE_IN_BITS < 32 +#define INT32 Int32# +#define WORD32 Word32# +#else +#define INT32 Int# +#define WORD32 Word# +#endif + +#if WORD_SIZE_IN_BITS < 64 +#define INT64 Int64# +#define WORD64 Word64# +#else +#define INT64 Int# +#define WORD64 Word# +#endif + +------------------------------------------------------------------------ +section "Char#" + {Operations on 31-bit characters.} +------------------------------------------------------------------------ + + +primop CharGtOp "gtChar#" Compare Char# -> Char# -> Bool +primop CharGeOp "geChar#" Compare Char# -> Char# -> Bool + +primop CharEqOp "eqChar#" Compare + Char# -> Char# -> Bool + with commutable = True + +primop CharNeOp "neChar#" Compare + Char# -> Char# -> Bool + with commutable = True + +primop CharLtOp "ltChar#" Compare Char# -> Char# -> Bool +primop CharLeOp "leChar#" Compare Char# -> Char# -> Bool + +primop OrdOp "ord#" GenPrimOp Char# -> Int# + +------------------------------------------------------------------------ +section "Int#" + {Operations on native-size integers (30+ bits).} +------------------------------------------------------------------------ + +primop IntAddOp "+#" Dyadic + Int# -> Int# -> Int# + with commutable = True + +primop IntSubOp "-#" Dyadic Int# -> Int# -> Int# + +primop IntMulOp "*#" + Dyadic Int# -> Int# -> Int# + {Low word of signed integer multiply.} + with commutable = True + +primop IntMulMayOfloOp "mulIntMayOflo#" + Dyadic Int# -> Int# -> Int# + {Return non-zero if there is any possibility that the upper word of a + signed integer multiply might contain useful information. Return + zero only if you are completely sure that no overflow can occur. + On a 32-bit platform, the recommmended implementation is to do a + 32 x 32 -> 64 signed multiply, and subtract result[63:32] from + (result[31] >>signed 31). If this is zero, meaning that the + upper word is merely a sign extension of the lower one, no + overflow can occur. + + On a 64-bit platform it is not always possible to + acquire the top 64 bits of the result. Therefore, a recommended + implementation is to take the absolute value of both operands, and + return 0 iff bits[63:31] of them are zero, since that means that their + magnitudes fit within 31 bits, so the magnitude of the product must fit + into 62 bits. + + If in doubt, return non-zero, but do make an effort to create the + correct answer for small args, since otherwise the performance of + (*) :: Integer -> Integer -> Integer will be poor. + } + with commutable = True + +primop IntQuotOp "quotInt#" Dyadic + Int# -> Int# -> Int# + {Rounds towards zero.} + with can_fail = True + +primop IntRemOp "remInt#" Dyadic + Int# -> Int# -> Int# + {Satisfies \texttt{(quotInt\# x y) *\# y +\# (remInt\# x y) == x}.} + with can_fail = True + +primop IntGcdOp "gcdInt#" Dyadic Int# -> Int# -> Int# + with out_of_line = True + +primop IntNegOp "negateInt#" Monadic Int# -> Int# +primop IntAddCOp "addIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) + {Add with carry. First member of result is (wrapped) sum; + second member is 0 iff no overflow occured.} +primop IntSubCOp "subIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) + {Subtract with carry. First member of result is (wrapped) difference; + second member is 0 iff no overflow occured.} + +primop IntGtOp ">#" Compare Int# -> Int# -> Bool +primop IntGeOp ">=#" Compare Int# -> Int# -> Bool + +primop IntEqOp "==#" Compare + Int# -> Int# -> Bool + with commutable = True + +primop IntNeOp "/=#" Compare + Int# -> Int# -> Bool + with commutable = True + +primop IntLtOp "<#" Compare Int# -> Int# -> Bool +primop IntLeOp "<=#" Compare Int# -> Int# -> Bool + +primop ChrOp "chr#" GenPrimOp Int# -> Char# + +primop Int2WordOp "int2Word#" GenPrimOp Int# -> Word# +primop Int2FloatOp "int2Float#" GenPrimOp Int# -> Float# +primop Int2DoubleOp "int2Double#" GenPrimOp Int# -> Double# + +primop Int2IntegerOp "int2Integer#" + GenPrimOp Int# -> (# Int#, ByteArr# #) + with out_of_line = True + +primop ISllOp "uncheckedIShiftL#" GenPrimOp Int# -> Int# -> Int# + {Shift left. Result undefined if shift amount is not + in the range 0 to word size - 1 inclusive.} +primop ISraOp "uncheckedIShiftRA#" GenPrimOp Int# -> Int# -> Int# + {Shift right arithmetic. Result undefined if shift amount is not + in the range 0 to word size - 1 inclusive.} +primop ISrlOp "uncheckedIShiftRL#" GenPrimOp Int# -> Int# -> Int# + {Shift right logical. Result undefined if shift amount is not + in the range 0 to word size - 1 inclusive.} + +------------------------------------------------------------------------ +section "Word#" + {Operations on native-sized unsigned words (30+ bits).} +------------------------------------------------------------------------ + +primop WordAddOp "plusWord#" Dyadic Word# -> Word# -> Word# + with commutable = True + +primop WordSubOp "minusWord#" Dyadic Word# -> Word# -> Word# + +primop WordMulOp "timesWord#" Dyadic Word# -> Word# -> Word# + with commutable = True + +primop WordQuotOp "quotWord#" Dyadic Word# -> Word# -> Word# + with can_fail = True + +primop WordRemOp "remWord#" Dyadic Word# -> Word# -> Word# + with can_fail = True + +primop AndOp "and#" Dyadic Word# -> Word# -> Word# + with commutable = True + +primop OrOp "or#" Dyadic Word# -> Word# -> Word# + with commutable = True + +primop XorOp "xor#" Dyadic Word# -> Word# -> Word# + with commutable = True + +primop NotOp "not#" Monadic Word# -> Word# + +primop SllOp "uncheckedShiftL#" GenPrimOp Word# -> Int# -> Word# + {Shift left logical. Result undefined if shift amount is not + in the range 0 to word size - 1 inclusive.} +primop SrlOp "uncheckedShiftRL#" GenPrimOp Word# -> Int# -> Word# + {Shift right logical. Result undefined if shift amount is not + in the range 0 to word size - 1 inclusive.} + +primop Word2IntOp "word2Int#" GenPrimOp Word# -> Int# + +primop Word2IntegerOp "word2Integer#" GenPrimOp + Word# -> (# Int#, ByteArr# #) + with out_of_line = True + +primop WordGtOp "gtWord#" Compare Word# -> Word# -> Bool +primop WordGeOp "geWord#" Compare Word# -> Word# -> Bool +primop WordEqOp "eqWord#" Compare Word# -> Word# -> Bool +primop WordNeOp "neWord#" Compare Word# -> Word# -> Bool +primop WordLtOp "ltWord#" Compare Word# -> Word# -> Bool +primop WordLeOp "leWord#" Compare Word# -> Word# -> Bool + +------------------------------------------------------------------------ +section "Narrowings" + {Explicit narrowing of native-sized ints or words.} +------------------------------------------------------------------------ + +primop Narrow8IntOp "narrow8Int#" Monadic Int# -> Int# +primop Narrow16IntOp "narrow16Int#" Monadic Int# -> Int# +primop Narrow32IntOp "narrow32Int#" Monadic Int# -> Int# +primop Narrow8WordOp "narrow8Word#" Monadic Word# -> Word# +primop Narrow16WordOp "narrow16Word#" Monadic Word# -> Word# +primop Narrow32WordOp "narrow32Word#" Monadic Word# -> Word# + + +#if WORD_SIZE_IN_BITS < 32 +------------------------------------------------------------------------ +section "Int32#" + {Operations on 32-bit integers (Int32\#). This type is only used + if plain Int\# has less than 32 bits. In any case, the operations + are not primops; they are implemented (if needed) as ccalls instead.} +------------------------------------------------------------------------ + +primop Int32ToIntegerOp "int32ToInteger#" GenPrimOp + Int32# -> (# Int#, ByteArr# #) + with out_of_line = True + + +------------------------------------------------------------------------ +section "Word32#" + {Operations on 32-bit unsigned words. This type is only used + if plain Word\# has less than 32 bits. In any case, the operations + are not primops; they are implemented (if needed) as ccalls instead.} +------------------------------------------------------------------------ + +primop Word32ToIntegerOp "word32ToInteger#" GenPrimOp + Word32# -> (# Int#, ByteArr# #) + with out_of_line = True + + +#endif + + +#if WORD_SIZE_IN_BITS < 64 +------------------------------------------------------------------------ +section "Int64#" + {Operations on 64-bit unsigned words. This type is only used + if plain Int\# has less than 64 bits. In any case, the operations + are not primops; they are implemented (if needed) as ccalls instead.} +------------------------------------------------------------------------ + +primop Int64ToIntegerOp "int64ToInteger#" GenPrimOp + Int64# -> (# Int#, ByteArr# #) + with out_of_line = True + +------------------------------------------------------------------------ +section "Word64#" + {Operations on 64-bit unsigned words. This type is only used + if plain Word\# has less than 64 bits. In any case, the operations + are not primops; they are implemented (if needed) as ccalls instead.} +------------------------------------------------------------------------ + +primop Word64ToIntegerOp "word64ToInteger#" GenPrimOp + Word64# -> (# Int#, ByteArr# #) + with out_of_line = True + +#endif + +------------------------------------------------------------------------ +section "Integer#" + {Operations on arbitrary-precision integers. These operations are +implemented via the GMP package. An integer is represented as a pair +consisting of an Int\# representing the number of 'limbs' in use and +the sign, and a ByteArr\# containing the 'limbs' themselves. Such pairs +are returned as unboxed pairs, but must be passed as separate +components. + +For .NET these operations are implemented by foreign imports, so the +primops are omitted.} +------------------------------------------------------------------------ + +#ifndef ILX + +primop IntegerAddOp "plusInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + with commutable = True + out_of_line = True + +primop IntegerSubOp "minusInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + with out_of_line = True + +primop IntegerMulOp "timesInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + with commutable = True + out_of_line = True + +primop IntegerGcdOp "gcdInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + {Greatest common divisor.} + with commutable = True + out_of_line = True + +primop IntegerIntGcdOp "gcdIntegerInt#" GenPrimOp + Int# -> ByteArr# -> Int# -> Int# + {Greatest common divisor, where second argument is an ordinary Int\#.} + with out_of_line = True + +primop IntegerDivExactOp "divExactInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + {Divisor is guaranteed to be a factor of dividend.} + with out_of_line = True + +primop IntegerQuotOp "quotInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + {Rounds towards zero.} + with out_of_line = True + +primop IntegerRemOp "remInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + {Satisfies \texttt{plusInteger\# (timesInteger\# (quotInteger\# x y) y) (remInteger\# x y) == x}.} + with out_of_line = True + +primop IntegerCmpOp "cmpInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> Int# + {Returns -1,0,1 according as first argument is less than, equal to, or greater than second argument.} + with needs_wrapper = True + out_of_line = True + +primop IntegerCmpIntOp "cmpIntegerInt#" GenPrimOp + Int# -> ByteArr# -> Int# -> Int# + {Returns -1,0,1 according as first argument is less than, equal to, or greater than second argument, which + is an ordinary Int\#.} + with needs_wrapper = True + out_of_line = True + +primop IntegerQuotRemOp "quotRemInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr#, Int#, ByteArr# #) + {Compute quot and rem simulaneously.} + with can_fail = True + out_of_line = True + +primop IntegerDivModOp "divModInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr#, Int#, ByteArr# #) + {Compute div and mod simultaneously, where div rounds towards negative infinity + and\texttt{(q,r) = divModInteger\#(x,y)} implies \texttt{plusInteger\# (timesInteger\# q y) r = x}.} + with can_fail = True + out_of_line = True + +primop Integer2IntOp "integer2Int#" GenPrimOp + Int# -> ByteArr# -> Int# + with needs_wrapper = True + out_of_line = True + +primop Integer2WordOp "integer2Word#" GenPrimOp + Int# -> ByteArr# -> Word# + with needs_wrapper = True + out_of_line = True + +#if WORD_SIZE_IN_BITS < 32 +primop IntegerToInt32Op "integerToInt32#" GenPrimOp + Int# -> ByteArr# -> Int32# + +primop IntegerToWord32Op "integerToWord32#" GenPrimOp + Int# -> ByteArr# -> Word32# +#endif + +primop IntegerAndOp "andInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + with out_of_line = True + +primop IntegerOrOp "orInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + with out_of_line = True + +primop IntegerXorOp "xorInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + with out_of_line = True + +primop IntegerComplementOp "complementInteger#" GenPrimOp + Int# -> ByteArr# -> (# Int#, ByteArr# #) + with out_of_line = True + +#endif /* ndef ILX */ + +------------------------------------------------------------------------ +section "Double#" + {Operations on double-precision (64 bit) floating-point numbers.} +------------------------------------------------------------------------ + +primop DoubleGtOp ">##" Compare Double# -> Double# -> Bool +primop DoubleGeOp ">=##" Compare Double# -> Double# -> Bool + +primop DoubleEqOp "==##" Compare + Double# -> Double# -> Bool + with commutable = True + +primop DoubleNeOp "/=##" Compare + Double# -> Double# -> Bool + with commutable = True + +primop DoubleLtOp "<##" Compare Double# -> Double# -> Bool +primop DoubleLeOp "<=##" Compare Double# -> Double# -> Bool + +primop DoubleAddOp "+##" Dyadic + Double# -> Double# -> Double# + with commutable = True + +primop DoubleSubOp "-##" Dyadic Double# -> Double# -> Double# + +primop DoubleMulOp "*##" Dyadic + Double# -> Double# -> Double# + with commutable = True + +primop DoubleDivOp "/##" Dyadic + Double# -> Double# -> Double# + with can_fail = True + +primop DoubleNegOp "negateDouble#" Monadic Double# -> Double# + +primop Double2IntOp "double2Int#" GenPrimOp Double# -> Int# +primop Double2FloatOp "double2Float#" GenPrimOp Double# -> Float# + +primop DoubleExpOp "expDouble#" Monadic + Double# -> Double# + with needs_wrapper = True + +primop DoubleLogOp "logDouble#" Monadic + Double# -> Double# + with + needs_wrapper = True + can_fail = True + +primop DoubleSqrtOp "sqrtDouble#" Monadic + Double# -> Double# + with needs_wrapper = True + +primop DoubleSinOp "sinDouble#" Monadic + Double# -> Double# + with needs_wrapper = True + +primop DoubleCosOp "cosDouble#" Monadic + Double# -> Double# + with needs_wrapper = True + +primop DoubleTanOp "tanDouble#" Monadic + Double# -> Double# + with needs_wrapper = True + +primop DoubleAsinOp "asinDouble#" Monadic + Double# -> Double# + with + needs_wrapper = True + can_fail = True + +primop DoubleAcosOp "acosDouble#" Monadic + Double# -> Double# + with + needs_wrapper = True + can_fail = True + +primop DoubleAtanOp "atanDouble#" Monadic + Double# -> Double# + with + needs_wrapper = True + +primop DoubleSinhOp "sinhDouble#" Monadic + Double# -> Double# + with needs_wrapper = True + +primop DoubleCoshOp "coshDouble#" Monadic + Double# -> Double# + with needs_wrapper = True + +primop DoubleTanhOp "tanhDouble#" Monadic + Double# -> Double# + with needs_wrapper = True + +primop DoublePowerOp "**##" Dyadic + Double# -> Double# -> Double# + {Exponentiation.} + with needs_wrapper = True + +primop DoubleDecodeOp "decodeDouble#" GenPrimOp + Double# -> (# Int#, Int#, ByteArr# #) + {Convert to arbitrary-precision integer. + First Int\# in result is the exponent; second Int\# and ByteArr\# represent an Integer\# + holding the mantissa.} + with out_of_line = True + +------------------------------------------------------------------------ +section "Float#" + {Operations on single-precision (32-bit) floating-point numbers.} +------------------------------------------------------------------------ + +primop FloatGtOp "gtFloat#" Compare Float# -> Float# -> Bool +primop FloatGeOp "geFloat#" Compare Float# -> Float# -> Bool + +primop FloatEqOp "eqFloat#" Compare + Float# -> Float# -> Bool + with commutable = True + +primop FloatNeOp "neFloat#" Compare + Float# -> Float# -> Bool + with commutable = True + +primop FloatLtOp "ltFloat#" Compare Float# -> Float# -> Bool +primop FloatLeOp "leFloat#" Compare Float# -> Float# -> Bool + +primop FloatAddOp "plusFloat#" Dyadic + Float# -> Float# -> Float# + with commutable = True + +primop FloatSubOp "minusFloat#" Dyadic Float# -> Float# -> Float# + +primop FloatMulOp "timesFloat#" Dyadic + Float# -> Float# -> Float# + with commutable = True + +primop FloatDivOp "divideFloat#" Dyadic + Float# -> Float# -> Float# + with can_fail = True + +primop FloatNegOp "negateFloat#" Monadic Float# -> Float# + +primop Float2IntOp "float2Int#" GenPrimOp Float# -> Int# + +primop FloatExpOp "expFloat#" Monadic + Float# -> Float# + with needs_wrapper = True + +primop FloatLogOp "logFloat#" Monadic + Float# -> Float# + with needs_wrapper = True + can_fail = True + +primop FloatSqrtOp "sqrtFloat#" Monadic + Float# -> Float# + with needs_wrapper = True + +primop FloatSinOp "sinFloat#" Monadic + Float# -> Float# + with needs_wrapper = True + +primop FloatCosOp "cosFloat#" Monadic + Float# -> Float# + with needs_wrapper = True + +primop FloatTanOp "tanFloat#" Monadic + Float# -> Float# + with needs_wrapper = True + +primop FloatAsinOp "asinFloat#" Monadic + Float# -> Float# + with needs_wrapper = True + can_fail = True + +primop FloatAcosOp "acosFloat#" Monadic + Float# -> Float# + with needs_wrapper = True + can_fail = True + +primop FloatAtanOp "atanFloat#" Monadic + Float# -> Float# + with needs_wrapper = True + +primop FloatSinhOp "sinhFloat#" Monadic + Float# -> Float# + with needs_wrapper = True + +primop FloatCoshOp "coshFloat#" Monadic + Float# -> Float# + with needs_wrapper = True + +primop FloatTanhOp "tanhFloat#" Monadic + Float# -> Float# + with needs_wrapper = True + +primop FloatPowerOp "powerFloat#" Dyadic + Float# -> Float# -> Float# + with needs_wrapper = True + +primop Float2DoubleOp "float2Double#" GenPrimOp Float# -> Double# + +primop FloatDecodeOp "decodeFloat#" GenPrimOp + Float# -> (# Int#, Int#, ByteArr# #) + {Convert to arbitrary-precision integer. + First Int\# in result is the exponent; second Int\# and ByteArr\# represent an Integer\# + holding the mantissa.} + with out_of_line = True + +------------------------------------------------------------------------ +section "Arrays" + {Operations on Array\#.} +------------------------------------------------------------------------ + +primop NewArrayOp "newArray#" GenPrimOp + Int# -> a -> State# s -> (# State# s, MutArr# s a #) + {Create a new mutable array of specified size (in bytes), + in the specified state thread, + with each element containing the specified initial value.} + with + usage = { mangle NewArrayOp [mkP, mkM, mkP] mkM } + out_of_line = True + +primop SameMutableArrayOp "sameMutableArray#" GenPrimOp + MutArr# s a -> MutArr# s a -> Bool + with + usage = { mangle SameMutableArrayOp [mkP, mkP] mkM } + +primop ReadArrayOp "readArray#" GenPrimOp + MutArr# s a -> Int# -> State# s -> (# State# s, a #) + {Read from specified index of mutable array. Result is not yet evaluated.} + with + usage = { mangle ReadArrayOp [mkM, mkP, mkP] mkM } + +primop WriteArrayOp "writeArray#" GenPrimOp + MutArr# s a -> Int# -> a -> State# s -> State# s + {Write to specified index of mutable array.} + with + usage = { mangle WriteArrayOp [mkM, mkP, mkM, mkP] mkR } + has_side_effects = True + +primop IndexArrayOp "indexArray#" GenPrimOp + Array# a -> Int# -> (# a #) + {Read from specified index of immutable array. Result is packaged into + an unboxed singleton; the result itself is not yet evaluated.} + with + usage = { mangle IndexArrayOp [mkM, mkP] mkM } + +primop UnsafeFreezeArrayOp "unsafeFreezeArray#" GenPrimOp + MutArr# s a -> State# s -> (# State# s, Array# a #) + {Make a mutable array immutable, without copying.} + with + usage = { mangle UnsafeFreezeArrayOp [mkM, mkP] mkM } + has_side_effects = True + +primop UnsafeThawArrayOp "unsafeThawArray#" GenPrimOp + Array# a -> State# s -> (# State# s, MutArr# s a #) + {Make an immutable array mutable, without copying.} + with + usage = { mangle UnsafeThawArrayOp [mkM, mkP] mkM } + out_of_line = True + +------------------------------------------------------------------------ +section "Byte Arrays" + {Operations on ByteArray\#. A ByteArray\# is a just a region of + raw memory in the garbage-collected heap, which is not scanned + for pointers. It carries its own size (in bytes). There are + three sets of operations for accessing byte array contents: + index for reading from immutable byte arrays, and read/write + for mutable byte arrays. Each set contains operations for + a range of useful primitive data types. Each operation takes + an offset measured in terms of the size fo the primitive type + being read or written.} + +------------------------------------------------------------------------ + +primop NewByteArrayOp_Char "newByteArray#" GenPrimOp + Int# -> State# s -> (# State# s, MutByteArr# s #) + {Create a new mutable byte array of specified size (in bytes), in + the specified state thread.} + with out_of_line = True + +primop NewPinnedByteArrayOp_Char "newPinnedByteArray#" GenPrimOp + Int# -> State# s -> (# State# s, MutByteArr# s #) + {Create a mutable byte array that the GC guarantees not to move.} + with out_of_line = True + +primop ByteArrayContents_Char "byteArrayContents#" GenPrimOp + ByteArr# -> Addr# + {Intended for use with pinned arrays; otherwise very unsafe!} + +primop SameMutableByteArrayOp "sameMutableByteArray#" GenPrimOp + MutByteArr# s -> MutByteArr# s -> Bool + +primop UnsafeFreezeByteArrayOp "unsafeFreezeByteArray#" GenPrimOp + MutByteArr# s -> State# s -> (# State# s, ByteArr# #) + {Make a mutable byte array immutable, without copying.} + with + has_side_effects = True + +primop SizeofByteArrayOp "sizeofByteArray#" GenPrimOp + ByteArr# -> Int# + +primop SizeofMutableByteArrayOp "sizeofMutableByteArray#" GenPrimOp + MutByteArr# s -> Int# + + +primop IndexByteArrayOp_Char "indexCharArray#" GenPrimOp + ByteArr# -> Int# -> Char# + {Read 8-bit character; offset in bytes.} + +primop IndexByteArrayOp_WideChar "indexWideCharArray#" GenPrimOp + ByteArr# -> Int# -> Char# + {Read 31-bit character; offset in 4-byte words.} + +primop IndexByteArrayOp_Int "indexIntArray#" GenPrimOp + ByteArr# -> Int# -> Int# + +primop IndexByteArrayOp_Word "indexWordArray#" GenPrimOp + ByteArr# -> Int# -> Word# + +primop IndexByteArrayOp_Addr "indexAddrArray#" GenPrimOp + ByteArr# -> Int# -> Addr# + +primop IndexByteArrayOp_Float "indexFloatArray#" GenPrimOp + ByteArr# -> Int# -> Float# + +primop IndexByteArrayOp_Double "indexDoubleArray#" GenPrimOp + ByteArr# -> Int# -> Double# + +primop IndexByteArrayOp_StablePtr "indexStablePtrArray#" GenPrimOp + ByteArr# -> Int# -> StablePtr# a + +primop IndexByteArrayOp_Int8 "indexInt8Array#" GenPrimOp + ByteArr# -> Int# -> Int# + +primop IndexByteArrayOp_Int16 "indexInt16Array#" GenPrimOp + ByteArr# -> Int# -> Int# + +primop IndexByteArrayOp_Int32 "indexInt32Array#" GenPrimOp + ByteArr# -> Int# -> INT32 + +primop IndexByteArrayOp_Int64 "indexInt64Array#" GenPrimOp + ByteArr# -> Int# -> INT64 + +primop IndexByteArrayOp_Word8 "indexWord8Array#" GenPrimOp + ByteArr# -> Int# -> Word# + +primop IndexByteArrayOp_Word16 "indexWord16Array#" GenPrimOp + ByteArr# -> Int# -> Word# + +primop IndexByteArrayOp_Word32 "indexWord32Array#" GenPrimOp + ByteArr# -> Int# -> WORD32 + +primop IndexByteArrayOp_Word64 "indexWord64Array#" GenPrimOp + ByteArr# -> Int# -> WORD64 + +primop ReadByteArrayOp_Char "readCharArray#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Char# #) + {Read 8-bit character; offset in bytes.} + +primop ReadByteArrayOp_WideChar "readWideCharArray#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Char# #) + {Read 31-bit character; offset in 4-byte words.} + +primop ReadByteArrayOp_Int "readIntArray#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Int# #) + +primop ReadByteArrayOp_Word "readWordArray#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Word# #) + +primop ReadByteArrayOp_Addr "readAddrArray#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Addr# #) + +primop ReadByteArrayOp_Float "readFloatArray#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Float# #) + +primop ReadByteArrayOp_Double "readDoubleArray#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Double# #) + +primop ReadByteArrayOp_StablePtr "readStablePtrArray#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, StablePtr# a #) + +primop ReadByteArrayOp_Int8 "readInt8Array#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Int# #) + +primop ReadByteArrayOp_Int16 "readInt16Array#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Int# #) + +primop ReadByteArrayOp_Int32 "readInt32Array#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, INT32 #) + +primop ReadByteArrayOp_Int64 "readInt64Array#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, INT64 #) + +primop ReadByteArrayOp_Word8 "readWord8Array#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Word# #) + +primop ReadByteArrayOp_Word16 "readWord16Array#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Word# #) + +primop ReadByteArrayOp_Word32 "readWord32Array#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, WORD32 #) + +primop ReadByteArrayOp_Word64 "readWord64Array#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, WORD64 #) + +primop WriteByteArrayOp_Char "writeCharArray#" GenPrimOp + MutByteArr# s -> Int# -> Char# -> State# s -> State# s + {Write 8-bit character; offset in bytes.} + with has_side_effects = True + +primop WriteByteArrayOp_WideChar "writeWideCharArray#" GenPrimOp + MutByteArr# s -> Int# -> Char# -> State# s -> State# s + {Write 31-bit character; offset in 4-byte words.} + with has_side_effects = True + +primop WriteByteArrayOp_Int "writeIntArray#" GenPrimOp + MutByteArr# s -> Int# -> Int# -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Word "writeWordArray#" GenPrimOp + MutByteArr# s -> Int# -> Word# -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Addr "writeAddrArray#" GenPrimOp + MutByteArr# s -> Int# -> Addr# -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Float "writeFloatArray#" GenPrimOp + MutByteArr# s -> Int# -> Float# -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Double "writeDoubleArray#" GenPrimOp + MutByteArr# s -> Int# -> Double# -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_StablePtr "writeStablePtrArray#" GenPrimOp + MutByteArr# s -> Int# -> StablePtr# a -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Int8 "writeInt8Array#" GenPrimOp + MutByteArr# s -> Int# -> Int# -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Int16 "writeInt16Array#" GenPrimOp + MutByteArr# s -> Int# -> Int# -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Int32 "writeInt32Array#" GenPrimOp + MutByteArr# s -> Int# -> INT32 -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Int64 "writeInt64Array#" GenPrimOp + MutByteArr# s -> Int# -> INT64 -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Word8 "writeWord8Array#" GenPrimOp + MutByteArr# s -> Int# -> Word# -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Word16 "writeWord16Array#" GenPrimOp + MutByteArr# s -> Int# -> Word# -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Word32 "writeWord32Array#" GenPrimOp + MutByteArr# s -> Int# -> WORD32 -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Word64 "writeWord64Array#" GenPrimOp + MutByteArr# s -> Int# -> WORD64 -> State# s -> State# s + with has_side_effects = True + +------------------------------------------------------------------------ +section "Addr#" + {Addr\# is an arbitrary machine address assumed to point outside + the garbage-collected heap. + + NB: {\tt nullAddr\#::Addr\#} is not a primop, but is defined in MkId.lhs. + It is the null address.} +------------------------------------------------------------------------ + +primop AddrAddOp "plusAddr#" GenPrimOp Addr# -> Int# -> Addr# +primop AddrSubOp "minusAddr#" GenPrimOp Addr# -> Addr# -> Int# + {Result is meaningless if two Addr\#s are so far apart that their + difference doesn't fit in an Int\#.} +primop AddrRemOp "remAddr#" GenPrimOp Addr# -> Int# -> Int# + {Return the remainder when the Addr\# arg, treated like an Int\#, + is divided by the Int\# arg.} +#if (WORD_SIZE_IN_BITS == 32 || WORD_SIZE_IN_BITS == 64) +primop Addr2IntOp "addr2Int#" GenPrimOp Addr# -> Int# + {Coerce directly from address to int. Strongly deprecated.} +primop Int2AddrOp "int2Addr#" GenPrimOp Int# -> Addr# + {Coerce directly from int to address. Strongly deprecated.} +#endif + +primop AddrGtOp "gtAddr#" Compare Addr# -> Addr# -> Bool +primop AddrGeOp "geAddr#" Compare Addr# -> Addr# -> Bool +primop AddrEqOp "eqAddr#" Compare Addr# -> Addr# -> Bool +primop AddrNeOp "neAddr#" Compare Addr# -> Addr# -> Bool +primop AddrLtOp "ltAddr#" Compare Addr# -> Addr# -> Bool +primop AddrLeOp "leAddr#" Compare Addr# -> Addr# -> Bool + +primop IndexOffAddrOp_Char "indexCharOffAddr#" GenPrimOp + Addr# -> Int# -> Char# + {Reads 8-bit character; offset in bytes.} + +primop IndexOffAddrOp_WideChar "indexWideCharOffAddr#" GenPrimOp + Addr# -> Int# -> Char# + {Reads 31-bit character; offset in 4-byte words.} + +primop IndexOffAddrOp_Int "indexIntOffAddr#" GenPrimOp + Addr# -> Int# -> Int# + +primop IndexOffAddrOp_Word "indexWordOffAddr#" GenPrimOp + Addr# -> Int# -> Word# + +primop IndexOffAddrOp_Addr "indexAddrOffAddr#" GenPrimOp + Addr# -> Int# -> Addr# + +primop IndexOffAddrOp_Float "indexFloatOffAddr#" GenPrimOp + Addr# -> Int# -> Float# + +primop IndexOffAddrOp_Double "indexDoubleOffAddr#" GenPrimOp + Addr# -> Int# -> Double# + +primop IndexOffAddrOp_StablePtr "indexStablePtrOffAddr#" GenPrimOp + Addr# -> Int# -> StablePtr# a + +primop IndexOffAddrOp_Int8 "indexInt8OffAddr#" GenPrimOp + Addr# -> Int# -> Int# + +primop IndexOffAddrOp_Int16 "indexInt16OffAddr#" GenPrimOp + Addr# -> Int# -> Int# + +primop IndexOffAddrOp_Int32 "indexInt32OffAddr#" GenPrimOp + Addr# -> Int# -> INT32 + +primop IndexOffAddrOp_Int64 "indexInt64OffAddr#" GenPrimOp + Addr# -> Int# -> INT64 + +primop IndexOffAddrOp_Word8 "indexWord8OffAddr#" GenPrimOp + Addr# -> Int# -> Word# + +primop IndexOffAddrOp_Word16 "indexWord16OffAddr#" GenPrimOp + Addr# -> Int# -> Word# + +primop IndexOffAddrOp_Word32 "indexWord32OffAddr#" GenPrimOp + Addr# -> Int# -> WORD32 + +primop IndexOffAddrOp_Word64 "indexWord64OffAddr#" GenPrimOp + Addr# -> Int# -> WORD64 + +primop ReadOffAddrOp_Char "readCharOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Char# #) + {Reads 8-bit character; offset in bytes.} + +primop ReadOffAddrOp_WideChar "readWideCharOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Char# #) + {Reads 31-bit character; offset in 4-byte words.} + +primop ReadOffAddrOp_Int "readIntOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Int# #) + +primop ReadOffAddrOp_Word "readWordOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Word# #) + +primop ReadOffAddrOp_Addr "readAddrOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Addr# #) + +primop ReadOffAddrOp_Float "readFloatOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Float# #) + +primop ReadOffAddrOp_Double "readDoubleOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Double# #) + +primop ReadOffAddrOp_StablePtr "readStablePtrOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, StablePtr# a #) + +primop ReadOffAddrOp_Int8 "readInt8OffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Int# #) + +primop ReadOffAddrOp_Int16 "readInt16OffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Int# #) + +primop ReadOffAddrOp_Int32 "readInt32OffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, INT32 #) + +primop ReadOffAddrOp_Int64 "readInt64OffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, INT64 #) + +primop ReadOffAddrOp_Word8 "readWord8OffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Word# #) + +primop ReadOffAddrOp_Word16 "readWord16OffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Word# #) + +primop ReadOffAddrOp_Word32 "readWord32OffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, WORD32 #) + +primop ReadOffAddrOp_Word64 "readWord64OffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, WORD64 #) + + +primop WriteOffAddrOp_Char "writeCharOffAddr#" GenPrimOp + Addr# -> Int# -> Char# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_WideChar "writeWideCharOffAddr#" GenPrimOp + Addr# -> Int# -> Char# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Int "writeIntOffAddr#" GenPrimOp + Addr# -> Int# -> Int# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Word "writeWordOffAddr#" GenPrimOp + Addr# -> Int# -> Word# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Addr "writeAddrOffAddr#" GenPrimOp + Addr# -> Int# -> Addr# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Float "writeFloatOffAddr#" GenPrimOp + Addr# -> Int# -> Float# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Double "writeDoubleOffAddr#" GenPrimOp + Addr# -> Int# -> Double# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_StablePtr "writeStablePtrOffAddr#" GenPrimOp + Addr# -> Int# -> StablePtr# a -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Int8 "writeInt8OffAddr#" GenPrimOp + Addr# -> Int# -> Int# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Int16 "writeInt16OffAddr#" GenPrimOp + Addr# -> Int# -> Int# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Int32 "writeInt32OffAddr#" GenPrimOp + Addr# -> Int# -> INT32 -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Int64 "writeInt64OffAddr#" GenPrimOp + Addr# -> Int# -> INT64 -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Word8 "writeWord8OffAddr#" GenPrimOp + Addr# -> Int# -> Word# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Word16 "writeWord16OffAddr#" GenPrimOp + Addr# -> Int# -> Word# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Word32 "writeWord32OffAddr#" GenPrimOp + Addr# -> Int# -> WORD32 -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Word64 "writeWord64OffAddr#" GenPrimOp + Addr# -> Int# -> WORD64 -> State# s -> State# s + with has_side_effects = True + +------------------------------------------------------------------------ +section "Mutable variables" + {Operations on MutVar\#s, which behave like single-element mutable arrays.} +------------------------------------------------------------------------ + +primop NewMutVarOp "newMutVar#" GenPrimOp + a -> State# s -> (# State# s, MutVar# s a #) + {Create MutVar\# with specified initial value in specified state thread.} + with + usage = { mangle NewMutVarOp [mkM, mkP] mkM } + out_of_line = True + +primop ReadMutVarOp "readMutVar#" GenPrimOp + MutVar# s a -> State# s -> (# State# s, a #) + {Read contents of MutVar\#. Result is not yet evaluated.} + with + usage = { mangle ReadMutVarOp [mkM, mkP] mkM } + +primop WriteMutVarOp "writeMutVar#" GenPrimOp + MutVar# s a -> a -> State# s -> State# s + {Write contents of MutVar\#.} + with + usage = { mangle WriteMutVarOp [mkM, mkM, mkP] mkR } + has_side_effects = True + +primop SameMutVarOp "sameMutVar#" GenPrimOp + MutVar# s a -> MutVar# s a -> Bool + with + usage = { mangle SameMutVarOp [mkP, mkP] mkM } + +-- not really the right type, but we don't know about pairs here. The +-- correct type is +-- +-- MutVar# s a -> (a -> (a,b)) -> State# s -> (# State# s, b #) +-- +primop AtomicModifyMutVarOp "atomicModifyMutVar#" GenPrimOp + MutVar# s a -> (a -> b) -> State# s -> (# State# s, c #) + with + usage = { mangle AtomicModifyMutVarOp [mkP, mkM, mkP] mkM } + has_side_effects = True + out_of_line = True + +------------------------------------------------------------------------ +section "Exceptions" +------------------------------------------------------------------------ + +primop CatchOp "catch#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a #) ) + -> (b -> State# RealWorld -> (# State# RealWorld, a #) ) + -> State# RealWorld + -> (# State# RealWorld, a #) + with + -- Catch is actually strict in its first argument + -- but we don't want to tell the strictness + -- analyser about that! + usage = { mangle CatchOp [mkM, mkM . (inFun CatchOp mkM mkM), mkP] mkM } + -- [mkO, mkO . (inFun mkM mkO)] mkO + -- might use caught action multiply + out_of_line = True + +primop RaiseOp "raise#" GenPrimOp + a -> b + with + strictness = { \ arity -> mkStrictSig (mkTopDmdType [lazyDmd] BotRes) } + -- NB: result is bottom + usage = { mangle RaiseOp [mkM] mkM } + out_of_line = True + +-- raiseIO# needs to be a primop, because exceptions in the IO monad +-- must be *precise* - we don't want the strictness analyser turning +-- one kind of bottom into another, as it is allowed to do in pure code. + +primop RaiseIOOp "raiseIO#" GenPrimOp + a -> State# RealWorld -> (# State# RealWorld, b #) + with + out_of_line = True + +primop BlockAsyncExceptionsOp "blockAsyncExceptions#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a #)) + -> (State# RealWorld -> (# State# RealWorld, a #)) + with + out_of_line = True + +primop UnblockAsyncExceptionsOp "unblockAsyncExceptions#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a #)) + -> (State# RealWorld -> (# State# RealWorld, a #)) + with + out_of_line = True + +------------------------------------------------------------------------ +section "STM-accessible Mutable Variables" +------------------------------------------------------------------------ + +primop AtomicallyOp "atomically#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a #) ) + -> State# RealWorld -> (# State# RealWorld, a #) + with + out_of_line = True + has_side_effects = True + +primop RetryOp "retry#" GenPrimOp + State# RealWorld -> (# State# RealWorld, a #) + with + out_of_line = True + has_side_effects = True + +primop CatchRetryOp "catchRetry#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a #) ) + -> (State# RealWorld -> (# State# RealWorld, a #) ) + -> (State# RealWorld -> (# State# RealWorld, a #) ) + with + out_of_line = True + has_side_effects = True + +primop CatchSTMOp "catchSTM#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a #) ) + -> (b -> State# RealWorld -> (# State# RealWorld, a #) ) + -> (State# RealWorld -> (# State# RealWorld, a #) ) + with + out_of_line = True + has_side_effects = True + +primop NewTVarOp "newTVar#" GenPrimOp + a + -> State# s -> (# State# s, TVar# s a #) + {Create a new Tar\# holding a specified initial value.} + with + out_of_line = True + +primop ReadTVarOp "readTVar#" GenPrimOp + TVar# s a + -> State# s -> (# State# s, a #) + {Read contents of TVar\#. Result is not yet evaluated.} + with + out_of_line = True + +primop WriteTVarOp "writeTVar#" GenPrimOp + TVar# s a + -> a + -> State# s -> State# s + {Write contents of TVar\#.} + with + out_of_line = True + has_side_effects = True + +primop SameTVarOp "sameTVar#" GenPrimOp + TVar# s a -> TVar# s a -> Bool + + +------------------------------------------------------------------------ +section "Synchronized Mutable Variables" + {Operations on MVar\#s, which are shared mutable variables + ({\it not} the same as MutVar\#s!). (Note: in a non-concurrent implementation, + (MVar\# a) can be represented by (MutVar\# (Maybe a)).)} +------------------------------------------------------------------------ + + +primop NewMVarOp "newMVar#" GenPrimOp + State# s -> (# State# s, MVar# s a #) + {Create new mvar; initially empty.} + with + usage = { mangle NewMVarOp [mkP] mkR } + out_of_line = True + +primop TakeMVarOp "takeMVar#" GenPrimOp + MVar# s a -> State# s -> (# State# s, a #) + {If mvar is empty, block until it becomes full. + Then remove and return its contents, and set it empty.} + with + usage = { mangle TakeMVarOp [mkM, mkP] mkM } + has_side_effects = True + out_of_line = True + +primop TryTakeMVarOp "tryTakeMVar#" GenPrimOp + MVar# s a -> State# s -> (# State# s, Int#, a #) + {If mvar is empty, immediately return with integer 0 and value undefined. + Otherwise, return with integer 1 and contents of mvar, and set mvar empty.} + with + usage = { mangle TryTakeMVarOp [mkM, mkP] mkM } + has_side_effects = True + out_of_line = True + +primop PutMVarOp "putMVar#" GenPrimOp + MVar# s a -> a -> State# s -> State# s + {If mvar is full, block until it becomes empty. + Then store value arg as its new contents.} + with + usage = { mangle PutMVarOp [mkM, mkM, mkP] mkR } + has_side_effects = True + out_of_line = True + +primop TryPutMVarOp "tryPutMVar#" GenPrimOp + MVar# s a -> a -> State# s -> (# State# s, Int# #) + {If mvar is full, immediately return with integer 0. + Otherwise, store value arg as mvar's new contents, and return with integer 1.} + with + usage = { mangle TryPutMVarOp [mkM, mkM, mkP] mkR } + has_side_effects = True + out_of_line = True + +primop SameMVarOp "sameMVar#" GenPrimOp + MVar# s a -> MVar# s a -> Bool + with + usage = { mangle SameMVarOp [mkP, mkP] mkM } + +primop IsEmptyMVarOp "isEmptyMVar#" GenPrimOp + MVar# s a -> State# s -> (# State# s, Int# #) + {Return 1 if mvar is empty; 0 otherwise.} + with + usage = { mangle IsEmptyMVarOp [mkP, mkP] mkM } + out_of_line = True + +------------------------------------------------------------------------ +section "Delay/wait operations" +------------------------------------------------------------------------ + +primop DelayOp "delay#" GenPrimOp + Int# -> State# s -> State# s + {Sleep specified number of microseconds.} + with + needs_wrapper = True + has_side_effects = True + out_of_line = True + +primop WaitReadOp "waitRead#" GenPrimOp + Int# -> State# s -> State# s + {Block until input is available on specified file descriptor.} + with + needs_wrapper = True + has_side_effects = True + out_of_line = True + +primop WaitWriteOp "waitWrite#" GenPrimOp + Int# -> State# s -> State# s + {Block until output is possible on specified file descriptor.} + with + needs_wrapper = True + has_side_effects = True + out_of_line = True + +#ifdef mingw32_TARGET_OS +primop AsyncReadOp "asyncRead#" GenPrimOp + Int# -> Int# -> Int# -> Addr# -> State# RealWorld-> (# State# RealWorld, Int#, Int# #) + {Asynchronously read bytes from specified file descriptor.} + with + needs_wrapper = True + has_side_effects = True + out_of_line = True + +primop AsyncWriteOp "asyncWrite#" GenPrimOp + Int# -> Int# -> Int# -> Addr# -> State# RealWorld-> (# State# RealWorld, Int#, Int# #) + {Asynchronously write bytes from specified file descriptor.} + with + needs_wrapper = True + has_side_effects = True + out_of_line = True + +primop AsyncDoProcOp "asyncDoProc#" GenPrimOp + Addr# -> Addr# -> State# RealWorld-> (# State# RealWorld, Int#, Int# #) + {Asynchronously perform procedure (first arg), passing it 2nd arg.} + with + needs_wrapper = True + has_side_effects = True + out_of_line = True + +#endif + +------------------------------------------------------------------------ +section "Concurrency primitives" + {(In a non-concurrent implementation, ThreadId\# can be as singleton + type, whose (unique) value is returned by myThreadId\#. The + other operations can be omitted.)} +------------------------------------------------------------------------ + +primop ForkOp "fork#" GenPrimOp + a -> State# RealWorld -> (# State# RealWorld, ThreadId# #) + with + usage = { mangle ForkOp [mkO, mkP] mkR } + has_side_effects = True + out_of_line = True + +primop ForkOnOp "forkOn#" GenPrimOp + Int# -> a -> State# RealWorld -> (# State# RealWorld, ThreadId# #) + with + usage = { mangle ForkOnOp [mkO, mkP] mkR } + has_side_effects = True + out_of_line = True + +primop KillThreadOp "killThread#" GenPrimOp + ThreadId# -> a -> State# RealWorld -> State# RealWorld + with + usage = { mangle KillThreadOp [mkP, mkM, mkP] mkR } + has_side_effects = True + out_of_line = True + +primop YieldOp "yield#" GenPrimOp + State# RealWorld -> State# RealWorld + with + has_side_effects = True + out_of_line = True + +primop MyThreadIdOp "myThreadId#" GenPrimOp + State# RealWorld -> (# State# RealWorld, ThreadId# #) + with + out_of_line = True + +primop LabelThreadOp "labelThread#" GenPrimOp + ThreadId# -> Addr# -> State# RealWorld -> State# RealWorld + with + has_side_effects = True + out_of_line = True + +primop IsCurrentThreadBoundOp "isCurrentThreadBound#" GenPrimOp + State# RealWorld -> (# State# RealWorld, Int# #) + with + out_of_line = True + +------------------------------------------------------------------------ +section "Weak pointers" +------------------------------------------------------------------------ + +-- note that tyvar "o" denotes openAlphaTyVar + +primop MkWeakOp "mkWeak#" GenPrimOp + o -> b -> c -> State# RealWorld -> (# State# RealWorld, Weak# b #) + with + usage = { mangle MkWeakOp [mkZ, mkM, mkM, mkP] mkM } + has_side_effects = True + out_of_line = True + +primop DeRefWeakOp "deRefWeak#" GenPrimOp + Weak# a -> State# RealWorld -> (# State# RealWorld, Int#, a #) + with + usage = { mangle DeRefWeakOp [mkM, mkP] mkM } + has_side_effects = True + out_of_line = True + +primop FinalizeWeakOp "finalizeWeak#" GenPrimOp + Weak# a -> State# RealWorld -> (# State# RealWorld, Int#, + (State# RealWorld -> (# State# RealWorld, () #)) #) + with + usage = { mangle FinalizeWeakOp [mkM, mkP] + (mkR . (inUB FinalizeWeakOp + [id,id,inFun FinalizeWeakOp mkR mkM])) } + has_side_effects = True + out_of_line = True + +primop TouchOp "touch#" GenPrimOp + o -> State# RealWorld -> State# RealWorld + with + has_side_effects = True + +------------------------------------------------------------------------ +section "Stable pointers and names" +------------------------------------------------------------------------ + +primop MakeStablePtrOp "makeStablePtr#" GenPrimOp + a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #) + with + usage = { mangle MakeStablePtrOp [mkM, mkP] mkM } + has_side_effects = True + out_of_line = True + +primop DeRefStablePtrOp "deRefStablePtr#" GenPrimOp + StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #) + with + usage = { mangle DeRefStablePtrOp [mkM, mkP] mkM } + needs_wrapper = True + has_side_effects = True + out_of_line = True + +primop EqStablePtrOp "eqStablePtr#" GenPrimOp + StablePtr# a -> StablePtr# a -> Int# + with + usage = { mangle EqStablePtrOp [mkP, mkP] mkR } + has_side_effects = True + +primop MakeStableNameOp "makeStableName#" GenPrimOp + a -> State# RealWorld -> (# State# RealWorld, StableName# a #) + with + usage = { mangle MakeStableNameOp [mkZ, mkP] mkR } + needs_wrapper = True + has_side_effects = True + out_of_line = True + +primop EqStableNameOp "eqStableName#" GenPrimOp + StableName# a -> StableName# a -> Int# + with + usage = { mangle EqStableNameOp [mkP, mkP] mkR } + +primop StableNameToIntOp "stableNameToInt#" GenPrimOp + StableName# a -> Int# + with + usage = { mangle StableNameToIntOp [mkP] mkR } + +------------------------------------------------------------------------ +section "Unsafe pointer equality" +-- (#1 Bad Guy: Alistair Reid :) +------------------------------------------------------------------------ + +primop ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp + a -> a -> Int# + with + usage = { mangle ReallyUnsafePtrEqualityOp [mkZ, mkZ] mkR } + +------------------------------------------------------------------------ +section "Parallelism" +------------------------------------------------------------------------ + +primop ParOp "par#" GenPrimOp + a -> Int# + with + usage = { mangle ParOp [mkO] mkR } + -- Note that Par is lazy to avoid that the sparked thing + -- gets evaluted strictly, which it should *not* be + has_side_effects = True + +-- HWL: The first 4 Int# in all par... annotations denote: +-- name, granularity info, size of result, degree of parallelism +-- Same structure as _seq_ i.e. returns Int# +-- KSW: v, the second arg in parAt# and parAtForNow#, is used only to determine +-- `the processor containing the expression v'; it is not evaluated + +primop ParGlobalOp "parGlobal#" GenPrimOp + a -> Int# -> Int# -> Int# -> Int# -> b -> Int# + with + usage = { mangle ParGlobalOp [mkO, mkP, mkP, mkP, mkP, mkM] mkM } + has_side_effects = True + +primop ParLocalOp "parLocal#" GenPrimOp + a -> Int# -> Int# -> Int# -> Int# -> b -> Int# + with + usage = { mangle ParLocalOp [mkO, mkP, mkP, mkP, mkP, mkM] mkM } + has_side_effects = True + +primop ParAtOp "parAt#" GenPrimOp + b -> a -> Int# -> Int# -> Int# -> Int# -> c -> Int# + with + usage = { mangle ParAtOp [mkO, mkZ, mkP, mkP, mkP, mkP, mkM] mkM } + has_side_effects = True + +primop ParAtAbsOp "parAtAbs#" GenPrimOp + a -> Int# -> Int# -> Int# -> Int# -> Int# -> b -> Int# + with + usage = { mangle ParAtAbsOp [mkO, mkP, mkP, mkP, mkP, mkM] mkM } + has_side_effects = True + +primop ParAtRelOp "parAtRel#" GenPrimOp + a -> Int# -> Int# -> Int# -> Int# -> Int# -> b -> Int# + with + usage = { mangle ParAtRelOp [mkO, mkP, mkP, mkP, mkP, mkM] mkM } + has_side_effects = True + +primop ParAtForNowOp "parAtForNow#" GenPrimOp + b -> a -> Int# -> Int# -> Int# -> Int# -> c -> Int# + with + usage = { mangle ParAtForNowOp [mkO, mkZ, mkP, mkP, mkP, mkP, mkM] mkM } + has_side_effects = True + +-- copyable# and noFollow# are yet to be implemented (for GpH) +-- +--primop CopyableOp "copyable#" GenPrimOp +-- a -> Int# +-- with +-- usage = { mangle CopyableOp [mkZ] mkR } +-- has_side_effects = True +-- +--primop NoFollowOp "noFollow#" GenPrimOp +-- a -> Int# +-- with +-- usage = { mangle NoFollowOp [mkZ] mkR } +-- has_side_effects = True + + +------------------------------------------------------------------------ +section "Tag to enum stuff" + {Convert back and forth between values of enumerated types + and small integers.} +------------------------------------------------------------------------ + +primop DataToTagOp "dataToTag#" GenPrimOp + a -> Int# + with + strictness = { \ arity -> mkStrictSig (mkTopDmdType [seqDmd] TopRes) } + -- dataToTag# must have an evaluated argument + +primop TagToEnumOp "tagToEnum#" GenPrimOp + Int# -> a + +------------------------------------------------------------------------ +section "Bytecode operations" + {Support for the bytecode interpreter and linker.} +------------------------------------------------------------------------ + + +primop AddrToHValueOp "addrToHValue#" GenPrimOp + Addr# -> (# a #) + {Convert an Addr\# to a followable type.} + +primop MkApUpd0_Op "mkApUpd0#" GenPrimOp + BCO# -> (# a #) + with + out_of_line = True + +primop NewBCOOp "newBCO#" GenPrimOp + ByteArr# -> ByteArr# -> Array# a -> ByteArr# -> Int# -> ByteArr# -> State# s -> (# State# s, BCO# #) + with + has_side_effects = True + out_of_line = True + +------------------------------------------------------------------------ +section "Coercion" + {{\tt unsafeCoerce\# :: a -> b} is not a primop, but is defined in MkId.lhs.} + +------------------------------------------------------------------------ + + +------------------------------------------------------------------------ +--- --- +------------------------------------------------------------------------ + +thats_all_folks + + + |