-%
-% (c) The AQUA Project, Glasgow University, 1994-1998
-%
-\section[CoreUnfold]{Core-syntax unfoldings}
-
-Unfoldings (which can travel across module boundaries) are in Core
-syntax (namely @CoreExpr@s).
-
-The type @Unfolding@ sits ``above'' simply-Core-expressions
-unfoldings, capturing ``higher-level'' things we know about a binding,
-usually things that the simplifier found out (e.g., ``it's a
-literal''). In the corner of a @CoreUnfolding@ unfolding, you will
-find, unsurprisingly, a Core expression.
-
-\begin{code}
-module CoreUnfold (
- Unfolding(..), UnfoldingGuidance, -- types
-
- noUnfolding, mkUnfolding, getUnfoldingTemplate,
- isEvaldUnfolding, hasUnfolding,
-
- couldBeSmallEnoughToInline,
- certainlySmallEnoughToInline,
- okToUnfoldInHiFile,
-
- calcUnfoldingGuidance,
-
- callSiteInline, blackListed
- ) where
-
-#include "HsVersions.h"
-
-import CmdLineOpts ( opt_UF_CreationThreshold,
- opt_UF_UseThreshold,
- opt_UF_ScrutConDiscount,
- opt_UF_FunAppDiscount,
- opt_UF_PrimArgDiscount,
- opt_UF_KeenessFactor,
- opt_UF_CheapOp, opt_UF_DearOp, opt_UF_NoRepLit,
- opt_UnfoldCasms, opt_PprStyle_Debug,
- opt_D_dump_inlinings
- )
-import CoreSyn
-import PprCore ( pprCoreExpr )
-import CoreUtils ( whnfOrBottom )
-import OccurAnal ( occurAnalyseGlobalExpr )
-import BinderInfo ( )
-import CoreUtils ( coreExprType, exprIsTrivial, mkFormSummary,
- FormSummary(..) )
-import Id ( Id, idType, idUnique, isId,
- getIdSpecialisation, getInlinePragma, getIdUnfolding
- )
-import VarSet
-import Const ( Con(..), isLitLitLit, isWHNFCon )
-import PrimOp ( PrimOp(..), primOpIsDupable )
-import IdInfo ( ArityInfo(..), InlinePragInfo(..), OccInfo(..) )
-import TyCon ( tyConFamilySize )
-import Type ( splitAlgTyConApp_maybe, splitFunTy_maybe )
-import Const ( isNoRepLit )
-import Unique ( Unique, buildIdKey, augmentIdKey, runSTRepIdKey )
-import Maybes ( maybeToBool )
-import Bag
-import Util ( isIn, lengthExceeds )
-import Outputable
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{@Unfolding@ and @UnfoldingGuidance@ types}
-%* *
-%************************************************************************
-
-\begin{code}
-data Unfolding
- = NoUnfolding
-
- | OtherCon [Con] -- It ain't one of these
- -- (OtherCon xs) also indicates that something has been evaluated
- -- and hence there's no point in re-evaluating it.
- -- OtherCon [] is used even for non-data-type values
- -- to indicated evaluated-ness. Notably:
- -- data C = C !(Int -> Int)
- -- case x of { C f -> ... }
- -- Here, f gets an OtherCon [] unfolding.
-
- | CoreUnfolding -- An unfolding with redundant cached information
- FormSummary -- Tells whether the template is a WHNF or bottom
- UnfoldingGuidance -- Tells about the *size* of the template.
- CoreExpr -- Template; binder-info is correct
-\end{code}
-
-\begin{code}
-noUnfolding = NoUnfolding
-
-mkUnfolding expr
- = let
- -- strictness mangling (depends on there being no CSE)
- ufg = calcUnfoldingGuidance opt_UF_CreationThreshold expr
- occ = occurAnalyseGlobalExpr expr
- in
- CoreUnfolding (mkFormSummary expr) ufg occ
-
-getUnfoldingTemplate :: Unfolding -> CoreExpr
-getUnfoldingTemplate (CoreUnfolding _ _ expr) = expr
-getUnfoldingTemplate other = panic "getUnfoldingTemplate"
-
-isEvaldUnfolding :: Unfolding -> Bool
-isEvaldUnfolding (OtherCon _) = True
-isEvaldUnfolding (CoreUnfolding ValueForm _ expr) = True
-isEvaldUnfolding other = False
-
-hasUnfolding :: Unfolding -> Bool
-hasUnfolding NoUnfolding = False
-hasUnfolding other = True
-
-data UnfoldingGuidance
- = UnfoldNever
- | UnfoldAlways -- There is no "original" definition,
- -- so you'd better unfold. Or: something
- -- so cheap to unfold (e.g., 1#) that
- -- you should do it absolutely always.
-
- | UnfoldIfGoodArgs Int -- and "n" value args
-
- [Int] -- Discount if the argument is evaluated.
- -- (i.e., a simplification will definitely
- -- be possible). One elt of the list per *value* arg.
-
- Int -- The "size" of the unfolding; to be elaborated
- -- later. ToDo
-
- Int -- Scrutinee discount: the discount to substract if the thing is in
- -- a context (case (thing args) of ...),
- -- (where there are the right number of arguments.)
-\end{code}
-
-\begin{code}
-instance Outputable UnfoldingGuidance where
- ppr UnfoldAlways = ptext SLIT("ALWAYS")
- ppr UnfoldNever = ptext SLIT("NEVER")
- ppr (UnfoldIfGoodArgs v cs size discount)
- = hsep [ptext SLIT("IF_ARGS"), int v,
- if null cs -- always print *something*
- then char 'X'
- else hcat (map (text . show) cs),
- int size,
- int discount ]
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[calcUnfoldingGuidance]{Calculate ``unfolding guidance'' for an expression}
-%* *
-%************************************************************************
-
-\begin{code}
-calcUnfoldingGuidance
- :: Int -- bomb out if size gets bigger than this
- -> CoreExpr -- expression to look at
- -> UnfoldingGuidance
-calcUnfoldingGuidance bOMB_OUT_SIZE expr
- | exprIsTrivial expr -- Often trivial expressions are never bound
- -- to an expression, but it can happen. For
- -- example, the Id for a nullary constructor has
- -- a trivial expression as its unfolding, and
- -- we want to make sure that we always unfold it.
- = UnfoldAlways
-
- | otherwise
- = case collectBinders expr of { (binders, body) ->
- let
- val_binders = filter isId binders
- in
- case (sizeExpr bOMB_OUT_SIZE val_binders body) of
-
- TooBig -> UnfoldNever
-
- SizeIs size cased_args scrut_discount
- -> UnfoldIfGoodArgs
- (length val_binders)
- (map discount_for val_binders)
- (I# size)
- (I# scrut_discount)
- where
- discount_for b
- | num_cases == 0 = 0
- | is_fun_ty = num_cases * opt_UF_FunAppDiscount
- | is_data_ty = num_cases * tyConFamilySize tycon * opt_UF_ScrutConDiscount
- | otherwise = num_cases * opt_UF_PrimArgDiscount
- where
- num_cases = foldlBag (\n b' -> if b==b' then n+1 else n) 0 cased_args
- -- Count occurrences of b in cased_args
- arg_ty = idType b
- is_fun_ty = maybeToBool (splitFunTy_maybe arg_ty)
- (is_data_ty, tycon) = case (splitAlgTyConApp_maybe (idType b)) of
- Nothing -> (False, panic "discount")
- Just (tc,_,_) -> (True, tc)
- }
-\end{code}
-
-\begin{code}
-sizeExpr :: Int -- Bomb out if it gets bigger than this
- -> [Id] -- Arguments; we're interested in which of these
- -- get case'd
- -> CoreExpr
- -> ExprSize
-
-sizeExpr (I# bOMB_OUT_SIZE) args expr
- = size_up expr
- where
- size_up (Type t) = sizeZero -- Types cost nothing
- size_up (Var v) = sizeOne
-
- size_up (Note InlineMe _) = sizeTwo -- The idea is that this is one more
- -- than the size of the "call" (i.e. 1)
- -- We want to reply "no" to noSizeIncrease
- -- for a bare reference (i.e. applied to no args)
- -- to an INLINE thing
-
- size_up (Note _ body) = size_up body -- Notes cost nothing
-
- size_up (App fun (Type t)) = size_up fun
- size_up (App fun arg) = size_up_app fun `addSize` size_up arg
-
- size_up (Con con args) = foldr (addSize . size_up)
- (size_up_con con args)
- args
-
- size_up (Lam b e) | isId b = size_up e `addSizeN` 1
- | otherwise = size_up e
-
- size_up (Let (NonRec binder rhs) body)
- = nukeScrutDiscount (size_up rhs) `addSize`
- size_up body `addSizeN`
- 1 -- For the allocation
-
- size_up (Let (Rec pairs) body)
- = nukeScrutDiscount rhs_size `addSize`
- size_up body `addSizeN`
- length pairs -- For the allocation
- where
- rhs_size = foldr (addSize . size_up . snd) sizeZero pairs
-
- size_up (Case scrut _ alts)
- = nukeScrutDiscount (size_up scrut) `addSize`
- arg_discount scrut `addSize`
- foldr (addSize . size_up_alt) sizeZero alts `addSizeN`
- case (splitAlgTyConApp_maybe (coreExprType scrut)) of
- Nothing -> 1
- Just (tc,_,_) -> tyConFamilySize tc
-
- ------------
- -- A function application with at least one value argument
- -- so if the function is an argument give it an arg-discount
- size_up_app (App fun arg) = size_up_app fun `addSize` size_up arg
- size_up_app fun = arg_discount fun `addSize` size_up fun
-
- ------------
- size_up_alt (con, bndrs, rhs) = size_up rhs
- -- Don't charge for args, so that wrappers look cheap
-
- ------------
- size_up_con (Literal lit) args | isNoRepLit lit = sizeN opt_UF_NoRepLit
- | otherwise = sizeOne
-
- size_up_con (DataCon dc) args = conSizeN (valArgCount args)
-
- size_up_con (PrimOp op) args = foldr addSize (sizeN op_cost) (map arg_discount args)
- -- Give an arg-discount if a primop is applies to
- -- one of the function's arguments
- where
- op_cost | primOpIsDupable op = opt_UF_CheapOp
- | otherwise = opt_UF_DearOp
-
- ------------
- -- We want to record if we're case'ing, or applying, an argument
- arg_discount (Var v) | v `is_elem` args = scrutArg v
- arg_discount other = sizeZero
-
- is_elem :: Id -> [Id] -> Bool
- is_elem = isIn "size_up_scrut"
-
- ------------
- -- These addSize things have to be here because
- -- I don't want to give them bOMB_OUT_SIZE as an argument
-
- addSizeN TooBig _ = TooBig
- addSizeN (SizeIs n xs d) (I# m)
- | n_tot -# d <# bOMB_OUT_SIZE = SizeIs n_tot xs d
- | otherwise = TooBig
- where
- n_tot = n +# m
-
- addSize TooBig _ = TooBig
- addSize _ TooBig = TooBig
- addSize (SizeIs n1 xs d1) (SizeIs n2 ys d2)
- | (n_tot -# d_tot) <# bOMB_OUT_SIZE = SizeIs n_tot xys d_tot
- | otherwise = TooBig
- where
- n_tot = n1 +# n2
- d_tot = d1 +# d2
- xys = xs `unionBags` ys
-\end{code}
-
-Code for manipulating sizes
-
-\begin{code}
-
-data ExprSize = TooBig
- | SizeIs Int# -- Size found
- (Bag Id) -- Arguments cased herein
- Int# -- Size to subtract if result is scrutinised
- -- by a case expression
-
-sizeZero = SizeIs 0# emptyBag 0#
-sizeOne = SizeIs 1# emptyBag 0#
-sizeTwo = SizeIs 2# emptyBag 0#
-sizeN (I# n) = SizeIs n emptyBag 0#
-conSizeN (I# n) = SizeIs 1# emptyBag (n +# 1#)
- -- Treat constructors as size 1, that unfoldAlways responsds 'False'
- -- when asked about 'x' when x is bound to (C 3#).
- -- This avoids gratuitous 'ticks' when x itself appears as an
- -- atomic constructor argument.
-
-scrutArg v = SizeIs 0# (unitBag v) 0#
-
-nukeScrutDiscount (SizeIs n vs d) = SizeIs n vs 0#
-nukeScrutDiscount TooBig = TooBig
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
-%* *
-%************************************************************************
-
-We have very limited information about an unfolding expression: (1)~so
-many type arguments and so many value arguments expected---for our
-purposes here, we assume we've got those. (2)~A ``size'' or ``cost,''
-a single integer. (3)~An ``argument info'' vector. For this, what we
-have at the moment is a Boolean per argument position that says, ``I
-will look with great favour on an explicit constructor in this
-position.'' (4)~The ``discount'' to subtract if the expression
-is being scrutinised.
-
-Assuming we have enough type- and value arguments (if not, we give up
-immediately), then we see if the ``discounted size'' is below some
-(semi-arbitrary) threshold. It works like this: for every argument
-position where we're looking for a constructor AND WE HAVE ONE in our
-hands, we get a (again, semi-arbitrary) discount [proportion to the
-number of constructors in the type being scrutinized].
-
-If we're in the context of a scrutinee ( \tr{(case <expr > of A .. -> ...;.. )})
-and the expression in question will evaluate to a constructor, we use
-the computed discount size *for the result only* rather than
-computing the argument discounts. Since we know the result of
-the expression is going to be taken apart, discounting its size
-is more accurate (see @sizeExpr@ above for how this discount size
-is computed).
-
-We use this one to avoid exporting inlinings that we ``couldn't possibly
-use'' on the other side. Can be overridden w/ flaggery.
-Just the same as smallEnoughToInline, except that it has no actual arguments.
-
-\begin{code}
-couldBeSmallEnoughToInline :: UnfoldingGuidance -> Bool
-couldBeSmallEnoughToInline UnfoldNever = False
-couldBeSmallEnoughToInline other = True
-
-certainlySmallEnoughToInline :: UnfoldingGuidance -> Bool
-certainlySmallEnoughToInline UnfoldNever = False
-certainlySmallEnoughToInline UnfoldAlways = True
-certainlySmallEnoughToInline (UnfoldIfGoodArgs _ _ size _) = size <= opt_UF_UseThreshold
-\end{code}
-
-@okToUnfoldInHifile@ is used when emitting unfolding info into an interface
-file to determine whether an unfolding candidate really should be unfolded.
-The predicate is needed to prevent @_casm_@s (+ lit-lits) from being emitted
-into interface files.
-
-The reason for inlining expressions containing _casm_s into interface files
-is that these fragments of C are likely to mention functions/#defines that
-will be out-of-scope when inlined into another module. This is not an
-unfixable problem for the user (just need to -#include the approp. header
-file), but turning it off seems to the simplest thing to do.
-
-\begin{code}
-okToUnfoldInHiFile :: CoreExpr -> Bool
-okToUnfoldInHiFile e = opt_UnfoldCasms || go e
- where
- -- Race over an expression looking for CCalls..
- go (Var _) = True
- go (Con (Literal lit) _) = not (isLitLitLit lit)
- go (Con (PrimOp op) args) = okToUnfoldPrimOp op && all go args
- go (Con con args) = True -- con args are always atomic
- go (App fun arg) = go fun && go arg
- go (Lam _ body) = go body
- go (Let binds body) = and (map go (body :rhssOfBind binds))
- go (Case scrut bndr alts) = and (map go (scrut:rhssOfAlts alts))
- go (Note _ body) = go body
- go (Type _) = True
-
- -- ok to unfold a PrimOp as long as it's not a _casm_
- okToUnfoldPrimOp (CCallOp _ is_casm _ _) = not is_casm
- okToUnfoldPrimOp _ = True
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{callSiteInline}
-%* *
-%************************************************************************
-
-This is the key function. It decides whether to inline a variable at a call site
-
-callSiteInline is used at call sites, so it is a bit more generous.
-It's a very important function that embodies lots of heuristics.
-A non-WHNF can be inlined if it doesn't occur inside a lambda,
-and occurs exactly once or
- occurs once in each branch of a case and is small
-
-If the thing is in WHNF, there's no danger of duplicating work,
-so we can inline if it occurs once, or is small
-
-\begin{code}
-callSiteInline :: Bool -- True <=> the Id is black listed
- -> Bool -- 'inline' note at call site
- -> Id -- The Id
- -> [CoreExpr] -- Arguments
- -> Bool -- True <=> continuation is interesting
- -> Maybe CoreExpr -- Unfolding, if any
-
-
-callSiteInline black_listed inline_call id args interesting_cont
- = case getIdUnfolding id of {
- NoUnfolding -> Nothing ;
- OtherCon _ -> Nothing ;
- CoreUnfolding form guidance unf_template ->
-
- let
- result | yes_or_no = Just unf_template
- | otherwise = Nothing
-
- inline_prag = getInlinePragma id
- arg_infos = map interestingArg val_args
- val_args = filter isValArg args
- whnf = whnfOrBottom form
-
- yes_or_no =
- case inline_prag of
- IAmDead -> pprTrace "callSiteInline: dead" (ppr id) False
- IMustNotBeINLINEd -> False
- IAmALoopBreaker -> False
- IMustBeINLINEd -> True -- Overrides absolutely everything, including the black list
- ICanSafelyBeINLINEd in_lam one_br -> consider in_lam one_br
- NoInlinePragInfo -> consider InsideLam False
-
- consider in_lam one_branch
- | black_listed = False
- | inline_call = True
- | one_branch -- Be very keen to inline something if this is its unique occurrence; that
- -- gives a good chance of eliminating the original binding for the thing.
- -- The only time we hold back is when substituting inside a lambda;
- -- then if the context is totally uninteresting (not applied, not scrutinised)
- -- there is no point in substituting because it might just increase allocation.
- = case in_lam of
- NotInsideLam -> True
- InsideLam -> whnf && (not (null args) || interesting_cont)
-
- | otherwise -- Occurs (textually) more than once, so look at its size
- = case guidance of
- UnfoldAlways -> True
- UnfoldNever -> False
- UnfoldIfGoodArgs n_vals_wanted arg_discounts size res_discount
- | enough_args && size <= (n_vals_wanted + 1)
- -- No size increase
- -- Size of call is n_vals_wanted (+1 for the function)
- -> case in_lam of
- NotInsideLam -> True
- InsideLam -> whnf
-
- | not (or arg_infos || really_interesting_cont)
- -- If it occurs more than once, there must be something interesting
- -- about some argument, or the result, to make it worth inlining
- -> False
-
- | otherwise
- -> case in_lam of
- NotInsideLam -> small_enough
- InsideLam -> whnf && small_enough
-
- where
- n_args = length arg_infos
- enough_args = n_args >= n_vals_wanted
- really_interesting_cont | n_args < n_vals_wanted = False -- Too few args
- | n_args == n_vals_wanted = interesting_cont
- | otherwise = True -- Extra args
- -- This rather elaborate defn for really_interesting_cont is important
- -- Consider an I# = INLINE (\x -> I# {x})
- -- The unfolding guidance deems it to have size 2, and no arguments.
- -- So in an application (I# y) we must take the extra arg 'y' as
- -- evidene of an interesting context!
-
- small_enough = (size - discount) <= opt_UF_UseThreshold
- discount = computeDiscount n_vals_wanted arg_discounts res_discount
- arg_infos really_interesting_cont
-
-
- in
-#ifdef DEBUG
- if opt_D_dump_inlinings then
- pprTrace "Considering inlining"
- (ppr id <+> vcat [text "black listed" <+> ppr black_listed,
- text "inline prag:" <+> ppr inline_prag,
- text "arg infos" <+> ppr arg_infos,
- text "interesting continuation" <+> ppr interesting_cont,
- text "whnf" <+> ppr whnf,
- text "guidance" <+> ppr guidance,
- text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO",
- if yes_or_no then
- text "Unfolding =" <+> pprCoreExpr unf_template
- else empty])
- result
- else
-#endif
- result
- }
-
--- An argument is interesting if it has *some* structure
--- We are here trying to avoid unfolding a function that
--- is applied only to variables that have no unfolding
--- (i.e. they are probably lambda bound): f x y z
--- There is little point in inlining f here.
-interestingArg (Type _) = False
-interestingArg (App fn (Type _)) = interestingArg fn
-interestingArg (Var v) = hasUnfolding (getIdUnfolding v)
-interestingArg other = True
-
-
-computeDiscount :: Int -> [Int] -> Int -> [Bool] -> Bool -> Int
-computeDiscount n_vals_wanted arg_discounts res_discount arg_infos result_used
- -- We multiple the raw discounts (args_discount and result_discount)
- -- ty opt_UnfoldingKeenessFactor because the former have to do with
- -- *size* whereas the discounts imply that there's some extra
- -- *efficiency* to be gained (e.g. beta reductions, case reductions)
- -- by inlining.
-
- -- we also discount 1 for each argument passed, because these will
- -- reduce with the lambdas in the function (we count 1 for a lambda
- -- in size_up).
- = length (take n_vals_wanted arg_infos) +
- -- Discount of 1 for each arg supplied, because the
- -- result replaces the call
- round (opt_UF_KeenessFactor *
- fromInt (arg_discount + result_discount))
- where
- arg_discount = sum (zipWith mk_arg_discount arg_discounts arg_infos)
-
- mk_arg_discount discount is_evald | is_evald = discount
- | otherwise = 0
-
- -- Don't give a result discount unless there are enough args
- result_discount | result_used = res_discount -- Over-applied, or case scrut
- | otherwise = 0
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Black-listing}
-%* *
-%************************************************************************
-
-Inlining is controlled by the "Inline phase" number, which is set
-by the per-simplification-pass '-finline-phase' flag.
-
-For optimisation we use phase 1,2 and nothing (i.e. no -finline-phase flag)
-in that order. The meanings of these are determined by the @blackListed@ function
-here.
-
-\begin{code}
-blackListed :: IdSet -- Used in transformation rules
- -> Maybe Int -- Inline phase
- -> Id -> Bool -- True <=> blacklisted
-
--- The blackListed function sees whether a variable should *not* be
--- inlined because of the inline phase we are in. This is the sole
--- place that the inline phase number is looked at.
-
--- Phase 0: used for 'no inlinings please'
-blackListed rule_vars (Just 0)
- = \v -> True
-
--- Phase 1: don't inline any rule-y things or things with specialisations
-blackListed rule_vars (Just 1)
- = \v -> let v_uniq = idUnique v
- in v `elemVarSet` rule_vars
- || not (isEmptyCoreRules (getIdSpecialisation v))
- || v_uniq == runSTRepIdKey
-
--- Phase 2: allow build/augment to inline, and specialisations
-blackListed rule_vars (Just 2)
- = \v -> let v_uniq = idUnique v
- in (v `elemVarSet` rule_vars && not (v_uniq == buildIdKey ||
- v_uniq == augmentIdKey))
- || v_uniq == runSTRepIdKey
-
--- Otherwise just go for it
-blackListed rule_vars phase
- = \v -> False
-\end{code}
-
-
-SLPJ 95/04: Why @runST@ must be inlined very late:
-\begin{verbatim}
-f x =
- runST ( \ s -> let
- (a, s') = newArray# 100 [] s
- (_, s'') = fill_in_array_or_something a x s'
- in
- freezeArray# a s'' )
-\end{verbatim}
-If we inline @runST@, we'll get:
-\begin{verbatim}
-f x = let
- (a, s') = newArray# 100 [] realWorld#{-NB-}
- (_, s'') = fill_in_array_or_something a x s'
- in
- freezeArray# a s''
-\end{verbatim}
-And now the @newArray#@ binding can be floated to become a CAF, which
-is totally and utterly wrong:
-\begin{verbatim}
-f = let
- (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!
- in
- \ x ->
- let (_, s'') = fill_in_array_or_something a x s' in
- freezeArray# a s''
-\end{verbatim}
-All calls to @f@ will share a {\em single} array!
-
-Yet we do want to inline runST sometime, so we can avoid
-needless code. Solution: black list it until the last moment.
-
+%\r
+% (c) The AQUA Project, Glasgow University, 1994-1998\r
+%\r
+\section[CoreUnfold]{Core-syntax unfoldings}\r
+\r
+Unfoldings (which can travel across module boundaries) are in Core\r
+syntax (namely @CoreExpr@s).\r
+\r
+The type @Unfolding@ sits ``above'' simply-Core-expressions\r
+unfoldings, capturing ``higher-level'' things we know about a binding,\r
+usually things that the simplifier found out (e.g., ``it's a\r
+literal''). In the corner of a @CoreUnfolding@ unfolding, you will\r
+find, unsurprisingly, a Core expression.\r
+\r
+\begin{code}\r
+module CoreUnfold (\r
+ Unfolding(..), UnfoldingGuidance, -- types\r
+\r
+ noUnfolding, mkUnfolding, getUnfoldingTemplate,\r
+ isEvaldUnfolding, hasUnfolding,\r
+\r
+ couldBeSmallEnoughToInline, \r
+ certainlySmallEnoughToInline, \r
+ okToUnfoldInHiFile,\r
+\r
+ calcUnfoldingGuidance,\r
+\r
+ callSiteInline, blackListed\r
+ ) where\r
+\r
+#include "HsVersions.h"\r
+\r
+import CmdLineOpts ( opt_UF_CreationThreshold,\r
+ opt_UF_UseThreshold,\r
+ opt_UF_ScrutConDiscount,\r
+ opt_UF_FunAppDiscount,\r
+ opt_UF_PrimArgDiscount,\r
+ opt_UF_KeenessFactor,\r
+ opt_UF_CheapOp, opt_UF_DearOp, opt_UF_NoRepLit,\r
+ opt_UnfoldCasms, opt_PprStyle_Debug,\r
+ opt_D_dump_inlinings\r
+ )\r
+import CoreSyn\r
+import PprCore ( pprCoreExpr )\r
+import OccurAnal ( occurAnalyseGlobalExpr )\r
+import BinderInfo ( )\r
+import CoreUtils ( coreExprType, exprIsTrivial, mkFormSummary, whnfOrBottom,\r
+ FormSummary(..) )\r
+import Id ( Id, idType, idUnique, isId, \r
+ getIdSpecialisation, getInlinePragma, getIdUnfolding\r
+ )\r
+import VarSet\r
+import Const ( Con(..), isLitLitLit, isWHNFCon )\r
+import PrimOp ( PrimOp(..), primOpIsDupable )\r
+import IdInfo ( ArityInfo(..), InlinePragInfo(..), OccInfo(..) )\r
+import TyCon ( tyConFamilySize )\r
+import Type ( splitAlgTyConApp_maybe, splitFunTy_maybe )\r
+import Const ( isNoRepLit )\r
+import Unique ( Unique, buildIdKey, augmentIdKey, runSTRepIdKey )\r
+import Maybes ( maybeToBool )\r
+import Bag\r
+import Util ( isIn, lengthExceeds )\r
+import Outputable\r
+\end{code}\r
+\r
+%************************************************************************\r
+%* *\r
+\subsection{@Unfolding@ and @UnfoldingGuidance@ types}\r
+%* *\r
+%************************************************************************\r
+\r
+\begin{code}\r
+data Unfolding\r
+ = NoUnfolding\r
+\r
+ | OtherCon [Con] -- It ain't one of these\r
+ -- (OtherCon xs) also indicates that something has been evaluated\r
+ -- and hence there's no point in re-evaluating it.\r
+ -- OtherCon [] is used even for non-data-type values\r
+ -- to indicated evaluated-ness. Notably:\r
+ -- data C = C !(Int -> Int)\r
+ -- case x of { C f -> ... }\r
+ -- Here, f gets an OtherCon [] unfolding.\r
+\r
+ | CoreUnfolding -- An unfolding with redundant cached information\r
+ FormSummary -- Tells whether the template is a WHNF or bottom\r
+ UnfoldingGuidance -- Tells about the *size* of the template.\r
+ CoreExpr -- Template; binder-info is correct\r
+\end{code}\r
+\r
+\begin{code}\r
+noUnfolding = NoUnfolding\r
+\r
+mkUnfolding expr\r
+ = let\r
+ -- strictness mangling (depends on there being no CSE)\r
+ ufg = calcUnfoldingGuidance opt_UF_CreationThreshold expr\r
+ occ = occurAnalyseGlobalExpr expr\r
+ in\r
+ CoreUnfolding (mkFormSummary expr) ufg occ\r
+\r
+getUnfoldingTemplate :: Unfolding -> CoreExpr\r
+getUnfoldingTemplate (CoreUnfolding _ _ expr) = expr\r
+getUnfoldingTemplate other = panic "getUnfoldingTemplate"\r
+\r
+isEvaldUnfolding :: Unfolding -> Bool\r
+isEvaldUnfolding (OtherCon _) = True\r
+isEvaldUnfolding (CoreUnfolding ValueForm _ expr) = True\r
+isEvaldUnfolding other = False\r
+\r
+hasUnfolding :: Unfolding -> Bool\r
+hasUnfolding NoUnfolding = False\r
+hasUnfolding other = True\r
+\r
+data UnfoldingGuidance\r
+ = UnfoldNever\r
+ | UnfoldAlways -- There is no "original" definition,\r
+ -- so you'd better unfold. Or: something\r
+ -- so cheap to unfold (e.g., 1#) that\r
+ -- you should do it absolutely always.\r
+\r
+ | UnfoldIfGoodArgs Int -- and "n" value args\r
+\r
+ [Int] -- Discount if the argument is evaluated.\r
+ -- (i.e., a simplification will definitely\r
+ -- be possible). One elt of the list per *value* arg.\r
+\r
+ Int -- The "size" of the unfolding; to be elaborated\r
+ -- later. ToDo\r
+\r
+ Int -- Scrutinee discount: the discount to substract if the thing is in\r
+ -- a context (case (thing args) of ...),\r
+ -- (where there are the right number of arguments.)\r
+\end{code}\r
+\r
+\begin{code}\r
+instance Outputable UnfoldingGuidance where\r
+ ppr UnfoldAlways = ptext SLIT("ALWAYS")\r
+ ppr UnfoldNever = ptext SLIT("NEVER")\r
+ ppr (UnfoldIfGoodArgs v cs size discount)\r
+ = hsep [ptext SLIT("IF_ARGS"), int v,\r
+ if null cs -- always print *something*\r
+ then char 'X'\r
+ else hcat (map (text . show) cs),\r
+ int size,\r
+ int discount ]\r
+\end{code}\r
+\r
+\r
+%************************************************************************\r
+%* *\r
+\subsection[calcUnfoldingGuidance]{Calculate ``unfolding guidance'' for an expression}\r
+%* *\r
+%************************************************************************\r
+\r
+\begin{code}\r
+calcUnfoldingGuidance\r
+ :: Int -- bomb out if size gets bigger than this\r
+ -> CoreExpr -- expression to look at\r
+ -> UnfoldingGuidance\r
+calcUnfoldingGuidance bOMB_OUT_SIZE expr\r
+ | exprIsTrivial expr -- Often trivial expressions are never bound\r
+ -- to an expression, but it can happen. For\r
+ -- example, the Id for a nullary constructor has\r
+ -- a trivial expression as its unfolding, and\r
+ -- we want to make sure that we always unfold it.\r
+ = UnfoldAlways\r
+ \r
+ | otherwise\r
+ = case collectBinders expr of { (binders, body) ->\r
+ let\r
+ val_binders = filter isId binders\r
+ in\r
+ case (sizeExpr bOMB_OUT_SIZE val_binders body) of\r
+\r
+ TooBig -> UnfoldNever\r
+\r
+ SizeIs size cased_args scrut_discount\r
+ -> UnfoldIfGoodArgs\r
+ (length val_binders)\r
+ (map discount_for val_binders)\r
+ (I# size)\r
+ (I# scrut_discount)\r
+ where \r
+ discount_for b \r
+ | num_cases == 0 = 0\r
+ | is_fun_ty = num_cases * opt_UF_FunAppDiscount\r
+ | is_data_ty = num_cases * tyConFamilySize tycon * opt_UF_ScrutConDiscount\r
+ | otherwise = num_cases * opt_UF_PrimArgDiscount\r
+ where\r
+ num_cases = foldlBag (\n b' -> if b==b' then n+1 else n) 0 cased_args\r
+ -- Count occurrences of b in cased_args\r
+ arg_ty = idType b\r
+ is_fun_ty = maybeToBool (splitFunTy_maybe arg_ty)\r
+ (is_data_ty, tycon) = case (splitAlgTyConApp_maybe (idType b)) of\r
+ Nothing -> (False, panic "discount")\r
+ Just (tc,_,_) -> (True, tc)\r
+ }\r
+\end{code}\r
+\r
+\begin{code}\r
+sizeExpr :: Int -- Bomb out if it gets bigger than this\r
+ -> [Id] -- Arguments; we're interested in which of these\r
+ -- get case'd\r
+ -> CoreExpr\r
+ -> ExprSize\r
+\r
+sizeExpr (I# bOMB_OUT_SIZE) args expr\r
+ = size_up expr\r
+ where\r
+ size_up (Type t) = sizeZero -- Types cost nothing\r
+ size_up (Var v) = sizeOne\r
+\r
+ size_up (Note InlineMe _) = sizeTwo -- The idea is that this is one more\r
+ -- than the size of the "call" (i.e. 1)\r
+ -- We want to reply "no" to noSizeIncrease\r
+ -- for a bare reference (i.e. applied to no args) \r
+ -- to an INLINE thing\r
+\r
+ size_up (Note _ body) = size_up body -- Notes cost nothing\r
+\r
+ size_up (App fun (Type t)) = size_up fun\r
+ size_up (App fun arg) = size_up_app fun `addSize` size_up arg\r
+\r
+ size_up (Con con args) = foldr (addSize . size_up) \r
+ (size_up_con con args)\r
+ args\r
+\r
+ size_up (Lam b e) | isId b = size_up e `addSizeN` 1\r
+ | otherwise = size_up e\r
+\r
+ size_up (Let (NonRec binder rhs) body)\r
+ = nukeScrutDiscount (size_up rhs) `addSize`\r
+ size_up body `addSizeN`\r
+ 1 -- For the allocation\r
+\r
+ size_up (Let (Rec pairs) body)\r
+ = nukeScrutDiscount rhs_size `addSize`\r
+ size_up body `addSizeN`\r
+ length pairs -- For the allocation\r
+ where\r
+ rhs_size = foldr (addSize . size_up . snd) sizeZero pairs\r
+\r
+ size_up (Case scrut _ alts)\r
+ = nukeScrutDiscount (size_up scrut) `addSize`\r
+ arg_discount scrut `addSize`\r
+ foldr (addSize . size_up_alt) sizeZero alts `addSizeN`\r
+ case (splitAlgTyConApp_maybe (coreExprType scrut)) of\r
+ Nothing -> 1\r
+ Just (tc,_,_) -> tyConFamilySize tc\r
+\r
+ ------------ \r
+ -- A function application with at least one value argument\r
+ -- so if the function is an argument give it an arg-discount\r
+ size_up_app (App fun arg) = size_up_app fun `addSize` size_up arg\r
+ size_up_app fun = arg_discount fun `addSize` size_up fun\r
+\r
+ ------------ \r
+ size_up_alt (con, bndrs, rhs) = size_up rhs\r
+ -- Don't charge for args, so that wrappers look cheap\r
+\r
+ ------------\r
+ size_up_con (Literal lit) args | isNoRepLit lit = sizeN opt_UF_NoRepLit\r
+ | otherwise = sizeOne\r
+\r
+ size_up_con (DataCon dc) args = conSizeN (valArgCount args)\r
+ \r
+ size_up_con (PrimOp op) args = foldr addSize (sizeN op_cost) (map arg_discount args)\r
+ -- Give an arg-discount if a primop is applies to\r
+ -- one of the function's arguments\r
+ where\r
+ op_cost | primOpIsDupable op = opt_UF_CheapOp\r
+ | otherwise = opt_UF_DearOp\r
+\r
+ ------------\r
+ -- We want to record if we're case'ing, or applying, an argument\r
+ arg_discount (Var v) | v `is_elem` args = scrutArg v\r
+ arg_discount other = sizeZero\r
+\r
+ is_elem :: Id -> [Id] -> Bool\r
+ is_elem = isIn "size_up_scrut"\r
+\r
+ ------------\r
+ -- These addSize things have to be here because\r
+ -- I don't want to give them bOMB_OUT_SIZE as an argument\r
+\r
+ addSizeN TooBig _ = TooBig\r
+ addSizeN (SizeIs n xs d) (I# m)\r
+ | n_tot -# d <# bOMB_OUT_SIZE = SizeIs n_tot xs d\r
+ | otherwise = TooBig\r
+ where\r
+ n_tot = n +# m\r
+ \r
+ addSize TooBig _ = TooBig\r
+ addSize _ TooBig = TooBig\r
+ addSize (SizeIs n1 xs d1) (SizeIs n2 ys d2)\r
+ | (n_tot -# d_tot) <# bOMB_OUT_SIZE = SizeIs n_tot xys d_tot\r
+ | otherwise = TooBig\r
+ where\r
+ n_tot = n1 +# n2\r
+ d_tot = d1 +# d2\r
+ xys = xs `unionBags` ys\r
+\end{code}\r
+\r
+Code for manipulating sizes\r
+\r
+\begin{code}\r
+\r
+data ExprSize = TooBig\r
+ | SizeIs Int# -- Size found\r
+ (Bag Id) -- Arguments cased herein\r
+ Int# -- Size to subtract if result is scrutinised \r
+ -- by a case expression\r
+\r
+sizeZero = SizeIs 0# emptyBag 0#\r
+sizeOne = SizeIs 1# emptyBag 0#\r
+sizeTwo = SizeIs 2# emptyBag 0#\r
+sizeN (I# n) = SizeIs n emptyBag 0#\r
+conSizeN (I# n) = SizeIs 1# emptyBag (n +# 1#)\r
+ -- Treat constructors as size 1, that unfoldAlways responsds 'False'\r
+ -- when asked about 'x' when x is bound to (C 3#).\r
+ -- This avoids gratuitous 'ticks' when x itself appears as an\r
+ -- atomic constructor argument.\r
+ \r
+scrutArg v = SizeIs 0# (unitBag v) 0#\r
+\r
+nukeScrutDiscount (SizeIs n vs d) = SizeIs n vs 0#\r
+nukeScrutDiscount TooBig = TooBig\r
+\end{code}\r
+\r
+\r
+%************************************************************************\r
+%* *\r
+\subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}\r
+%* *\r
+%************************************************************************\r
+\r
+We have very limited information about an unfolding expression: (1)~so\r
+many type arguments and so many value arguments expected---for our\r
+purposes here, we assume we've got those. (2)~A ``size'' or ``cost,''\r
+a single integer. (3)~An ``argument info'' vector. For this, what we\r
+have at the moment is a Boolean per argument position that says, ``I\r
+will look with great favour on an explicit constructor in this\r
+position.'' (4)~The ``discount'' to subtract if the expression\r
+is being scrutinised. \r
+\r
+Assuming we have enough type- and value arguments (if not, we give up\r
+immediately), then we see if the ``discounted size'' is below some\r
+(semi-arbitrary) threshold. It works like this: for every argument\r
+position where we're looking for a constructor AND WE HAVE ONE in our\r
+hands, we get a (again, semi-arbitrary) discount [proportion to the\r
+number of constructors in the type being scrutinized].\r
+\r
+If we're in the context of a scrutinee ( \tr{(case <expr > of A .. -> ...;.. )})\r
+and the expression in question will evaluate to a constructor, we use\r
+the computed discount size *for the result only* rather than\r
+computing the argument discounts. Since we know the result of\r
+the expression is going to be taken apart, discounting its size\r
+is more accurate (see @sizeExpr@ above for how this discount size\r
+is computed).\r
+\r
+We use this one to avoid exporting inlinings that we ``couldn't possibly\r
+use'' on the other side. Can be overridden w/ flaggery.\r
+Just the same as smallEnoughToInline, except that it has no actual arguments.\r
+\r
+\begin{code}\r
+couldBeSmallEnoughToInline :: UnfoldingGuidance -> Bool\r
+couldBeSmallEnoughToInline UnfoldNever = False\r
+couldBeSmallEnoughToInline other = True\r
+\r
+certainlySmallEnoughToInline :: UnfoldingGuidance -> Bool\r
+certainlySmallEnoughToInline UnfoldNever = False\r
+certainlySmallEnoughToInline UnfoldAlways = True\r
+certainlySmallEnoughToInline (UnfoldIfGoodArgs _ _ size _) = size <= opt_UF_UseThreshold\r
+\end{code}\r
+\r
+@okToUnfoldInHifile@ is used when emitting unfolding info into an interface\r
+file to determine whether an unfolding candidate really should be unfolded.\r
+The predicate is needed to prevent @_casm_@s (+ lit-lits) from being emitted\r
+into interface files. \r
+\r
+The reason for inlining expressions containing _casm_s into interface files\r
+is that these fragments of C are likely to mention functions/#defines that\r
+will be out-of-scope when inlined into another module. This is not an\r
+unfixable problem for the user (just need to -#include the approp. header\r
+file), but turning it off seems to the simplest thing to do.\r
+\r
+\begin{code}\r
+okToUnfoldInHiFile :: CoreExpr -> Bool\r
+okToUnfoldInHiFile e = opt_UnfoldCasms || go e\r
+ where\r
+ -- Race over an expression looking for CCalls..\r
+ go (Var _) = True\r
+ go (Con (Literal lit) _) = not (isLitLitLit lit)\r
+ go (Con (PrimOp op) args) = okToUnfoldPrimOp op && all go args\r
+ go (Con con args) = True -- con args are always atomic\r
+ go (App fun arg) = go fun && go arg\r
+ go (Lam _ body) = go body\r
+ go (Let binds body) = and (map go (body :rhssOfBind binds))\r
+ go (Case scrut bndr alts) = and (map go (scrut:rhssOfAlts alts))\r
+ go (Note _ body) = go body\r
+ go (Type _) = True\r
+\r
+ -- ok to unfold a PrimOp as long as it's not a _casm_\r
+ okToUnfoldPrimOp (CCallOp _ is_casm _ _) = not is_casm\r
+ okToUnfoldPrimOp _ = True\r
+\end{code}\r
+\r
+\r
+%************************************************************************\r
+%* *\r
+\subsection{callSiteInline}\r
+%* *\r
+%************************************************************************\r
+\r
+This is the key function. It decides whether to inline a variable at a call site\r
+\r
+callSiteInline is used at call sites, so it is a bit more generous.\r
+It's a very important function that embodies lots of heuristics.\r
+A non-WHNF can be inlined if it doesn't occur inside a lambda,\r
+and occurs exactly once or \r
+ occurs once in each branch of a case and is small\r
+\r
+If the thing is in WHNF, there's no danger of duplicating work, \r
+so we can inline if it occurs once, or is small\r
+\r
+\begin{code}\r
+callSiteInline :: Bool -- True <=> the Id is black listed\r
+ -> Bool -- 'inline' note at call site\r
+ -> Id -- The Id\r
+ -> [CoreExpr] -- Arguments\r
+ -> Bool -- True <=> continuation is interesting\r
+ -> Maybe CoreExpr -- Unfolding, if any\r
+\r
+\r
+callSiteInline black_listed inline_call id args interesting_cont\r
+ = case getIdUnfolding id of {\r
+ NoUnfolding -> Nothing ;\r
+ OtherCon _ -> Nothing ;\r
+ CoreUnfolding form guidance unf_template ->\r
+\r
+ let\r
+ result | yes_or_no = Just unf_template\r
+ | otherwise = Nothing\r
+\r
+ inline_prag = getInlinePragma id\r
+ arg_infos = map interestingArg val_args\r
+ val_args = filter isValArg args\r
+ whnf = whnfOrBottom form\r
+\r
+ yes_or_no =\r
+ case inline_prag of\r
+ IAmDead -> pprTrace "callSiteInline: dead" (ppr id) False\r
+ IMustNotBeINLINEd -> False\r
+ IAmALoopBreaker -> False\r
+ IMustBeINLINEd -> True -- Overrides absolutely everything, including the black list\r
+ ICanSafelyBeINLINEd in_lam one_br -> consider in_lam one_br\r
+ NoInlinePragInfo -> consider InsideLam False\r
+\r
+ consider in_lam one_branch \r
+ | black_listed = False\r
+ | inline_call = True\r
+ | one_branch -- Be very keen to inline something if this is its unique occurrence; that\r
+ -- gives a good chance of eliminating the original binding for the thing.\r
+ -- The only time we hold back is when substituting inside a lambda;\r
+ -- then if the context is totally uninteresting (not applied, not scrutinised)\r
+ -- there is no point in substituting because it might just increase allocation.\r
+ = case in_lam of\r
+ NotInsideLam -> True\r
+ InsideLam -> whnf && (not (null args) || interesting_cont)\r
+\r
+ | otherwise -- Occurs (textually) more than once, so look at its size\r
+ = case guidance of\r
+ UnfoldAlways -> True\r
+ UnfoldNever -> False\r
+ UnfoldIfGoodArgs n_vals_wanted arg_discounts size res_discount\r
+ | enough_args && size <= (n_vals_wanted + 1)\r
+ -- No size increase\r
+ -- Size of call is n_vals_wanted (+1 for the function)\r
+ -> case in_lam of\r
+ NotInsideLam -> True\r
+ InsideLam -> whnf\r
+\r
+ | not (or arg_infos || really_interesting_cont)\r
+ -- If it occurs more than once, there must be something interesting \r
+ -- about some argument, or the result, to make it worth inlining\r
+ -> False\r
+ \r
+ | otherwise\r
+ -> case in_lam of\r
+ NotInsideLam -> small_enough\r
+ InsideLam -> whnf && small_enough\r
+\r
+ where\r
+ n_args = length arg_infos\r
+ enough_args = n_args >= n_vals_wanted\r
+ really_interesting_cont | n_args < n_vals_wanted = False -- Too few args\r
+ | n_args == n_vals_wanted = interesting_cont\r
+ | otherwise = True -- Extra args\r
+ -- This rather elaborate defn for really_interesting_cont is important\r
+ -- Consider an I# = INLINE (\x -> I# {x})\r
+ -- The unfolding guidance deems it to have size 2, and no arguments.\r
+ -- So in an application (I# y) we must take the extra arg 'y' as\r
+ -- evidene of an interesting context!\r
+ \r
+ small_enough = (size - discount) <= opt_UF_UseThreshold\r
+ discount = computeDiscount n_vals_wanted arg_discounts res_discount \r
+ arg_infos really_interesting_cont\r
+\r
+ \r
+ in \r
+#ifdef DEBUG\r
+ if opt_D_dump_inlinings then\r
+ pprTrace "Considering inlining"\r
+ (ppr id <+> vcat [text "black listed" <+> ppr black_listed,\r
+ text "inline prag:" <+> ppr inline_prag,\r
+ text "arg infos" <+> ppr arg_infos,\r
+ text "interesting continuation" <+> ppr interesting_cont,\r
+ text "whnf" <+> ppr whnf,\r
+ text "guidance" <+> ppr guidance,\r
+ text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO",\r
+ if yes_or_no then\r
+ text "Unfolding =" <+> pprCoreExpr unf_template\r
+ else empty])\r
+ result\r
+ else\r
+#endif\r
+ result\r
+ }\r
+\r
+-- An argument is interesting if it has *some* structure\r
+-- We are here trying to avoid unfolding a function that\r
+-- is applied only to variables that have no unfolding\r
+-- (i.e. they are probably lambda bound): f x y z\r
+-- There is little point in inlining f here.\r
+interestingArg (Type _) = False\r
+interestingArg (App fn (Type _)) = interestingArg fn\r
+interestingArg (Var v) = hasUnfolding (getIdUnfolding v)\r
+interestingArg other = True\r
+\r
+\r
+computeDiscount :: Int -> [Int] -> Int -> [Bool] -> Bool -> Int\r
+computeDiscount n_vals_wanted arg_discounts res_discount arg_infos result_used\r
+ -- We multiple the raw discounts (args_discount and result_discount)\r
+ -- ty opt_UnfoldingKeenessFactor because the former have to do with\r
+ -- *size* whereas the discounts imply that there's some extra \r
+ -- *efficiency* to be gained (e.g. beta reductions, case reductions) \r
+ -- by inlining.\r
+\r
+ -- we also discount 1 for each argument passed, because these will\r
+ -- reduce with the lambdas in the function (we count 1 for a lambda\r
+ -- in size_up).\r
+ = length (take n_vals_wanted arg_infos) +\r
+ -- Discount of 1 for each arg supplied, because the \r
+ -- result replaces the call\r
+ round (opt_UF_KeenessFactor * \r
+ fromInt (arg_discount + result_discount))\r
+ where\r
+ arg_discount = sum (zipWith mk_arg_discount arg_discounts arg_infos)\r
+\r
+ mk_arg_discount discount is_evald | is_evald = discount\r
+ | otherwise = 0\r
+\r
+ -- Don't give a result discount unless there are enough args\r
+ result_discount | result_used = res_discount -- Over-applied, or case scrut\r
+ | otherwise = 0\r
+\end{code}\r
+\r
+\r
+%************************************************************************\r
+%* *\r
+\subsection{Black-listing}\r
+%* *\r
+%************************************************************************\r
+\r
+Inlining is controlled by the "Inline phase" number, which is set\r
+by the per-simplification-pass '-finline-phase' flag.\r
+\r
+For optimisation we use phase 1,2 and nothing (i.e. no -finline-phase flag)\r
+in that order. The meanings of these are determined by the @blackListed@ function\r
+here.\r
+\r
+\begin{code}\r
+blackListed :: IdSet -- Used in transformation rules\r
+ -> Maybe Int -- Inline phase\r
+ -> Id -> Bool -- True <=> blacklisted\r
+ \r
+-- The blackListed function sees whether a variable should *not* be \r
+-- inlined because of the inline phase we are in. This is the sole\r
+-- place that the inline phase number is looked at.\r
+\r
+-- Phase 0: used for 'no inlinings please'\r
+blackListed rule_vars (Just 0)\r
+ = \v -> True\r
+\r
+-- Phase 1: don't inline any rule-y things or things with specialisations\r
+blackListed rule_vars (Just 1)\r
+ = \v -> let v_uniq = idUnique v\r
+ in v `elemVarSet` rule_vars\r
+ || not (isEmptyCoreRules (getIdSpecialisation v))\r
+ || v_uniq == runSTRepIdKey\r
+\r
+-- Phase 2: allow build/augment to inline, and specialisations\r
+blackListed rule_vars (Just 2)\r
+ = \v -> let v_uniq = idUnique v\r
+ in (v `elemVarSet` rule_vars && not (v_uniq == buildIdKey || \r
+ v_uniq == augmentIdKey))\r
+ || v_uniq == runSTRepIdKey\r
+\r
+-- Otherwise just go for it\r
+blackListed rule_vars phase\r
+ = \v -> False\r
+\end{code}\r
+\r
+\r
+SLPJ 95/04: Why @runST@ must be inlined very late:\r
+\begin{verbatim}\r
+f x =\r
+ runST ( \ s -> let\r
+ (a, s') = newArray# 100 [] s\r
+ (_, s'') = fill_in_array_or_something a x s'\r
+ in\r
+ freezeArray# a s'' )\r
+\end{verbatim}\r
+If we inline @runST@, we'll get:\r
+\begin{verbatim}\r
+f x = let\r
+ (a, s') = newArray# 100 [] realWorld#{-NB-}\r
+ (_, s'') = fill_in_array_or_something a x s'\r
+ in\r
+ freezeArray# a s''\r
+\end{verbatim}\r
+And now the @newArray#@ binding can be floated to become a CAF, which\r
+is totally and utterly wrong:\r
+\begin{verbatim}\r
+f = let\r
+ (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!\r
+ in\r
+ \ x ->\r
+ let (_, s'') = fill_in_array_or_something a x s' in\r
+ freezeArray# a s''\r
+\end{verbatim}\r
+All calls to @f@ will share a {\em single} array! \r
+\r
+Yet we do want to inline runST sometime, so we can avoid\r
+needless code. Solution: black list it until the last moment.\r
+\r
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section[PrimOp]{Primitive operations (machine-level)}
-
-\begin{code}
-module PrimOp (
- PrimOp(..), allThePrimOps,
- primOpType, primOpSig, primOpUsg,
- mkPrimOpIdName, primOpRdrName,
-
- commutableOp,
-
- primOpOutOfLine, primOpNeedsWrapper, primOpStrictness,
- primOpOkForSpeculation, primOpIsCheap, primOpIsDupable,
- primOpHasSideEffects,
-
- getPrimOpResultInfo, PrimOpResultInfo(..),
-
- pprPrimOp
- ) where
-
-#include "HsVersions.h"
-
-import PrimRep -- most of it
-import TysPrim
-import TysWiredIn
-
-import Demand ( Demand, wwLazy, wwPrim, wwStrict )
-import Var ( TyVar, Id )
-import CallConv ( CallConv, pprCallConv )
-import PprType ( pprParendType )
-import Name ( Name, mkWiredInIdName )
-import RdrName ( RdrName, mkRdrQual )
-import OccName ( OccName, pprOccName, mkSrcVarOcc )
-import TyCon ( TyCon, tyConArity )
-import Type ( Type, mkForAllTys, mkForAllTy, mkFunTy, mkFunTys, mkTyVarTys,
- mkTyConTy, mkTyConApp, typePrimRep,
- splitFunTy_maybe, splitAlgTyConApp_maybe, splitTyConApp_maybe,
- UsageAnn(..), mkUsgTy
- )
-import Unique ( Unique, mkPrimOpIdUnique )
-import PrelMods ( pREL_GHC, pREL_GHC_Name )
-import Outputable
-import Util ( assoc, zipWithEqual )
-import GlaExts ( Int(..), Int#, (==#) )
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[PrimOp-datatype]{Datatype for @PrimOp@ (an enumeration)}
-%* *
-%************************************************************************
-
-These are in \tr{state-interface.verb} order.
-
-\begin{code}
-data PrimOp
- -- dig the FORTRAN/C influence on the names...
-
- -- comparisons:
-
- = CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp
- | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp
- | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp
- | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp
- | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp
- | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp
-
- -- Char#-related ops:
- | OrdOp | ChrOp
-
- -- Int#-related ops:
- -- IntAbsOp unused?? ADR
- | IntAddOp | IntSubOp | IntMulOp | IntQuotOp
- | IntRemOp | IntNegOp | IntAbsOp
- | ISllOp | ISraOp | ISrlOp -- shift {left,right} {arithmetic,logical}
- | IntAddCOp
- | IntSubCOp
- | IntMulCOp
-
- -- Word#-related ops:
- | WordQuotOp | WordRemOp
- | AndOp | OrOp | NotOp | XorOp
- | SllOp | SrlOp -- shift {left,right} {logical}
- | Int2WordOp | Word2IntOp -- casts
-
- -- Addr#-related ops:
- | Int2AddrOp | Addr2IntOp -- casts
-
- -- Float#-related ops:
- | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp
- | Float2IntOp | Int2FloatOp
-
- | FloatExpOp | FloatLogOp | FloatSqrtOp
- | FloatSinOp | FloatCosOp | FloatTanOp
- | FloatAsinOp | FloatAcosOp | FloatAtanOp
- | FloatSinhOp | FloatCoshOp | FloatTanhOp
- -- not all machines have these available conveniently:
- -- | FloatAsinhOp | FloatAcoshOp | FloatAtanhOp
- | FloatPowerOp -- ** op
-
- -- Double#-related ops:
- | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp
- | Double2IntOp | Int2DoubleOp
- | Double2FloatOp | Float2DoubleOp
-
- | DoubleExpOp | DoubleLogOp | DoubleSqrtOp
- | DoubleSinOp | DoubleCosOp | DoubleTanOp
- | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp
- | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp
- -- not all machines have these available conveniently:
- -- | DoubleAsinhOp | DoubleAcoshOp | DoubleAtanhOp
- | DoublePowerOp -- ** op
-
- -- Integer (and related...) ops:
- -- slightly weird -- to match GMP package.
- | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerGcdOp
- | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp
-
- | IntegerCmpOp
- | IntegerCmpIntOp
-
- | Integer2IntOp | Integer2WordOp
- | Int2IntegerOp | Word2IntegerOp
- | Addr2IntegerOp
- -- casting to/from Integer and 64-bit (un)signed quantities.
- | IntegerToInt64Op | Int64ToIntegerOp
- | IntegerToWord64Op | Word64ToIntegerOp
- -- ?? gcd, etc?
-
- | FloatDecodeOp
- | DoubleDecodeOp
-
- -- primitive ops for primitive arrays
-
- | NewArrayOp
- | NewByteArrayOp PrimRep
-
- | SameMutableArrayOp
- | SameMutableByteArrayOp
-
- | ReadArrayOp | WriteArrayOp | IndexArrayOp -- for arrays of Haskell ptrs
-
- | ReadByteArrayOp PrimRep
- | WriteByteArrayOp PrimRep
- | IndexByteArrayOp PrimRep
- | IndexOffAddrOp PrimRep
- | WriteOffAddrOp PrimRep
- -- PrimRep can be one of {Char,Int,Addr,Float,Double}Kind.
- -- This is just a cheesy encoding of a bunch of ops.
- -- Note that ForeignObjRep is not included -- the only way of
- -- creating a ForeignObj is with a ccall or casm.
- | IndexOffForeignObjOp PrimRep
-
- | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp
- | UnsafeThawArrayOp | UnsafeThawByteArrayOp
- | SizeofByteArrayOp | SizeofMutableByteArrayOp
-
- -- Mutable variables
- | NewMutVarOp
- | ReadMutVarOp
- | WriteMutVarOp
- | SameMutVarOp
-
- -- for MVars
- | NewMVarOp
- | TakeMVarOp
- | PutMVarOp
- | SameMVarOp
- | IsEmptyMVarOp
-
- -- exceptions
- | CatchOp
- | RaiseOp
-
- -- foreign objects
- | MakeForeignObjOp
- | WriteForeignObjOp
-
- -- weak pointers
- | MkWeakOp
- | DeRefWeakOp
- | FinalizeWeakOp
-
- -- stable names
- | MakeStableNameOp
- | EqStableNameOp
- | StableNameToIntOp
-
- -- stable pointers
- | MakeStablePtrOp
- | DeRefStablePtrOp
- | EqStablePtrOp
-\end{code}
-
-A special ``trap-door'' to use in making calls direct to C functions:
-\begin{code}
- | CCallOp (Either
- FAST_STRING -- Left fn => An "unboxed" ccall# to `fn'.
- Unique) -- Right u => first argument (an Addr#) is the function pointer
- -- (unique is used to generate a 'typedef' to cast
- -- the function pointer if compiling the ccall# down to
- -- .hc code - can't do this inline for tedious reasons.)
-
- Bool -- True <=> really a "casm"
- Bool -- True <=> might invoke Haskell GC
- CallConv -- calling convention to use.
-
- -- (... to be continued ... )
-\end{code}
-
-The ``type'' of @CCallOp foo [t1, ... tm] r@ is @t1 -> ... tm -> r@.
-(See @primOpInfo@ for details.)
-
-Note: that first arg and part of the result should be the system state
-token (which we carry around to fool over-zealous optimisers) but
-which isn't actually passed.
-
-For example, we represent
-\begin{pseudocode}
-((ccall# foo [StablePtr# a, Int] Float) sp# i#) :: (Float, IoWorld)
-\end{pseudocode}
-by
-\begin{pseudocode}
-Case
- ( Prim
- (CCallOp "foo" [Universe#, StablePtr# a, Int#] FloatPrimAndUniverse False)
- -- :: Universe# -> StablePtr# a -> Int# -> FloatPrimAndUniverse
- []
- [w#, sp# i#]
- )
- (AlgAlts [ ( FloatPrimAndIoWorld,
- [f#, w#],
- Con (TupleCon 2) [Float, IoWorld] [F# f#, World w#]
- ) ]
- NoDefault
- )
-\end{pseudocode}
-
-Nota Bene: there are some people who find the empty list of types in
-the @Prim@ somewhat puzzling and would represent the above by
-\begin{pseudocode}
-Case
- ( Prim
- (CCallOp "foo" [alpha1, alpha2, alpha3] alpha4 False)
- -- :: /\ alpha1, alpha2 alpha3, alpha4.
- -- alpha1 -> alpha2 -> alpha3 -> alpha4
- [Universe#, StablePtr# a, Int#, FloatPrimAndIoWorld]
- [w#, sp# i#]
- )
- (AlgAlts [ ( FloatPrimAndIoWorld,
- [f#, w#],
- Con (TupleCon 2) [Float, IoWorld] [F# f#, World w#]
- ) ]
- NoDefault
- )
-\end{pseudocode}
-
-But, this is a completely different way of using @CCallOp@. The most
-major changes required if we switch to this are in @primOpInfo@, and
-the desugarer. The major difficulty is in moving the HeapRequirement
-stuff somewhere appropriate. (The advantage is that we could simplify
-@CCallOp@ and record just the number of arguments with corresponding
-simplifications in reading pragma unfoldings, the simplifier,
-instantiation (etc) of core expressions, ... . Maybe we should think
-about using it this way?? ADR)
-
-\begin{code}
- -- (... continued from above ... )
-
- -- Operation to test two closure addresses for equality (yes really!)
- -- BLAME ALASTAIR REID FOR THIS! THE REST OF US ARE INNOCENT!
- | ReallyUnsafePtrEqualityOp
-
- -- parallel stuff
- | SeqOp
- | ParOp
-
- -- concurrency
- | ForkOp
- | KillThreadOp
- | YieldOp
- | MyThreadIdOp
- | DelayOp
- | WaitReadOp
- | WaitWriteOp
-
- -- more parallel stuff
- | ParGlobalOp -- named global par
- | ParLocalOp -- named local par
- | ParAtOp -- specifies destination of local par
- | ParAtAbsOp -- specifies destination of local par (abs processor)
- | ParAtRelOp -- specifies destination of local par (rel processor)
- | ParAtForNowOp -- specifies initial destination of global par
- | CopyableOp -- marks copyable code
- | NoFollowOp -- marks non-followup expression
-
- -- tag-related
- | DataToTagOp
- | TagToEnumOp
-\end{code}
-
-Used for the Ord instance
-
-\begin{code}
-tagOf_PrimOp CharGtOp = (ILIT( 1) :: FAST_INT)
-tagOf_PrimOp CharGeOp = ILIT( 2)
-tagOf_PrimOp CharEqOp = ILIT( 3)
-tagOf_PrimOp CharNeOp = ILIT( 4)
-tagOf_PrimOp CharLtOp = ILIT( 5)
-tagOf_PrimOp CharLeOp = ILIT( 6)
-tagOf_PrimOp IntGtOp = ILIT( 7)
-tagOf_PrimOp IntGeOp = ILIT( 8)
-tagOf_PrimOp IntEqOp = ILIT( 9)
-tagOf_PrimOp IntNeOp = ILIT( 10)
-tagOf_PrimOp IntLtOp = ILIT( 11)
-tagOf_PrimOp IntLeOp = ILIT( 12)
-tagOf_PrimOp WordGtOp = ILIT( 13)
-tagOf_PrimOp WordGeOp = ILIT( 14)
-tagOf_PrimOp WordEqOp = ILIT( 15)
-tagOf_PrimOp WordNeOp = ILIT( 16)
-tagOf_PrimOp WordLtOp = ILIT( 17)
-tagOf_PrimOp WordLeOp = ILIT( 18)
-tagOf_PrimOp AddrGtOp = ILIT( 19)
-tagOf_PrimOp AddrGeOp = ILIT( 20)
-tagOf_PrimOp AddrEqOp = ILIT( 21)
-tagOf_PrimOp AddrNeOp = ILIT( 22)
-tagOf_PrimOp AddrLtOp = ILIT( 23)
-tagOf_PrimOp AddrLeOp = ILIT( 24)
-tagOf_PrimOp FloatGtOp = ILIT( 25)
-tagOf_PrimOp FloatGeOp = ILIT( 26)
-tagOf_PrimOp FloatEqOp = ILIT( 27)
-tagOf_PrimOp FloatNeOp = ILIT( 28)
-tagOf_PrimOp FloatLtOp = ILIT( 29)
-tagOf_PrimOp FloatLeOp = ILIT( 30)
-tagOf_PrimOp DoubleGtOp = ILIT( 31)
-tagOf_PrimOp DoubleGeOp = ILIT( 32)
-tagOf_PrimOp DoubleEqOp = ILIT( 33)
-tagOf_PrimOp DoubleNeOp = ILIT( 34)
-tagOf_PrimOp DoubleLtOp = ILIT( 35)
-tagOf_PrimOp DoubleLeOp = ILIT( 36)
-tagOf_PrimOp OrdOp = ILIT( 37)
-tagOf_PrimOp ChrOp = ILIT( 38)
-tagOf_PrimOp IntAddOp = ILIT( 39)
-tagOf_PrimOp IntSubOp = ILIT( 40)
-tagOf_PrimOp IntMulOp = ILIT( 41)
-tagOf_PrimOp IntQuotOp = ILIT( 42)
-tagOf_PrimOp IntRemOp = ILIT( 43)
-tagOf_PrimOp IntNegOp = ILIT( 44)
-tagOf_PrimOp IntAbsOp = ILIT( 45)
-tagOf_PrimOp WordQuotOp = ILIT( 46)
-tagOf_PrimOp WordRemOp = ILIT( 47)
-tagOf_PrimOp AndOp = ILIT( 48)
-tagOf_PrimOp OrOp = ILIT( 49)
-tagOf_PrimOp NotOp = ILIT( 50)
-tagOf_PrimOp XorOp = ILIT( 51)
-tagOf_PrimOp SllOp = ILIT( 52)
-tagOf_PrimOp SrlOp = ILIT( 53)
-tagOf_PrimOp ISllOp = ILIT( 54)
-tagOf_PrimOp ISraOp = ILIT( 55)
-tagOf_PrimOp ISrlOp = ILIT( 56)
-tagOf_PrimOp IntAddCOp = ILIT( 57)
-tagOf_PrimOp IntSubCOp = ILIT( 58)
-tagOf_PrimOp IntMulCOp = ILIT( 59)
-tagOf_PrimOp Int2WordOp = ILIT( 60)
-tagOf_PrimOp Word2IntOp = ILIT( 61)
-tagOf_PrimOp Int2AddrOp = ILIT( 62)
-tagOf_PrimOp Addr2IntOp = ILIT( 63)
-
-tagOf_PrimOp FloatAddOp = ILIT( 64)
-tagOf_PrimOp FloatSubOp = ILIT( 65)
-tagOf_PrimOp FloatMulOp = ILIT( 66)
-tagOf_PrimOp FloatDivOp = ILIT( 67)
-tagOf_PrimOp FloatNegOp = ILIT( 68)
-tagOf_PrimOp Float2IntOp = ILIT( 69)
-tagOf_PrimOp Int2FloatOp = ILIT( 70)
-tagOf_PrimOp FloatExpOp = ILIT( 71)
-tagOf_PrimOp FloatLogOp = ILIT( 72)
-tagOf_PrimOp FloatSqrtOp = ILIT( 73)
-tagOf_PrimOp FloatSinOp = ILIT( 74)
-tagOf_PrimOp FloatCosOp = ILIT( 75)
-tagOf_PrimOp FloatTanOp = ILIT( 76)
-tagOf_PrimOp FloatAsinOp = ILIT( 77)
-tagOf_PrimOp FloatAcosOp = ILIT( 78)
-tagOf_PrimOp FloatAtanOp = ILIT( 79)
-tagOf_PrimOp FloatSinhOp = ILIT( 80)
-tagOf_PrimOp FloatCoshOp = ILIT( 81)
-tagOf_PrimOp FloatTanhOp = ILIT( 82)
-tagOf_PrimOp FloatPowerOp = ILIT( 83)
-
-tagOf_PrimOp DoubleAddOp = ILIT( 84)
-tagOf_PrimOp DoubleSubOp = ILIT( 85)
-tagOf_PrimOp DoubleMulOp = ILIT( 86)
-tagOf_PrimOp DoubleDivOp = ILIT( 87)
-tagOf_PrimOp DoubleNegOp = ILIT( 88)
-tagOf_PrimOp Double2IntOp = ILIT( 89)
-tagOf_PrimOp Int2DoubleOp = ILIT( 90)
-tagOf_PrimOp Double2FloatOp = ILIT( 91)
-tagOf_PrimOp Float2DoubleOp = ILIT( 92)
-tagOf_PrimOp DoubleExpOp = ILIT( 93)
-tagOf_PrimOp DoubleLogOp = ILIT( 94)
-tagOf_PrimOp DoubleSqrtOp = ILIT( 95)
-tagOf_PrimOp DoubleSinOp = ILIT( 96)
-tagOf_PrimOp DoubleCosOp = ILIT( 97)
-tagOf_PrimOp DoubleTanOp = ILIT( 98)
-tagOf_PrimOp DoubleAsinOp = ILIT( 99)
-tagOf_PrimOp DoubleAcosOp = ILIT(100)
-tagOf_PrimOp DoubleAtanOp = ILIT(101)
-tagOf_PrimOp DoubleSinhOp = ILIT(102)
-tagOf_PrimOp DoubleCoshOp = ILIT(103)
-tagOf_PrimOp DoubleTanhOp = ILIT(104)
-tagOf_PrimOp DoublePowerOp = ILIT(105)
-
-tagOf_PrimOp IntegerAddOp = ILIT(106)
-tagOf_PrimOp IntegerSubOp = ILIT(107)
-tagOf_PrimOp IntegerMulOp = ILIT(108)
-tagOf_PrimOp IntegerGcdOp = ILIT(109)
-tagOf_PrimOp IntegerQuotRemOp = ILIT(110)
-tagOf_PrimOp IntegerDivModOp = ILIT(111)
-tagOf_PrimOp IntegerNegOp = ILIT(112)
-tagOf_PrimOp IntegerCmpOp = ILIT(113)
-tagOf_PrimOp IntegerCmpIntOp = ILIT(114)
-tagOf_PrimOp Integer2IntOp = ILIT(115)
-tagOf_PrimOp Integer2WordOp = ILIT(116)
-tagOf_PrimOp Int2IntegerOp = ILIT(117)
-tagOf_PrimOp Word2IntegerOp = ILIT(118)
-tagOf_PrimOp Addr2IntegerOp = ILIT(119)
-tagOf_PrimOp IntegerToInt64Op = ILIT(120)
-tagOf_PrimOp Int64ToIntegerOp = ILIT(121)
-tagOf_PrimOp IntegerToWord64Op = ILIT(122)
-tagOf_PrimOp Word64ToIntegerOp = ILIT(123)
-tagOf_PrimOp FloatDecodeOp = ILIT(125)
-tagOf_PrimOp DoubleDecodeOp = ILIT(127)
-
-tagOf_PrimOp NewArrayOp = ILIT(128)
-tagOf_PrimOp (NewByteArrayOp CharRep) = ILIT(129)
-tagOf_PrimOp (NewByteArrayOp IntRep) = ILIT(130)
-tagOf_PrimOp (NewByteArrayOp WordRep) = ILIT(131)
-tagOf_PrimOp (NewByteArrayOp AddrRep) = ILIT(132)
-tagOf_PrimOp (NewByteArrayOp FloatRep) = ILIT(133)
-tagOf_PrimOp (NewByteArrayOp DoubleRep) = ILIT(134)
-tagOf_PrimOp (NewByteArrayOp StablePtrRep) = ILIT(135)
-
-tagOf_PrimOp SameMutableArrayOp = ILIT(136)
-tagOf_PrimOp SameMutableByteArrayOp = ILIT(137)
-tagOf_PrimOp ReadArrayOp = ILIT(138)
-tagOf_PrimOp WriteArrayOp = ILIT(139)
-tagOf_PrimOp IndexArrayOp = ILIT(140)
-
-tagOf_PrimOp (ReadByteArrayOp CharRep) = ILIT(141)
-tagOf_PrimOp (ReadByteArrayOp IntRep) = ILIT(142)
-tagOf_PrimOp (ReadByteArrayOp WordRep) = ILIT(143)
-tagOf_PrimOp (ReadByteArrayOp AddrRep) = ILIT(144)
-tagOf_PrimOp (ReadByteArrayOp FloatRep) = ILIT(145)
-tagOf_PrimOp (ReadByteArrayOp DoubleRep) = ILIT(146)
-tagOf_PrimOp (ReadByteArrayOp StablePtrRep) = ILIT(147)
-tagOf_PrimOp (ReadByteArrayOp Int64Rep) = ILIT(148)
-tagOf_PrimOp (ReadByteArrayOp Word64Rep) = ILIT(149)
-
-tagOf_PrimOp (WriteByteArrayOp CharRep) = ILIT(150)
-tagOf_PrimOp (WriteByteArrayOp IntRep) = ILIT(151)
-tagOf_PrimOp (WriteByteArrayOp WordRep) = ILIT(152)
-tagOf_PrimOp (WriteByteArrayOp AddrRep) = ILIT(153)
-tagOf_PrimOp (WriteByteArrayOp FloatRep) = ILIT(154)
-tagOf_PrimOp (WriteByteArrayOp DoubleRep) = ILIT(155)
-tagOf_PrimOp (WriteByteArrayOp StablePtrRep) = ILIT(156)
-tagOf_PrimOp (WriteByteArrayOp Int64Rep) = ILIT(157)
-tagOf_PrimOp (WriteByteArrayOp Word64Rep) = ILIT(158)
-
-tagOf_PrimOp (IndexByteArrayOp CharRep) = ILIT(159)
-tagOf_PrimOp (IndexByteArrayOp IntRep) = ILIT(160)
-tagOf_PrimOp (IndexByteArrayOp WordRep) = ILIT(161)
-tagOf_PrimOp (IndexByteArrayOp AddrRep) = ILIT(162)
-tagOf_PrimOp (IndexByteArrayOp FloatRep) = ILIT(163)
-tagOf_PrimOp (IndexByteArrayOp DoubleRep) = ILIT(164)
-tagOf_PrimOp (IndexByteArrayOp StablePtrRep) = ILIT(165)
-tagOf_PrimOp (IndexByteArrayOp Int64Rep) = ILIT(166)
-tagOf_PrimOp (IndexByteArrayOp Word64Rep) = ILIT(167)
-
-tagOf_PrimOp (IndexOffAddrOp CharRep) = ILIT(168)
-tagOf_PrimOp (IndexOffAddrOp IntRep) = ILIT(169)
-tagOf_PrimOp (IndexOffAddrOp WordRep) = ILIT(170)
-tagOf_PrimOp (IndexOffAddrOp AddrRep) = ILIT(171)
-tagOf_PrimOp (IndexOffAddrOp FloatRep) = ILIT(172)
-tagOf_PrimOp (IndexOffAddrOp DoubleRep) = ILIT(173)
-tagOf_PrimOp (IndexOffAddrOp StablePtrRep) = ILIT(174)
-tagOf_PrimOp (IndexOffAddrOp Int64Rep) = ILIT(175)
-tagOf_PrimOp (IndexOffAddrOp Word64Rep) = ILIT(176)
-
-tagOf_PrimOp (IndexOffForeignObjOp CharRep) = ILIT(177)
-tagOf_PrimOp (IndexOffForeignObjOp IntRep) = ILIT(178)
-tagOf_PrimOp (IndexOffForeignObjOp WordRep) = ILIT(179)
-tagOf_PrimOp (IndexOffForeignObjOp AddrRep) = ILIT(180)
-tagOf_PrimOp (IndexOffForeignObjOp FloatRep) = ILIT(181)
-tagOf_PrimOp (IndexOffForeignObjOp DoubleRep) = ILIT(182)
-tagOf_PrimOp (IndexOffForeignObjOp StablePtrRep) = ILIT(183)
-tagOf_PrimOp (IndexOffForeignObjOp Int64Rep) = ILIT(184)
-tagOf_PrimOp (IndexOffForeignObjOp Word64Rep) = ILIT(185)
-
-tagOf_PrimOp (WriteOffAddrOp CharRep) = ILIT(186)
-tagOf_PrimOp (WriteOffAddrOp IntRep) = ILIT(187)
-tagOf_PrimOp (WriteOffAddrOp WordRep) = ILIT(188)
-tagOf_PrimOp (WriteOffAddrOp AddrRep) = ILIT(189)
-tagOf_PrimOp (WriteOffAddrOp FloatRep) = ILIT(190)
-tagOf_PrimOp (WriteOffAddrOp DoubleRep) = ILIT(191)
-tagOf_PrimOp (WriteOffAddrOp StablePtrRep) = ILIT(192)
-tagOf_PrimOp (WriteOffAddrOp ForeignObjRep) = ILIT(193)
-tagOf_PrimOp (WriteOffAddrOp Int64Rep) = ILIT(194)
-tagOf_PrimOp (WriteOffAddrOp Word64Rep) = ILIT(195)
-
-tagOf_PrimOp UnsafeFreezeArrayOp = ILIT(196)
-tagOf_PrimOp UnsafeFreezeByteArrayOp = ILIT(197)
-tagOf_PrimOp UnsafeThawArrayOp = ILIT(198)
-tagOf_PrimOp UnsafeThawByteArrayOp = ILIT(199)
-tagOf_PrimOp SizeofByteArrayOp = ILIT(200)
-tagOf_PrimOp SizeofMutableByteArrayOp = ILIT(201)
-
-tagOf_PrimOp NewMVarOp = ILIT(202)
-tagOf_PrimOp TakeMVarOp = ILIT(203)
-tagOf_PrimOp PutMVarOp = ILIT(204)
-tagOf_PrimOp SameMVarOp = ILIT(205)
-tagOf_PrimOp IsEmptyMVarOp = ILIT(206)
-tagOf_PrimOp MakeForeignObjOp = ILIT(207)
-tagOf_PrimOp WriteForeignObjOp = ILIT(208)
-tagOf_PrimOp MkWeakOp = ILIT(209)
-tagOf_PrimOp DeRefWeakOp = ILIT(210)
-tagOf_PrimOp FinalizeWeakOp = ILIT(211)
-tagOf_PrimOp MakeStableNameOp = ILIT(212)
-tagOf_PrimOp EqStableNameOp = ILIT(213)
-tagOf_PrimOp StableNameToIntOp = ILIT(214)
-tagOf_PrimOp MakeStablePtrOp = ILIT(215)
-tagOf_PrimOp DeRefStablePtrOp = ILIT(216)
-tagOf_PrimOp EqStablePtrOp = ILIT(217)
-tagOf_PrimOp (CCallOp _ _ _ _) = ILIT(218)
-tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(219)
-tagOf_PrimOp SeqOp = ILIT(220)
-tagOf_PrimOp ParOp = ILIT(221)
-tagOf_PrimOp ForkOp = ILIT(222)
-tagOf_PrimOp KillThreadOp = ILIT(223)
-tagOf_PrimOp YieldOp = ILIT(224)
-tagOf_PrimOp MyThreadIdOp = ILIT(225)
-tagOf_PrimOp DelayOp = ILIT(226)
-tagOf_PrimOp WaitReadOp = ILIT(227)
-tagOf_PrimOp WaitWriteOp = ILIT(228)
-tagOf_PrimOp ParGlobalOp = ILIT(229)
-tagOf_PrimOp ParLocalOp = ILIT(230)
-tagOf_PrimOp ParAtOp = ILIT(231)
-tagOf_PrimOp ParAtAbsOp = ILIT(232)
-tagOf_PrimOp ParAtRelOp = ILIT(233)
-tagOf_PrimOp ParAtForNowOp = ILIT(234)
-tagOf_PrimOp CopyableOp = ILIT(235)
-tagOf_PrimOp NoFollowOp = ILIT(236)
-tagOf_PrimOp NewMutVarOp = ILIT(237)
-tagOf_PrimOp ReadMutVarOp = ILIT(238)
-tagOf_PrimOp WriteMutVarOp = ILIT(239)
-tagOf_PrimOp SameMutVarOp = ILIT(240)
-tagOf_PrimOp CatchOp = ILIT(241)
-tagOf_PrimOp RaiseOp = ILIT(242)
-tagOf_PrimOp DataToTagOp = ILIT(243)
-tagOf_PrimOp TagToEnumOp = ILIT(244)
-
-tagOf_PrimOp op = pprPanic# "tagOf_PrimOp: pattern-match" (ppr op)
---panic# "tagOf_PrimOp: pattern-match"
-
-instance Eq PrimOp where
- op1 == op2 = tagOf_PrimOp op1 _EQ_ tagOf_PrimOp op2
-
-instance Ord PrimOp where
- op1 < op2 = tagOf_PrimOp op1 _LT_ tagOf_PrimOp op2
- op1 <= op2 = tagOf_PrimOp op1 _LE_ tagOf_PrimOp op2
- op1 >= op2 = tagOf_PrimOp op1 _GE_ tagOf_PrimOp op2
- op1 > op2 = tagOf_PrimOp op1 _GT_ 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
- = [ CharGtOp,
- CharGeOp,
- CharEqOp,
- CharNeOp,
- CharLtOp,
- CharLeOp,
- IntGtOp,
- IntGeOp,
- IntEqOp,
- IntNeOp,
- IntLtOp,
- IntLeOp,
- WordGtOp,
- WordGeOp,
- WordEqOp,
- WordNeOp,
- WordLtOp,
- WordLeOp,
- AddrGtOp,
- AddrGeOp,
- AddrEqOp,
- AddrNeOp,
- AddrLtOp,
- AddrLeOp,
- FloatGtOp,
- FloatGeOp,
- FloatEqOp,
- FloatNeOp,
- FloatLtOp,
- FloatLeOp,
- DoubleGtOp,
- DoubleGeOp,
- DoubleEqOp,
- DoubleNeOp,
- DoubleLtOp,
- DoubleLeOp,
- OrdOp,
- ChrOp,
- IntAddOp,
- IntSubOp,
- IntMulOp,
- IntQuotOp,
- IntRemOp,
- IntNegOp,
- WordQuotOp,
- WordRemOp,
- AndOp,
- OrOp,
- NotOp,
- XorOp,
- SllOp,
- SrlOp,
- ISllOp,
- ISraOp,
- ISrlOp,
- IntAddCOp,
- IntSubCOp,
- IntMulCOp,
- Int2WordOp,
- Word2IntOp,
- Int2AddrOp,
- Addr2IntOp,
-
- FloatAddOp,
- FloatSubOp,
- FloatMulOp,
- FloatDivOp,
- FloatNegOp,
- Float2IntOp,
- Int2FloatOp,
- FloatExpOp,
- FloatLogOp,
- FloatSqrtOp,
- FloatSinOp,
- FloatCosOp,
- FloatTanOp,
- FloatAsinOp,
- FloatAcosOp,
- FloatAtanOp,
- FloatSinhOp,
- FloatCoshOp,
- FloatTanhOp,
- FloatPowerOp,
- DoubleAddOp,
- DoubleSubOp,
- DoubleMulOp,
- DoubleDivOp,
- DoubleNegOp,
- Double2IntOp,
- Int2DoubleOp,
- Double2FloatOp,
- Float2DoubleOp,
- DoubleExpOp,
- DoubleLogOp,
- DoubleSqrtOp,
- DoubleSinOp,
- DoubleCosOp,
- DoubleTanOp,
- DoubleAsinOp,
- DoubleAcosOp,
- DoubleAtanOp,
- DoubleSinhOp,
- DoubleCoshOp,
- DoubleTanhOp,
- DoublePowerOp,
- IntegerAddOp,
- IntegerSubOp,
- IntegerMulOp,
- IntegerGcdOp,
- IntegerQuotRemOp,
- IntegerDivModOp,
- IntegerNegOp,
- IntegerCmpOp,
- IntegerCmpIntOp,
- Integer2IntOp,
- Integer2WordOp,
- Int2IntegerOp,
- Word2IntegerOp,
- Addr2IntegerOp,
- IntegerToInt64Op,
- Int64ToIntegerOp,
- IntegerToWord64Op,
- Word64ToIntegerOp,
- FloatDecodeOp,
- DoubleDecodeOp,
- NewArrayOp,
- NewByteArrayOp CharRep,
- NewByteArrayOp IntRep,
- NewByteArrayOp WordRep,
- NewByteArrayOp AddrRep,
- NewByteArrayOp FloatRep,
- NewByteArrayOp DoubleRep,
- NewByteArrayOp StablePtrRep,
- SameMutableArrayOp,
- SameMutableByteArrayOp,
- ReadArrayOp,
- WriteArrayOp,
- IndexArrayOp,
- ReadByteArrayOp CharRep,
- ReadByteArrayOp IntRep,
- ReadByteArrayOp WordRep,
- ReadByteArrayOp AddrRep,
- ReadByteArrayOp FloatRep,
- ReadByteArrayOp DoubleRep,
- ReadByteArrayOp StablePtrRep,
- ReadByteArrayOp Int64Rep,
- ReadByteArrayOp Word64Rep,
- WriteByteArrayOp CharRep,
- WriteByteArrayOp IntRep,
- WriteByteArrayOp WordRep,
- WriteByteArrayOp AddrRep,
- WriteByteArrayOp FloatRep,
- WriteByteArrayOp DoubleRep,
- WriteByteArrayOp StablePtrRep,
- WriteByteArrayOp Int64Rep,
- WriteByteArrayOp Word64Rep,
- IndexByteArrayOp CharRep,
- IndexByteArrayOp IntRep,
- IndexByteArrayOp WordRep,
- IndexByteArrayOp AddrRep,
- IndexByteArrayOp FloatRep,
- IndexByteArrayOp DoubleRep,
- IndexByteArrayOp StablePtrRep,
- IndexByteArrayOp Int64Rep,
- IndexByteArrayOp Word64Rep,
- IndexOffForeignObjOp CharRep,
- IndexOffForeignObjOp AddrRep,
- IndexOffForeignObjOp IntRep,
- IndexOffForeignObjOp WordRep,
- IndexOffForeignObjOp FloatRep,
- IndexOffForeignObjOp DoubleRep,
- IndexOffForeignObjOp StablePtrRep,
- IndexOffForeignObjOp Int64Rep,
- IndexOffForeignObjOp Word64Rep,
- IndexOffAddrOp CharRep,
- IndexOffAddrOp IntRep,
- IndexOffAddrOp WordRep,
- IndexOffAddrOp AddrRep,
- IndexOffAddrOp FloatRep,
- IndexOffAddrOp DoubleRep,
- IndexOffAddrOp StablePtrRep,
- IndexOffAddrOp Int64Rep,
- IndexOffAddrOp Word64Rep,
- WriteOffAddrOp CharRep,
- WriteOffAddrOp IntRep,
- WriteOffAddrOp WordRep,
- WriteOffAddrOp AddrRep,
- WriteOffAddrOp FloatRep,
- WriteOffAddrOp DoubleRep,
- WriteOffAddrOp ForeignObjRep,
- WriteOffAddrOp StablePtrRep,
- WriteOffAddrOp Int64Rep,
- WriteOffAddrOp Word64Rep,
- UnsafeFreezeArrayOp,
- UnsafeFreezeByteArrayOp,
- UnsafeThawArrayOp,
- UnsafeThawByteArrayOp,
- SizeofByteArrayOp,
- SizeofMutableByteArrayOp,
- NewMutVarOp,
- ReadMutVarOp,
- WriteMutVarOp,
- SameMutVarOp,
- CatchOp,
- RaiseOp,
- NewMVarOp,
- TakeMVarOp,
- PutMVarOp,
- SameMVarOp,
- IsEmptyMVarOp,
- MakeForeignObjOp,
- WriteForeignObjOp,
- MkWeakOp,
- DeRefWeakOp,
- FinalizeWeakOp,
- MakeStableNameOp,
- EqStableNameOp,
- StableNameToIntOp,
- MakeStablePtrOp,
- DeRefStablePtrOp,
- EqStablePtrOp,
- ReallyUnsafePtrEqualityOp,
- ParGlobalOp,
- ParLocalOp,
- ParAtOp,
- ParAtAbsOp,
- ParAtRelOp,
- ParAtForNowOp,
- CopyableOp,
- NoFollowOp,
- SeqOp,
- ParOp,
- ForkOp,
- KillThreadOp,
- YieldOp,
- MyThreadIdOp,
- DelayOp,
- WaitReadOp,
- WaitWriteOp,
- DataToTagOp,
- TagToEnumOp
- ]
-\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 (mkSrcVarOcc str) ty
-mkMonadic str ty = Monadic (mkSrcVarOcc str) ty
-mkCompare str ty = Compare (mkSrcVarOcc str) ty
-mkGenPrimOp str tvs tys ty = GenPrimOp (mkSrcVarOcc str) tvs tys ty
-\end{code}
-
-Utility bits:
-\begin{code}
-one_Integer_ty = [intPrimTy, byteArrayPrimTy]
-two_Integer_tys
- = [intPrimTy, byteArrayPrimTy, -- first Integer pieces
- intPrimTy, byteArrayPrimTy] -- second '' pieces
-an_Integer_and_Int_tys
- = [intPrimTy, byteArrayPrimTy, -- Integer
- intPrimTy]
-
-unboxedPair = mkUnboxedTupleTy 2
-unboxedTriple = mkUnboxedTupleTy 3
-unboxedQuadruple = mkUnboxedTupleTy 4
-
-integerMonadic name = mkGenPrimOp name [] one_Integer_ty
- (unboxedPair one_Integer_ty)
-
-integerDyadic name = mkGenPrimOp name [] two_Integer_tys
- (unboxedPair one_Integer_ty)
-
-integerDyadic2Results name = mkGenPrimOp name [] two_Integer_tys
- (unboxedQuadruple two_Integer_tys)
-
-integerCompare name = mkGenPrimOp name [] two_Integer_tys intPrimTy
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Strictness}
-%* *
-%************************************************************************
-
-Not all primops are strict!
-
-\begin{code}
-primOpStrictness :: PrimOp -> ([Demand], Bool)
- -- See IdInfo.StrictnessInfo for discussion of what the results
- -- **NB** as a cheap hack, to avoid having to look up the PrimOp's arity,
- -- the list of demands may be infinite!
- -- Use only the ones you ned.
-
-primOpStrictness SeqOp = ([wwLazy], False)
-primOpStrictness ParOp = ([wwLazy], False)
-primOpStrictness ForkOp = ([wwLazy, wwPrim], False)
-
-primOpStrictness NewArrayOp = ([wwPrim, wwLazy, wwPrim], False)
-primOpStrictness WriteArrayOp = ([wwPrim, wwPrim, wwLazy, wwPrim], False)
-
-primOpStrictness NewMutVarOp = ([wwLazy, wwPrim], False)
-primOpStrictness WriteMutVarOp = ([wwPrim, wwLazy, wwPrim], False)
-
-primOpStrictness PutMVarOp = ([wwPrim, wwLazy, wwPrim], False)
-
-primOpStrictness CatchOp = ([wwLazy, wwLazy], False)
-primOpStrictness RaiseOp = ([wwLazy], True) -- NB: True => result is bottom
-
-primOpStrictness MkWeakOp = ([wwLazy, wwLazy, wwLazy, wwPrim], False)
-primOpStrictness MakeStableNameOp = ([wwLazy, wwPrim], False)
-primOpStrictness MakeStablePtrOp = ([wwLazy, wwPrim], False)
-
-primOpStrictness DataToTagOp = ([wwLazy], False)
-
- -- The rest all have primitive-typed arguments
-primOpStrictness other = (repeat wwPrim, False)
-\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
-\end{code}
-
-There's plenty of this stuff!
-
-\begin{code}
-primOpInfo CharGtOp = mkCompare SLIT("gtChar#") charPrimTy
-primOpInfo CharGeOp = mkCompare SLIT("geChar#") charPrimTy
-primOpInfo CharEqOp = mkCompare SLIT("eqChar#") charPrimTy
-primOpInfo CharNeOp = mkCompare SLIT("neChar#") charPrimTy
-primOpInfo CharLtOp = mkCompare SLIT("ltChar#") charPrimTy
-primOpInfo CharLeOp = mkCompare SLIT("leChar#") charPrimTy
-
-primOpInfo IntGtOp = mkCompare SLIT(">#") intPrimTy
-primOpInfo IntGeOp = mkCompare SLIT(">=#") intPrimTy
-primOpInfo IntEqOp = mkCompare SLIT("==#") intPrimTy
-primOpInfo IntNeOp = mkCompare SLIT("/=#") intPrimTy
-primOpInfo IntLtOp = mkCompare SLIT("<#") intPrimTy
-primOpInfo IntLeOp = mkCompare SLIT("<=#") intPrimTy
-
-primOpInfo WordGtOp = mkCompare SLIT("gtWord#") wordPrimTy
-primOpInfo WordGeOp = mkCompare SLIT("geWord#") wordPrimTy
-primOpInfo WordEqOp = mkCompare SLIT("eqWord#") wordPrimTy
-primOpInfo WordNeOp = mkCompare SLIT("neWord#") wordPrimTy
-primOpInfo WordLtOp = mkCompare SLIT("ltWord#") wordPrimTy
-primOpInfo WordLeOp = mkCompare SLIT("leWord#") wordPrimTy
-
-primOpInfo AddrGtOp = mkCompare SLIT("gtAddr#") addrPrimTy
-primOpInfo AddrGeOp = mkCompare SLIT("geAddr#") addrPrimTy
-primOpInfo AddrEqOp = mkCompare SLIT("eqAddr#") addrPrimTy
-primOpInfo AddrNeOp = mkCompare SLIT("neAddr#") addrPrimTy
-primOpInfo AddrLtOp = mkCompare SLIT("ltAddr#") addrPrimTy
-primOpInfo AddrLeOp = mkCompare SLIT("leAddr#") addrPrimTy
-
-primOpInfo FloatGtOp = mkCompare SLIT("gtFloat#") floatPrimTy
-primOpInfo FloatGeOp = mkCompare SLIT("geFloat#") floatPrimTy
-primOpInfo FloatEqOp = mkCompare SLIT("eqFloat#") floatPrimTy
-primOpInfo FloatNeOp = mkCompare SLIT("neFloat#") floatPrimTy
-primOpInfo FloatLtOp = mkCompare SLIT("ltFloat#") floatPrimTy
-primOpInfo FloatLeOp = mkCompare SLIT("leFloat#") floatPrimTy
-
-primOpInfo DoubleGtOp = mkCompare SLIT(">##") doublePrimTy
-primOpInfo DoubleGeOp = mkCompare SLIT(">=##") doublePrimTy
-primOpInfo DoubleEqOp = mkCompare SLIT("==##") doublePrimTy
-primOpInfo DoubleNeOp = mkCompare SLIT("/=##") doublePrimTy
-primOpInfo DoubleLtOp = mkCompare SLIT("<##") doublePrimTy
-primOpInfo DoubleLeOp = mkCompare SLIT("<=##") doublePrimTy
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[PrimOp-Char]{PrimOpInfo for @Char#@s}
-%* *
-%************************************************************************
-
-\begin{code}
-primOpInfo OrdOp = mkGenPrimOp SLIT("ord#") [] [charPrimTy] intPrimTy
-primOpInfo ChrOp = mkGenPrimOp SLIT("chr#") [] [intPrimTy] charPrimTy
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[PrimOp-Int]{PrimOpInfo for @Int#@s}
-%* *
-%************************************************************************
-
-\begin{code}
-primOpInfo IntAddOp = mkDyadic SLIT("+#") intPrimTy
-primOpInfo IntSubOp = mkDyadic SLIT("-#") intPrimTy
-primOpInfo IntMulOp = mkDyadic SLIT("*#") intPrimTy
-primOpInfo IntQuotOp = mkDyadic SLIT("quotInt#") intPrimTy
-primOpInfo IntRemOp = mkDyadic SLIT("remInt#") intPrimTy
-
-primOpInfo IntNegOp = mkMonadic SLIT("negateInt#") intPrimTy
-primOpInfo IntAbsOp = mkMonadic SLIT("absInt#") intPrimTy
-
-primOpInfo IntAddCOp =
- mkGenPrimOp SLIT("addIntC#") [] [intPrimTy, intPrimTy]
- (unboxedPair [intPrimTy, intPrimTy])
-
-primOpInfo IntSubCOp =
- mkGenPrimOp SLIT("subIntC#") [] [intPrimTy, intPrimTy]
- (unboxedPair [intPrimTy, intPrimTy])
-
-primOpInfo IntMulCOp =
- mkGenPrimOp SLIT("mulIntC#") [] [intPrimTy, intPrimTy]
- (unboxedPair [intPrimTy, intPrimTy])
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[PrimOp-Word]{PrimOpInfo for @Word#@s}
-%* *
-%************************************************************************
-
-A @Word#@ is an unsigned @Int#@.
-
-\begin{code}
-primOpInfo WordQuotOp = mkDyadic SLIT("quotWord#") wordPrimTy
-primOpInfo WordRemOp = mkDyadic SLIT("remWord#") wordPrimTy
-
-primOpInfo AndOp = mkDyadic SLIT("and#") wordPrimTy
-primOpInfo OrOp = mkDyadic SLIT("or#") wordPrimTy
-primOpInfo XorOp = mkDyadic SLIT("xor#") wordPrimTy
-primOpInfo NotOp = mkMonadic SLIT("not#") wordPrimTy
-
-primOpInfo SllOp
- = mkGenPrimOp SLIT("shiftL#") [] [wordPrimTy, intPrimTy] wordPrimTy
-primOpInfo SrlOp
- = mkGenPrimOp SLIT("shiftRL#") [] [wordPrimTy, intPrimTy] wordPrimTy
-
-primOpInfo ISllOp
- = mkGenPrimOp SLIT("iShiftL#") [] [intPrimTy, intPrimTy] intPrimTy
-primOpInfo ISraOp
- = mkGenPrimOp SLIT("iShiftRA#") [] [intPrimTy, intPrimTy] intPrimTy
-primOpInfo ISrlOp
- = mkGenPrimOp SLIT("iShiftRL#") [] [intPrimTy, intPrimTy] intPrimTy
-
-primOpInfo Int2WordOp = mkGenPrimOp SLIT("int2Word#") [] [intPrimTy] wordPrimTy
-primOpInfo Word2IntOp = mkGenPrimOp SLIT("word2Int#") [] [wordPrimTy] intPrimTy
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[PrimOp-Addr]{PrimOpInfo for @Addr#@s}
-%* *
-%************************************************************************
-
-\begin{code}
-primOpInfo Int2AddrOp = mkGenPrimOp SLIT("int2Addr#") [] [intPrimTy] addrPrimTy
-primOpInfo Addr2IntOp = mkGenPrimOp SLIT("addr2Int#") [] [addrPrimTy] intPrimTy
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection[PrimOp-Float]{PrimOpInfo for @Float#@s}
-%* *
-%************************************************************************
-
-@decodeFloat#@ is given w/ Integer-stuff (it's similar).
-
-\begin{code}
-primOpInfo FloatAddOp = mkDyadic SLIT("plusFloat#") floatPrimTy
-primOpInfo FloatSubOp = mkDyadic SLIT("minusFloat#") floatPrimTy
-primOpInfo FloatMulOp = mkDyadic SLIT("timesFloat#") floatPrimTy
-primOpInfo FloatDivOp = mkDyadic SLIT("divideFloat#") floatPrimTy
-primOpInfo FloatNegOp = mkMonadic SLIT("negateFloat#") floatPrimTy
-
-primOpInfo Float2IntOp = mkGenPrimOp SLIT("float2Int#") [] [floatPrimTy] intPrimTy
-primOpInfo Int2FloatOp = mkGenPrimOp SLIT("int2Float#") [] [intPrimTy] floatPrimTy
-
-primOpInfo FloatExpOp = mkMonadic SLIT("expFloat#") floatPrimTy
-primOpInfo FloatLogOp = mkMonadic SLIT("logFloat#") floatPrimTy
-primOpInfo FloatSqrtOp = mkMonadic SLIT("sqrtFloat#") floatPrimTy
-primOpInfo FloatSinOp = mkMonadic SLIT("sinFloat#") floatPrimTy
-primOpInfo FloatCosOp = mkMonadic SLIT("cosFloat#") floatPrimTy
-primOpInfo FloatTanOp = mkMonadic SLIT("tanFloat#") floatPrimTy
-primOpInfo FloatAsinOp = mkMonadic SLIT("asinFloat#") floatPrimTy
-primOpInfo FloatAcosOp = mkMonadic SLIT("acosFloat#") floatPrimTy
-primOpInfo FloatAtanOp = mkMonadic SLIT("atanFloat#") floatPrimTy
-primOpInfo FloatSinhOp = mkMonadic SLIT("sinhFloat#") floatPrimTy
-primOpInfo FloatCoshOp = mkMonadic SLIT("coshFloat#") floatPrimTy
-primOpInfo FloatTanhOp = mkMonadic SLIT("tanhFloat#") floatPrimTy
-primOpInfo FloatPowerOp = mkDyadic SLIT("powerFloat#") floatPrimTy
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[PrimOp-Double]{PrimOpInfo for @Double#@s}
-%* *
-%************************************************************************
-
-@decodeDouble#@ is given w/ Integer-stuff (it's similar).
-
-\begin{code}
-primOpInfo DoubleAddOp = mkDyadic SLIT("+##") doublePrimTy
-primOpInfo DoubleSubOp = mkDyadic SLIT("-##") doublePrimTy
-primOpInfo DoubleMulOp = mkDyadic SLIT("*##") doublePrimTy
-primOpInfo DoubleDivOp = mkDyadic SLIT("/##") doublePrimTy
-primOpInfo DoubleNegOp = mkMonadic SLIT("negateDouble#") doublePrimTy
-
-primOpInfo Double2IntOp = mkGenPrimOp SLIT("double2Int#") [] [doublePrimTy] intPrimTy
-primOpInfo Int2DoubleOp = mkGenPrimOp SLIT("int2Double#") [] [intPrimTy] doublePrimTy
-
-primOpInfo Double2FloatOp = mkGenPrimOp SLIT("double2Float#") [] [doublePrimTy] floatPrimTy
-primOpInfo Float2DoubleOp = mkGenPrimOp SLIT("float2Double#") [] [floatPrimTy] doublePrimTy
-
-primOpInfo DoubleExpOp = mkMonadic SLIT("expDouble#") doublePrimTy
-primOpInfo DoubleLogOp = mkMonadic SLIT("logDouble#") doublePrimTy
-primOpInfo DoubleSqrtOp = mkMonadic SLIT("sqrtDouble#") doublePrimTy
-primOpInfo DoubleSinOp = mkMonadic SLIT("sinDouble#") doublePrimTy
-primOpInfo DoubleCosOp = mkMonadic SLIT("cosDouble#") doublePrimTy
-primOpInfo DoubleTanOp = mkMonadic SLIT("tanDouble#") doublePrimTy
-primOpInfo DoubleAsinOp = mkMonadic SLIT("asinDouble#") doublePrimTy
-primOpInfo DoubleAcosOp = mkMonadic SLIT("acosDouble#") doublePrimTy
-primOpInfo DoubleAtanOp = mkMonadic SLIT("atanDouble#") doublePrimTy
-primOpInfo DoubleSinhOp = mkMonadic SLIT("sinhDouble#") doublePrimTy
-primOpInfo DoubleCoshOp = mkMonadic SLIT("coshDouble#") doublePrimTy
-primOpInfo DoubleTanhOp = mkMonadic SLIT("tanhDouble#") doublePrimTy
-primOpInfo DoublePowerOp= mkDyadic SLIT("**##") doublePrimTy
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[PrimOp-Integer]{PrimOpInfo for @Integer@ (and related!)}
-%* *
-%************************************************************************
-
-\begin{code}
-primOpInfo IntegerNegOp = integerMonadic SLIT("negateInteger#")
-
-primOpInfo IntegerAddOp = integerDyadic SLIT("plusInteger#")
-primOpInfo IntegerSubOp = integerDyadic SLIT("minusInteger#")
-primOpInfo IntegerMulOp = integerDyadic SLIT("timesInteger#")
-primOpInfo IntegerGcdOp = integerDyadic SLIT("gcdInteger#")
-
-primOpInfo IntegerCmpOp = integerCompare SLIT("cmpInteger#")
-primOpInfo IntegerCmpIntOp
- = mkGenPrimOp SLIT("cmpIntegerInt#") [] an_Integer_and_Int_tys intPrimTy
-
-primOpInfo IntegerQuotRemOp = integerDyadic2Results SLIT("quotRemInteger#")
-primOpInfo IntegerDivModOp = integerDyadic2Results SLIT("divModInteger#")
-
-primOpInfo Integer2IntOp
- = mkGenPrimOp SLIT("integer2Int#") [] one_Integer_ty intPrimTy
-
-primOpInfo Integer2WordOp
- = mkGenPrimOp SLIT("integer2Word#") [] one_Integer_ty wordPrimTy
-
-primOpInfo Int2IntegerOp
- = mkGenPrimOp SLIT("int2Integer#") [] [intPrimTy]
- (unboxedPair one_Integer_ty)
-
-primOpInfo Word2IntegerOp
- = mkGenPrimOp SLIT("word2Integer#") [] [wordPrimTy]
- (unboxedPair one_Integer_ty)
-
-primOpInfo Addr2IntegerOp
- = mkGenPrimOp SLIT("addr2Integer#") [] [addrPrimTy]
- (unboxedPair one_Integer_ty)
-
-primOpInfo IntegerToInt64Op
- = mkGenPrimOp SLIT("integerToInt64#") [] one_Integer_ty int64PrimTy
-
-primOpInfo Int64ToIntegerOp
- = mkGenPrimOp SLIT("int64ToInteger#") [] [int64PrimTy]
- (unboxedPair one_Integer_ty)
-
-primOpInfo Word64ToIntegerOp
- = mkGenPrimOp SLIT("word64ToInteger#") [] [word64PrimTy]
- (unboxedPair one_Integer_ty)
-
-primOpInfo IntegerToWord64Op
- = mkGenPrimOp SLIT("integerToWord64#") [] one_Integer_ty word64PrimTy
-\end{code}
-
-Decoding of floating-point numbers is sorta Integer-related. Encoding
-is done with plain ccalls now (see PrelNumExtra.lhs).
-
-\begin{code}
-primOpInfo FloatDecodeOp
- = mkGenPrimOp SLIT("decodeFloat#") [] [floatPrimTy]
- (unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy])
-primOpInfo DoubleDecodeOp
- = mkGenPrimOp SLIT("decodeDouble#") [] [doublePrimTy]
- (unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy])
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[PrimOp-Arrays]{PrimOpInfo for primitive arrays}
-%* *
-%************************************************************************
-
-\begin{verbatim}
-newArray# :: Int# -> a -> State# s -> (# State# s, MutArr# s a #)
-newFooArray# :: Int# -> State# s -> (# State# s, MutByteArr# s #)
-\end{verbatim}
-
-\begin{code}
-primOpInfo NewArrayOp
- = let {
- elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
- state = mkStatePrimTy s
- } in
- mkGenPrimOp SLIT("newArray#") [s_tv, elt_tv]
- [intPrimTy, elt, state]
- (unboxedPair [state, mkMutableArrayPrimTy s elt])
-
-primOpInfo (NewByteArrayOp kind)
- = let
- s = alphaTy; s_tv = alphaTyVar
-
- op_str = _PK_ ("new" ++ primRepString kind ++ "Array#")
- state = mkStatePrimTy s
- in
- mkGenPrimOp op_str [s_tv]
- [intPrimTy, state]
- (unboxedPair [state, mkMutableByteArrayPrimTy s])
-
----------------------------------------------------------------------------
-
-{-
-sameMutableArray# :: MutArr# s a -> MutArr# s a -> Bool
-sameMutableByteArray# :: MutByteArr# s -> MutByteArr# s -> Bool
--}
-
-primOpInfo SameMutableArrayOp
- = let {
- elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
- mut_arr_ty = mkMutableArrayPrimTy s elt
- } in
- mkGenPrimOp SLIT("sameMutableArray#") [s_tv, elt_tv] [mut_arr_ty, mut_arr_ty]
- boolTy
-
-primOpInfo SameMutableByteArrayOp
- = let {
- s = alphaTy; s_tv = alphaTyVar;
- mut_arr_ty = mkMutableByteArrayPrimTy s
- } in
- mkGenPrimOp SLIT("sameMutableByteArray#") [s_tv] [mut_arr_ty, mut_arr_ty]
- boolTy
-
----------------------------------------------------------------------------
--- Primitive arrays of Haskell pointers:
-
-{-
-readArray# :: MutArr# s a -> Int# -> State# s -> (# State# s, a #)
-writeArray# :: MutArr# s a -> Int# -> a -> State# s -> State# s
-indexArray# :: Array# a -> Int# -> (# a #)
--}
-
-primOpInfo ReadArrayOp
- = let {
- elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
- state = mkStatePrimTy s
- } in
- mkGenPrimOp SLIT("readArray#") [s_tv, elt_tv]
- [mkMutableArrayPrimTy s elt, intPrimTy, state]
- (unboxedPair [state, elt])
-
-
-primOpInfo WriteArrayOp
- = let {
- elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
- } in
- mkGenPrimOp SLIT("writeArray#") [s_tv, elt_tv]
- [mkMutableArrayPrimTy s elt, intPrimTy, elt, mkStatePrimTy s]
- (mkStatePrimTy s)
-
-primOpInfo IndexArrayOp
- = let { elt = alphaTy; elt_tv = alphaTyVar } in
- mkGenPrimOp SLIT("indexArray#") [elt_tv] [mkArrayPrimTy elt, intPrimTy]
- (mkUnboxedTupleTy 1 [elt])
-
----------------------------------------------------------------------------
--- Primitive arrays full of unboxed bytes:
-
-primOpInfo (ReadByteArrayOp kind)
- = let
- s = alphaTy; s_tv = alphaTyVar
-
- op_str = _PK_ ("read" ++ primRepString kind ++ "Array#")
- (tvs, prim_ty) = mkPrimTyApp betaTyVars kind
- state = mkStatePrimTy s
- in
- mkGenPrimOp op_str (s_tv:tvs)
- [mkMutableByteArrayPrimTy s, intPrimTy, state]
- (unboxedPair [state, prim_ty])
-
-primOpInfo (WriteByteArrayOp kind)
- = let
- s = alphaTy; s_tv = alphaTyVar
- op_str = _PK_ ("write" ++ primRepString kind ++ "Array#")
- (tvs, prim_ty) = mkPrimTyApp betaTyVars kind
- in
- mkGenPrimOp op_str (s_tv:tvs)
- [mkMutableByteArrayPrimTy s, intPrimTy, prim_ty, mkStatePrimTy s]
- (mkStatePrimTy s)
-
-primOpInfo (IndexByteArrayOp kind)
- = let
- op_str = _PK_ ("index" ++ primRepString kind ++ "Array#")
- (tvs, prim_ty) = mkPrimTyApp alphaTyVars kind
- in
- mkGenPrimOp op_str tvs [byteArrayPrimTy, intPrimTy] prim_ty
-
-primOpInfo (IndexOffForeignObjOp kind)
- = let
- op_str = _PK_ ("index" ++ primRepString kind ++ "OffForeignObj#")
- (tvs, prim_ty) = mkPrimTyApp alphaTyVars kind
- in
- mkGenPrimOp op_str tvs [foreignObjPrimTy, intPrimTy] prim_ty
-
-primOpInfo (IndexOffAddrOp kind)
- = let
- op_str = _PK_ ("index" ++ primRepString kind ++ "OffAddr#")
- (tvs, prim_ty) = mkPrimTyApp alphaTyVars kind
- in
- mkGenPrimOp op_str tvs [addrPrimTy, intPrimTy] prim_ty
-
-primOpInfo (WriteOffAddrOp kind)
- = let
- s = alphaTy; s_tv = alphaTyVar
- op_str = _PK_ ("write" ++ primRepString kind ++ "OffAddr#")
- (tvs, prim_ty) = mkPrimTyApp betaTyVars kind
- in
- mkGenPrimOp op_str (s_tv:tvs)
- [addrPrimTy, intPrimTy, prim_ty, mkStatePrimTy s]
- (mkStatePrimTy s)
-
----------------------------------------------------------------------------
-{-
-unsafeFreezeArray# :: MutArr# s a -> State# s -> (# State# s, Array# a #)
-unsafeFreezeByteArray# :: MutByteArr# s -> State# s -> (# State# s, ByteArray# #)
-unsafeThawArray# :: Array# a -> State# s -> (# State# s, MutArr# s a #)
-unsafeThawByteArray# :: ByteArray# -> State# s -> (# State# s, MutByteArr# s #)
--}
-
-primOpInfo UnsafeFreezeArrayOp
- = let {
- elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
- state = mkStatePrimTy s
- } in
- mkGenPrimOp SLIT("unsafeFreezeArray#") [s_tv, elt_tv]
- [mkMutableArrayPrimTy s elt, state]
- (unboxedPair [state, mkArrayPrimTy elt])
-
-primOpInfo UnsafeFreezeByteArrayOp
- = let {
- s = alphaTy; s_tv = alphaTyVar;
- state = mkStatePrimTy s
- } in
- mkGenPrimOp SLIT("unsafeFreezeByteArray#") [s_tv]
- [mkMutableByteArrayPrimTy s, state]
- (unboxedPair [state, byteArrayPrimTy])
-
-primOpInfo UnsafeThawArrayOp
- = let {
- elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
- state = mkStatePrimTy s
- } in
- mkGenPrimOp SLIT("unsafeThawArray#") [s_tv, elt_tv]
- [mkArrayPrimTy elt, state]
- (unboxedPair [state, mkMutableArrayPrimTy s elt])
-
-primOpInfo UnsafeThawByteArrayOp
- = let {
- s = alphaTy; s_tv = alphaTyVar;
- state = mkStatePrimTy s
- } in
- mkGenPrimOp SLIT("unsafeThawByteArray#") [s_tv]
- [byteArrayPrimTy, state]
- (unboxedPair [state, mkMutableByteArrayPrimTy s])
-
----------------------------------------------------------------------------
-primOpInfo SizeofByteArrayOp
- = mkGenPrimOp
- SLIT("sizeofByteArray#") []
- [byteArrayPrimTy]
- intPrimTy
-
-primOpInfo SizeofMutableByteArrayOp
- = let { s = alphaTy; s_tv = alphaTyVar } in
- mkGenPrimOp
- SLIT("sizeofMutableByteArray#") [s_tv]
- [mkMutableByteArrayPrimTy s]
- intPrimTy
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection[PrimOp-MutVars]{PrimOpInfo for mutable variable ops}
-%* *
-%************************************************************************
-
-\begin{code}
-primOpInfo NewMutVarOp
- = let {
- elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
- state = mkStatePrimTy s
- } in
- mkGenPrimOp SLIT("newMutVar#") [s_tv, elt_tv]
- [elt, state]
- (unboxedPair [state, mkMutVarPrimTy s elt])
-
-primOpInfo ReadMutVarOp
- = let {
- elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
- state = mkStatePrimTy s
- } in
- mkGenPrimOp SLIT("readMutVar#") [s_tv, elt_tv]
- [mkMutVarPrimTy s elt, state]
- (unboxedPair [state, elt])
-
-
-primOpInfo WriteMutVarOp
- = let {
- elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
- } in
- mkGenPrimOp SLIT("writeMutVar#") [s_tv, elt_tv]
- [mkMutVarPrimTy s elt, elt, mkStatePrimTy s]
- (mkStatePrimTy s)
-
-primOpInfo SameMutVarOp
- = let {
- elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;
- mut_var_ty = mkMutVarPrimTy s elt
- } in
- mkGenPrimOp SLIT("sameMutVar#") [s_tv, elt_tv] [mut_var_ty, mut_var_ty]
- boolTy
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[PrimOp-Exceptions]{PrimOpInfo for exceptions}
-%* *
-%************************************************************************
-
-catch :: IO a -> (IOError -> IO a) -> IO a
-catch# :: a -> (b -> a) -> a
-
-\begin{code}
-primOpInfo CatchOp
- = let
- a = alphaTy; a_tv = alphaTyVar
- b = betaTy; b_tv = betaTyVar;
- in
- mkGenPrimOp SLIT("catch#") [a_tv, b_tv] [a, mkFunTy b a] a
-
-primOpInfo RaiseOp
- = let
- a = alphaTy; a_tv = alphaTyVar
- b = betaTy; b_tv = betaTyVar;
- in
- mkGenPrimOp SLIT("raise#") [a_tv, b_tv] [a] b
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[PrimOp-MVars]{PrimOpInfo for synchronizing Variables}
-%* *
-%************************************************************************
-
-\begin{code}
-primOpInfo NewMVarOp
- = let
- elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
- state = mkStatePrimTy s
- in
- mkGenPrimOp SLIT("newMVar#") [s_tv, elt_tv] [state]
- (unboxedPair [state, mkMVarPrimTy s elt])
-
-primOpInfo TakeMVarOp
- = let
- elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
- state = mkStatePrimTy s
- in
- mkGenPrimOp SLIT("takeMVar#") [s_tv, elt_tv]
- [mkMVarPrimTy s elt, state]
- (unboxedPair [state, elt])
-
-primOpInfo PutMVarOp
- = let
- elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
- in
- mkGenPrimOp SLIT("putMVar#") [s_tv, elt_tv]
- [mkMVarPrimTy s elt, elt, mkStatePrimTy s]
- (mkStatePrimTy s)
-
-primOpInfo SameMVarOp
- = let
- elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
- mvar_ty = mkMVarPrimTy s elt
- in
- mkGenPrimOp SLIT("sameMVar#") [s_tv, elt_tv] [mvar_ty, mvar_ty] boolTy
-
-primOpInfo IsEmptyMVarOp
- = let
- elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar
- state = mkStatePrimTy s
- in
- mkGenPrimOp SLIT("isEmptyMVar#") [s_tv, elt_tv]
- [mkMVarPrimTy s elt, mkStatePrimTy s]
- (unboxedPair [state, intPrimTy])
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[PrimOp-Wait]{PrimOpInfo for delay/wait operations}
-%* *
-%************************************************************************
-
-\begin{code}
-
-primOpInfo DelayOp
- = let {
- s = alphaTy; s_tv = alphaTyVar
- } in
- mkGenPrimOp SLIT("delay#") [s_tv]
- [intPrimTy, mkStatePrimTy s] (mkStatePrimTy s)
-
-primOpInfo WaitReadOp
- = let {
- s = alphaTy; s_tv = alphaTyVar
- } in
- mkGenPrimOp SLIT("waitRead#") [s_tv]
- [intPrimTy, mkStatePrimTy s] (mkStatePrimTy s)
-
-primOpInfo WaitWriteOp
- = let {
- s = alphaTy; s_tv = alphaTyVar
- } in
- mkGenPrimOp SLIT("waitWrite#") [s_tv]
- [intPrimTy, mkStatePrimTy s] (mkStatePrimTy s)
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[PrimOp-Concurrency]{Concurrency Primitives}
-%* *
-%************************************************************************
-
-\begin{code}
--- fork# :: a -> State# RealWorld -> (# State# RealWorld, ThreadId# #)
-primOpInfo ForkOp
- = mkGenPrimOp SLIT("fork#") [alphaTyVar]
- [alphaTy, realWorldStatePrimTy]
- (unboxedPair [realWorldStatePrimTy, threadIdPrimTy])
-
--- killThread# :: ThreadId# -> exception -> State# RealWorld -> State# RealWorld
-primOpInfo KillThreadOp
- = mkGenPrimOp SLIT("killThread#") [alphaTyVar]
- [threadIdPrimTy, alphaTy, realWorldStatePrimTy]
- realWorldStatePrimTy
-
--- yield# :: State# RealWorld -> State# RealWorld
-primOpInfo YieldOp
- = mkGenPrimOp SLIT("yield#") []
- [realWorldStatePrimTy]
- realWorldStatePrimTy
-
--- myThreadId# :: State# RealWorld -> (# State# RealWorld, ThreadId# #)
-primOpInfo MyThreadIdOp
- = mkGenPrimOp SLIT("myThreadId#") []
- [realWorldStatePrimTy]
- (unboxedPair [realWorldStatePrimTy, threadIdPrimTy])
-\end{code}
-
-************************************************************************
-%* *
-\subsubsection[PrimOps-Foreign]{PrimOpInfo for Foreign Objects}
-%* *
-%************************************************************************
-
-\begin{code}
-primOpInfo MakeForeignObjOp
- = mkGenPrimOp SLIT("makeForeignObj#") []
- [addrPrimTy, realWorldStatePrimTy]
- (unboxedPair [realWorldStatePrimTy, foreignObjPrimTy])
-
-primOpInfo WriteForeignObjOp
- = let {
- s = alphaTy; s_tv = alphaTyVar
- } in
- mkGenPrimOp SLIT("writeForeignObj#") [s_tv]
- [foreignObjPrimTy, addrPrimTy, mkStatePrimTy s] (mkStatePrimTy s)
-\end{code}
-
-************************************************************************
-%* *
-\subsubsection[PrimOps-Weak]{PrimOpInfo for Weak Pointers}
-%* *
-%************************************************************************
-
-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)
-
-\begin{code}
-primOpInfo MkWeakOp
- = mkGenPrimOp SLIT("mkWeak#") [alphaTyVar, betaTyVar, gammaTyVar]
- [alphaTy, betaTy, gammaTy, realWorldStatePrimTy]
- (unboxedPair [realWorldStatePrimTy, mkWeakPrimTy betaTy])
-\end{code}
-
-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)
-
-\begin{code}
-primOpInfo DeRefWeakOp
- = mkGenPrimOp SLIT("deRefWeak#") [alphaTyVar]
- [mkWeakPrimTy alphaTy, realWorldStatePrimTy]
- (unboxedTriple [realWorldStatePrimTy, intPrimTy, alphaTy])
-\end{code}
-
-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.
-
-\begin{code}
-primOpInfo FinalizeWeakOp
- = mkGenPrimOp SLIT("finalizeWeak#") [alphaTyVar]
- [mkWeakPrimTy alphaTy, realWorldStatePrimTy]
- (unboxedTriple [realWorldStatePrimTy, intPrimTy,
- mkFunTy realWorldStatePrimTy
- (unboxedPair [realWorldStatePrimTy,unitTy])])
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[PrimOp-stable-pointers]{PrimOpInfo for stable pointers and stable names}
-%* *
-%************************************************************************
-
-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.
-
-\begin{code}
-primOpInfo MakeStablePtrOp
- = mkGenPrimOp SLIT("makeStablePtr#") [alphaTyVar]
- [alphaTy, realWorldStatePrimTy]
- (unboxedPair [realWorldStatePrimTy,
- mkTyConApp stablePtrPrimTyCon [alphaTy]])
-
-primOpInfo DeRefStablePtrOp
- = mkGenPrimOp SLIT("deRefStablePtr#") [alphaTyVar]
- [mkStablePtrPrimTy alphaTy, realWorldStatePrimTy]
- (unboxedPair [realWorldStatePrimTy, alphaTy])
-
-primOpInfo EqStablePtrOp
- = mkGenPrimOp SLIT("eqStablePtr#") [alphaTyVar, betaTyVar]
- [mkStablePtrPrimTy alphaTy, mkStablePtrPrimTy betaTy]
- intPrimTy
-
-primOpInfo MakeStableNameOp
- = mkGenPrimOp SLIT("makeStableName#") [alphaTyVar]
- [alphaTy, realWorldStatePrimTy]
- (unboxedPair [realWorldStatePrimTy,
- mkTyConApp stableNamePrimTyCon [alphaTy]])
-
-primOpInfo EqStableNameOp
- = mkGenPrimOp SLIT("eqStableName#") [alphaTyVar, betaTyVar]
- [mkStableNamePrimTy alphaTy, mkStableNamePrimTy betaTy]
- intPrimTy
-
-primOpInfo StableNameToIntOp
- = mkGenPrimOp SLIT("stableNameToInt#") [alphaTyVar]
- [mkStableNamePrimTy alphaTy]
- intPrimTy
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[PrimOp-unsafePointerEquality]{PrimOpInfo for Pointer Equality}
-%* *
-%************************************************************************
-
-[Alastair Reid is to blame for this!]
-
-These days, (Glasgow) Haskell seems to have a bit of everything from
-other languages: strict operations, mutable variables, sequencing,
-pointers, etc. About the only thing left is LISP's ability to test
-for pointer equality. So, let's add it in!
-
-\begin{verbatim}
-reallyUnsafePtrEquality :: a -> a -> Int#
-\end{verbatim}
-
-which tests any two closures (of the same type) to see if they're the
-same. (Returns $0$ for @False@, $\neq 0$ for @True@ - to avoid
-difficulties of trying to box up the result.)
-
-NB This is {\em really unsafe\/} because even something as trivial as
-a garbage collection might change the answer by removing indirections.
-Still, no-one's forcing you to use it. If you're worried about little
-things like loss of referential transparency, you might like to wrap
-it all up in a monad-like thing as John O'Donnell and John Hughes did
-for non-determinism (1989 (Fraserburgh) Glasgow FP Workshop
-Proceedings?)
-
-I'm thinking of using it to speed up a critical equality test in some
-graphics stuff in a context where the possibility of saying that
-denotationally equal things aren't isn't a problem (as long as it
-doesn't happen too often.) ADR
-
-To Will: Jim said this was already in, but I can't see it so I'm
-adding it. Up to you whether you add it. (Note that this could have
-been readily implemented using a @veryDangerousCCall@ before they were
-removed...)
-
-\begin{code}
-primOpInfo ReallyUnsafePtrEqualityOp
- = mkGenPrimOp SLIT("reallyUnsafePtrEquality#") [alphaTyVar]
- [alphaTy, alphaTy] intPrimTy
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[PrimOp-parallel]{PrimOpInfo for parallelism op(s)}
-%* *
-%************************************************************************
-
-\begin{code}
-primOpInfo SeqOp -- seq# :: a -> Int#
- = mkGenPrimOp SLIT("seq#") [alphaTyVar] [alphaTy] intPrimTy
-
-primOpInfo ParOp -- par# :: a -> Int#
- = mkGenPrimOp SLIT("par#") [alphaTyVar] [alphaTy] intPrimTy
-\end{code}
-
-\begin{code}
--- 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
-
-primOpInfo ParGlobalOp -- parGlobal# :: a -> Int# -> Int# -> Int# -> Int# -> b -> Int#
- = mkGenPrimOp SLIT("parGlobal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy
-
-primOpInfo ParLocalOp -- parLocal# :: a -> Int# -> Int# -> Int# -> Int# -> b -> Int#
- = mkGenPrimOp SLIT("parLocal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy
-
-primOpInfo ParAtOp -- parAt# :: a -> v -> Int# -> Int# -> Int# -> Int# -> b -> Int#
- = mkGenPrimOp SLIT("parAt#") [alphaTyVar,betaTyVar,gammaTyVar] [betaTy,alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] intPrimTy
-
-primOpInfo ParAtAbsOp -- parAtAbs# :: a -> Int# -> Int# -> Int# -> Int# -> Int# -> b -> Int#
- = mkGenPrimOp SLIT("parAtAbs#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy
-
-primOpInfo ParAtRelOp -- parAtRel# :: a -> Int# -> Int# -> Int# -> Int# -> Int# -> b -> Int#
- = mkGenPrimOp SLIT("parAtRel#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy
-
-primOpInfo ParAtForNowOp -- parAtForNow# :: a -> v -> Int# -> Int# -> Int# -> Int# -> b -> Int#
- = mkGenPrimOp SLIT("parAtForNow#") [alphaTyVar,betaTyVar,gammaTyVar] [betaTy,alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] intPrimTy
-
-primOpInfo CopyableOp -- copyable# :: a -> Int#
- = mkGenPrimOp SLIT("copyable#") [alphaTyVar] [alphaTy] intPrimTy
-
-primOpInfo NoFollowOp -- noFollow# :: a -> Int#
- = mkGenPrimOp SLIT("noFollow#") [alphaTyVar] [alphaTy] intPrimTy
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[PrimOp-IO-etc]{PrimOpInfo for C calls, and I/O-ish things}
-%* *
-%************************************************************************
-
-\begin{code}
-primOpInfo (CCallOp _ _ _ _)
- = mkGenPrimOp SLIT("ccall#") [alphaTyVar] [] alphaTy
-
-{-
-primOpInfo (CCallOp _ _ _ _ arg_tys result_ty)
- = mkGenPrimOp SLIT("ccall#") [] arg_tys result_tycon tys_applied
- where
- (result_tycon, tys_applied, _) = splitAlgTyConApp result_ty
--}
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[PrimOp-tag]{PrimOpInfo for @dataToTag#@ and @tagToEnum#@}
-%* *
-%************************************************************************
-
-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}
-primOpInfo DataToTagOp
- = mkGenPrimOp SLIT("dataToTag#") [alphaTyVar] [alphaTy] intPrimTy
-
-primOpInfo TagToEnumOp
- = mkGenPrimOp SLIT("tagToEnum#") [alphaTyVar] [intPrimTy] alphaTy
-
-#ifdef DEBUG
-primOpInfo op = panic ("primOpInfo:"++ show (I# (tagOf_PrimOp 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 op
- = case op of
- TakeMVarOp -> True
- PutMVarOp -> True
- DelayOp -> True
- WaitReadOp -> True
- WaitWriteOp -> True
- CatchOp -> True
- RaiseOp -> True
- NewArrayOp -> True
- NewByteArrayOp _ -> True
- IntegerAddOp -> True
- IntegerSubOp -> True
- IntegerMulOp -> True
- IntegerGcdOp -> True
- IntegerQuotRemOp -> True
- IntegerDivModOp -> True
- Int2IntegerOp -> True
- Word2IntegerOp -> True
- Addr2IntegerOp -> True
- Word64ToIntegerOp -> True
- Int64ToIntegerOp -> True
- FloatDecodeOp -> True
- DoubleDecodeOp -> True
- MkWeakOp -> True
- FinalizeWeakOp -> True
- MakeStableNameOp -> True
- MakeForeignObjOp -> True
- NewMutVarOp -> True
- NewMVarOp -> True
- ForkOp -> True
- KillThreadOp -> True
- YieldOp -> True
- CCallOp _ _ may_gc@True _ -> True -- _ccall_GC_
- -- the next one doesn't perform any heap checks,
- -- but it is of such an esoteric nature that
- -- it is done out-of-line rather than require
- -- the NCG to implement it.
- UnsafeThawArrayOp -> True
- _ -> False
-\end{code}
-
-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.
-
-See also @primOpIsCheap@ (below).
-
-PrimOps that have side effects also should not be executed speculatively
-or by data dependencies.
-
-\begin{code}
-primOpOkForSpeculation :: PrimOp -> Bool
-primOpOkForSpeculation op
- = not (primOpCanFail op || primOpHasSideEffects op || primOpOutOfLine op)
-\end{code}
-
-@primOpIsCheap@, as used in \tr{SimplUtils.lhs}. For now (HACK
-WARNING), we just borrow some other predicates for a
-what-should-be-good-enough test. "Cheap" means willing to call it more
-than once. Evaluation order is unaffected.
-
-\begin{code}
-primOpIsCheap op = not (primOpHasSideEffects op || primOpOutOfLine op)
-\end{code}
-
-primOpIsDupable means that the use of the primop is small enough to
-duplicate into different case branches. See CoreUtils.exprIsDupable.
-
-\begin{code}
-primOpIsDupable (CCallOp _ _ _ _) = False
-primOpIsDupable op = not (primOpOutOfLine op)
-\end{code}
-
-
-\begin{code}
-primOpCanFail :: PrimOp -> Bool
--- Int.
-primOpCanFail IntQuotOp = True -- Divide by zero
-primOpCanFail IntRemOp = True -- Divide by zero
-
--- Integer
-primOpCanFail IntegerQuotRemOp = True -- Divide by zero
-primOpCanFail IntegerDivModOp = True -- Divide by zero
-
--- Float. ToDo: tan? tanh?
-primOpCanFail FloatDivOp = True -- Divide by zero
-primOpCanFail FloatLogOp = True -- Log of zero
-primOpCanFail FloatAsinOp = True -- Arg out of domain
-primOpCanFail FloatAcosOp = True -- Arg out of domain
-
--- Double. ToDo: tan? tanh?
-primOpCanFail DoubleDivOp = True -- Divide by zero
-primOpCanFail DoubleLogOp = True -- Log of zero
-primOpCanFail DoubleAsinOp = True -- Arg out of domain
-primOpCanFail DoubleAcosOp = True -- Arg out of domain
-
-primOpCanFail other_op = False
-\end{code}
-
-And some primops have side-effects and so, for example, must not be
-duplicated.
-
-\begin{code}
-primOpHasSideEffects :: PrimOp -> Bool
-
-primOpHasSideEffects TakeMVarOp = True
-primOpHasSideEffects DelayOp = True
-primOpHasSideEffects WaitReadOp = True
-primOpHasSideEffects WaitWriteOp = True
-
-primOpHasSideEffects ParOp = True
-primOpHasSideEffects ForkOp = True
-primOpHasSideEffects KillThreadOp = True
-primOpHasSideEffects YieldOp = True
-primOpHasSideEffects SeqOp = True
-
-primOpHasSideEffects MakeForeignObjOp = True
-primOpHasSideEffects WriteForeignObjOp = True
-primOpHasSideEffects MkWeakOp = True
-primOpHasSideEffects DeRefWeakOp = True
-primOpHasSideEffects FinalizeWeakOp = True
-primOpHasSideEffects MakeStablePtrOp = True
-primOpHasSideEffects MakeStableNameOp = True
-primOpHasSideEffects EqStablePtrOp = True -- SOF
-primOpHasSideEffects DeRefStablePtrOp = True -- ??? JSM & ADR
-
-primOpHasSideEffects ParGlobalOp = True
-primOpHasSideEffects ParLocalOp = True
-primOpHasSideEffects ParAtOp = True
-primOpHasSideEffects ParAtAbsOp = True
-primOpHasSideEffects ParAtRelOp = True
-primOpHasSideEffects ParAtForNowOp = True
-primOpHasSideEffects CopyableOp = True -- Possibly not. ASP
-primOpHasSideEffects NoFollowOp = True -- Possibly not. ASP
-
--- CCall
-primOpHasSideEffects (CCallOp _ _ _ _) = True
-
-primOpHasSideEffects other = False
-\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
-
-primOpNeedsWrapper (CCallOp _ _ _ _) = True
-
-primOpNeedsWrapper Integer2IntOp = True
-primOpNeedsWrapper Integer2WordOp = True
-primOpNeedsWrapper IntegerCmpOp = True
-primOpNeedsWrapper IntegerCmpIntOp = True
-
-primOpNeedsWrapper FloatExpOp = True
-primOpNeedsWrapper FloatLogOp = True
-primOpNeedsWrapper FloatSqrtOp = True
-primOpNeedsWrapper FloatSinOp = True
-primOpNeedsWrapper FloatCosOp = True
-primOpNeedsWrapper FloatTanOp = True
-primOpNeedsWrapper FloatAsinOp = True
-primOpNeedsWrapper FloatAcosOp = True
-primOpNeedsWrapper FloatAtanOp = True
-primOpNeedsWrapper FloatSinhOp = True
-primOpNeedsWrapper FloatCoshOp = True
-primOpNeedsWrapper FloatTanhOp = True
-primOpNeedsWrapper FloatPowerOp = True
-
-primOpNeedsWrapper DoubleExpOp = True
-primOpNeedsWrapper DoubleLogOp = True
-primOpNeedsWrapper DoubleSqrtOp = True
-primOpNeedsWrapper DoubleSinOp = True
-primOpNeedsWrapper DoubleCosOp = True
-primOpNeedsWrapper DoubleTanOp = True
-primOpNeedsWrapper DoubleAsinOp = True
-primOpNeedsWrapper DoubleAcosOp = True
-primOpNeedsWrapper DoubleAtanOp = True
-primOpNeedsWrapper DoubleSinhOp = True
-primOpNeedsWrapper DoubleCoshOp = True
-primOpNeedsWrapper DoubleTanhOp = True
-primOpNeedsWrapper DoublePowerOp = True
-
-primOpNeedsWrapper MakeStableNameOp = True
-primOpNeedsWrapper DeRefStablePtrOp = True
-
-primOpNeedsWrapper DelayOp = True
-primOpNeedsWrapper WaitReadOp = True
-primOpNeedsWrapper WaitWriteOp = True
-
-primOpNeedsWrapper other_op = False
-\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)
-
-mkPrimOpIdName :: PrimOp -> Id -> Name
- -- Make the name for the PrimOp's Id
- -- We have to pass in the Id itself because it's a WiredInId
- -- and hence recursive
-mkPrimOpIdName op id
- = mkWiredInIdName key pREL_GHC occ_name id
- where
- occ_name = primOpOcc op
- key = mkPrimOpIdUnique (IBOX(tagOf_PrimOp op))
-
-
-primOpRdrName :: PrimOp -> RdrName
-primOpRdrName op = mkRdrQual pREL_GHC_Name (primOpOcc op)
-
-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)
-
-primOpSig :: PrimOp -> ([TyVar],[Type],Type)
-primOpSig op
- = 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)
-
--- primOpUsg is like primOpSig but the types it yields are the
--- appropriate sigma (i.e., usage-annotated) types,
--- as required by the UsageSP inference.
-
-primOpUsg :: PrimOp -> ([TyVar],[Type],Type)
-primOpUsg op
- = case op of
-
- -- Refer to comment by `otherwise' clause; we need consider here
- -- *only* primops that have arguments or results containing Haskell
- -- pointers (things that are pointed). Unpointed values are
- -- irrelevant to the usage analysis. The issue is whether pointed
- -- values may be entered or duplicated by the primop.
-
- -- Remember that primops are *never* partially applied.
-
- NewArrayOp -> mangle [mkP, mkM, mkP ] mkM
- SameMutableArrayOp -> mangle [mkP, mkP ] mkM
- ReadArrayOp -> mangle [mkM, mkP, mkP ] mkM
- WriteArrayOp -> mangle [mkM, mkP, mkM, mkP] mkR
- IndexArrayOp -> mangle [mkM, mkP ] mkM
- UnsafeFreezeArrayOp -> mangle [mkM, mkP ] mkM
- UnsafeThawArrayOp -> mangle [mkM, mkP ] mkM
-
- NewMutVarOp -> mangle [mkM, mkP ] mkM
- ReadMutVarOp -> mangle [mkM, mkP ] mkM
- WriteMutVarOp -> mangle [mkM, mkM, mkP ] mkR
- SameMutVarOp -> mangle [mkP, mkP ] mkM
-
- CatchOp -> -- [mkO, mkO . (inFun mkM mkO)] mkO
- mangle [mkM, mkM . (inFun mkM mkM)] mkM
- -- might use caught action multiply
- RaiseOp -> mangle [mkM ] mkM
-
- NewMVarOp -> mangle [mkP ] mkR
- TakeMVarOp -> mangle [mkM, mkP ] mkM
- PutMVarOp -> mangle [mkM, mkM, mkP ] mkR
- SameMVarOp -> mangle [mkP, mkP ] mkM
- IsEmptyMVarOp -> mangle [mkP, mkP ] mkM
-
- ForkOp -> mangle [mkO, mkP ] mkR
- KillThreadOp -> mangle [mkP, mkM, mkP ] mkR
-
- MkWeakOp -> mangle [mkZ, mkM, mkM, mkP] mkM
- DeRefWeakOp -> mangle [mkM, mkP ] mkM
- FinalizeWeakOp -> mangle [mkM, mkP ] (mkR . (inUB [id,id,inFun mkR mkM]))
-
- MakeStablePtrOp -> mangle [mkM, mkP ] mkM
- DeRefStablePtrOp -> mangle [mkM, mkP ] mkM
- EqStablePtrOp -> mangle [mkP, mkP ] mkR
- MakeStableNameOp -> mangle [mkZ, mkP ] mkR
- EqStableNameOp -> mangle [mkP, mkP ] mkR
- StableNameToIntOp -> mangle [mkP ] mkR
-
- ReallyUnsafePtrEqualityOp -> mangle [mkZ, mkZ ] mkR
-
- SeqOp -> mangle [mkO ] mkR
- ParOp -> mangle [mkO ] mkR
- ParGlobalOp -> mangle [mkO, mkP, mkP, mkP, mkP, mkM] mkM
- ParLocalOp -> mangle [mkO, mkP, mkP, mkP, mkP, mkM] mkM
- ParAtOp -> mangle [mkO, mkZ, mkP, mkP, mkP, mkP, mkM] mkM
- ParAtAbsOp -> mangle [mkO, mkP, mkP, mkP, mkP, mkM] mkM
- ParAtRelOp -> mangle [mkO, mkP, mkP, mkP, mkP, mkM] mkM
- ParAtForNowOp -> mangle [mkO, mkZ, mkP, mkP, mkP, mkP, mkM] mkM
- CopyableOp -> mangle [mkZ ] mkR
- NoFollowOp -> mangle [mkZ ] mkR
-
- CCallOp _ _ _ _ -> mangle [ ] mkM
-
- -- Things with no Haskell pointers inside: in actuality, usages are
- -- irrelevant here (hence it doesn't matter that some of these
- -- apparently permit duplication; since such arguments are never
- -- ENTERed anyway, the usage annotation they get is entirely irrelevant
- -- except insofar as it propagates to infect other values that *are*
- -- pointed.
-
- otherwise -> nomangle
-
- where mkZ = mkUsgTy UsOnce -- pointed argument used zero
- mkO = mkUsgTy UsOnce -- pointed argument used once
- mkM = mkUsgTy UsMany -- pointed argument used multiply
- mkP = mkUsgTy UsOnce -- unpointed argument
- mkR = mkUsgTy UsMany -- unpointed result
-
- (tyvars, arg_tys, res_ty)
- = primOpSig op
-
- nomangle = (tyvars, map mkP arg_tys, mkR res_ty)
-
- mangle fs g = (tyvars, zipWithEqual "primOpUsg" ($) fs arg_tys, g res_ty)
-
- inFun f g ty = case splitFunTy_maybe ty of
- Just (a,b) -> mkFunTy (f a) (g b)
- Nothing -> pprPanic "primOpUsg:inFun" (ppr op <+> ppr ty)
-
- inUB fs ty = case splitTyConApp_maybe ty of
- Just (tc,tys) -> ASSERT( tc == unboxedTupleTyCon (length fs) )
- mkUnboxedTupleTy (length fs) (zipWithEqual "primOpUsg"
- ($) fs tys)
- Nothing -> pprPanic "primOpUsg:inUB" (ppr op <+> ppr 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 ->
- let rep = typePrimRep ty in
- case rep of
- PtrRep -> case splitAlgTyConApp_maybe ty of
- Nothing -> panic "getPrimOpResultInfo"
- Just (tc,_,_) -> ReturnsAlg tc
- other -> ReturnsPrim other
-
-isCompareOp :: PrimOp -> Bool
-isCompareOp op
- = case primOpInfo op of
- Compare _ _ -> True
- _ -> False
-\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
-
-commutableOp CharEqOp = True
-commutableOp CharNeOp = True
-commutableOp IntAddOp = True
-commutableOp IntMulOp = True
-commutableOp AndOp = True
-commutableOp OrOp = True
-commutableOp XorOp = True
-commutableOp IntEqOp = True
-commutableOp IntNeOp = True
-commutableOp IntegerAddOp = True
-commutableOp IntegerMulOp = True
-commutableOp IntegerGcdOp = True
-commutableOp FloatAddOp = True
-commutableOp FloatMulOp = True
-commutableOp FloatEqOp = True
-commutableOp FloatNeOp = True
-commutableOp DoubleAddOp = True
-commutableOp DoubleMulOp = True
-commutableOp DoubleEqOp = True
-commutableOp DoubleNeOp = True
-commutableOp _ = False
-\end{code}
-
-Utils:
-\begin{code}
-mkPrimTyApp :: [TyVar] -> PrimRep -> ([TyVar], Type)
- -- CharRep --> ([], Char#)
- -- StablePtrRep --> ([a], StablePtr# a)
-mkPrimTyApp tvs kind
- = (forall_tvs, mkTyConApp tycon (mkTyVarTys forall_tvs))
- where
- tycon = primRepTyCon kind
- forall_tvs = take (tyConArity tycon) tvs
-
-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 (CCallOp fun is_casm may_gc cconv)
- = let
- callconv = text "{-" <> pprCallConv cconv <> text "-}"
-
- before
- | is_casm && may_gc = "casm_GC ``"
- | is_casm = "casm ``"
- | may_gc = "ccall_GC "
- | otherwise = "ccall "
-
- after
- | is_casm = text "''"
- | otherwise = empty
-
- ppr_dyn =
- case fun of
- Right _ -> text "dyn_"
- _ -> empty
-
- ppr_fun =
- case fun of
- Right _ -> text "\"\""
- Left fn -> ptext fn
-
- in
- hcat [ ifPprDebug callconv
- , text "__", ppr_dyn
- , text before , ppr_fun , after]
-
-pprPrimOp other_op
- = getPprStyle $ \ sty ->
- if ifaceStyle sty then -- For interfaces Print it qualified with PrelGHC.
- ptext SLIT("PrelGHC.") <> pprOccName occ
- else
- pprOccName occ
- where
- occ = primOpOcc other_op
-\end{code}
+%\r
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998\r
+%\r
+\section[PrimOp]{Primitive operations (machine-level)}\r
+\r
+\begin{code}\r
+module PrimOp (\r
+ PrimOp(..), allThePrimOps,\r
+ primOpType, primOpSig, primOpUsg,\r
+ mkPrimOpIdName, primOpRdrName,\r
+\r
+ commutableOp,\r
+\r
+ primOpOutOfLine, primOpNeedsWrapper, primOpStrictness,\r
+ primOpOkForSpeculation, primOpIsCheap, primOpIsDupable,\r
+ primOpHasSideEffects,\r
+\r
+ getPrimOpResultInfo, PrimOpResultInfo(..),\r
+\r
+ pprPrimOp\r
+ ) where\r
+\r
+#include "HsVersions.h"\r
+\r
+import PrimRep -- most of it\r
+import TysPrim\r
+import TysWiredIn\r
+\r
+import Demand ( Demand, wwLazy, wwPrim, wwStrict )\r
+import Var ( TyVar, Id )\r
+import CallConv ( CallConv, pprCallConv )\r
+import PprType ( pprParendType )\r
+import Name ( Name, mkWiredInIdName )\r
+import RdrName ( RdrName, mkRdrQual )\r
+import OccName ( OccName, pprOccName, mkSrcVarOcc )\r
+import TyCon ( TyCon, tyConArity )\r
+import Type ( Type, mkForAllTys, mkForAllTy, mkFunTy, mkFunTys, mkTyVarTys,\r
+ mkTyConTy, mkTyConApp, typePrimRep,\r
+ splitFunTy_maybe, splitAlgTyConApp_maybe, splitTyConApp_maybe,\r
+ UsageAnn(..), mkUsgTy\r
+ )\r
+import Unique ( Unique, mkPrimOpIdUnique )\r
+import PrelMods ( pREL_GHC, pREL_GHC_Name )\r
+import Outputable\r
+import Util ( assoc, zipWithEqual )\r
+import GlaExts ( Int(..), Int#, (==#) )\r
+\end{code}\r
+\r
+%************************************************************************\r
+%* *\r
+\subsection[PrimOp-datatype]{Datatype for @PrimOp@ (an enumeration)}\r
+%* *\r
+%************************************************************************\r
+\r
+These are in \tr{state-interface.verb} order.\r
+\r
+\begin{code}\r
+data PrimOp\r
+ -- dig the FORTRAN/C influence on the names...\r
+\r
+ -- comparisons:\r
+\r
+ = CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp\r
+ | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp\r
+ | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp\r
+ | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp\r
+ | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp\r
+ | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp\r
+\r
+ -- Char#-related ops:\r
+ | OrdOp | ChrOp\r
+\r
+ -- Int#-related ops:\r
+ -- IntAbsOp unused?? ADR\r
+ | IntAddOp | IntSubOp | IntMulOp | IntQuotOp\r
+ | IntRemOp | IntNegOp | IntAbsOp\r
+ | ISllOp | ISraOp | ISrlOp -- shift {left,right} {arithmetic,logical}\r
+ | IntAddCOp\r
+ | IntSubCOp\r
+ | IntMulCOp\r
+\r
+ -- Word#-related ops:\r
+ | WordQuotOp | WordRemOp\r
+ | AndOp | OrOp | NotOp | XorOp\r
+ | SllOp | SrlOp -- shift {left,right} {logical}\r
+ | Int2WordOp | Word2IntOp -- casts\r
+\r
+ -- Addr#-related ops:\r
+ | Int2AddrOp | Addr2IntOp -- casts\r
+\r
+ -- Float#-related ops:\r
+ | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp\r
+ | Float2IntOp | Int2FloatOp\r
+\r
+ | FloatExpOp | FloatLogOp | FloatSqrtOp\r
+ | FloatSinOp | FloatCosOp | FloatTanOp\r
+ | FloatAsinOp | FloatAcosOp | FloatAtanOp\r
+ | FloatSinhOp | FloatCoshOp | FloatTanhOp\r
+ -- not all machines have these available conveniently:\r
+ -- | FloatAsinhOp | FloatAcoshOp | FloatAtanhOp\r
+ | FloatPowerOp -- ** op\r
+\r
+ -- Double#-related ops:\r
+ | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp\r
+ | Double2IntOp | Int2DoubleOp\r
+ | Double2FloatOp | Float2DoubleOp\r
+\r
+ | DoubleExpOp | DoubleLogOp | DoubleSqrtOp\r
+ | DoubleSinOp | DoubleCosOp | DoubleTanOp\r
+ | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp\r
+ | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp\r
+ -- not all machines have these available conveniently:\r
+ -- | DoubleAsinhOp | DoubleAcoshOp | DoubleAtanhOp\r
+ | DoublePowerOp -- ** op\r
+\r
+ -- Integer (and related...) ops:\r
+ -- slightly weird -- to match GMP package.\r
+ | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerGcdOp\r
+ | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp\r
+\r
+ | IntegerCmpOp\r
+ | IntegerCmpIntOp\r
+\r
+ | Integer2IntOp | Integer2WordOp \r
+ | Int2IntegerOp | Word2IntegerOp\r
+ | Addr2IntegerOp\r
+ -- casting to/from Integer and 64-bit (un)signed quantities.\r
+ | IntegerToInt64Op | Int64ToIntegerOp\r
+ | IntegerToWord64Op | Word64ToIntegerOp\r
+ -- ?? gcd, etc?\r
+\r
+ | FloatDecodeOp\r
+ | DoubleDecodeOp\r
+\r
+ -- primitive ops for primitive arrays\r
+\r
+ | NewArrayOp\r
+ | NewByteArrayOp PrimRep\r
+\r
+ | SameMutableArrayOp\r
+ | SameMutableByteArrayOp\r
+\r
+ | ReadArrayOp | WriteArrayOp | IndexArrayOp -- for arrays of Haskell ptrs\r
+\r
+ | ReadByteArrayOp PrimRep\r
+ | WriteByteArrayOp PrimRep\r
+ | IndexByteArrayOp PrimRep\r
+ | IndexOffAddrOp PrimRep\r
+ | WriteOffAddrOp PrimRep\r
+ -- PrimRep can be one of {Char,Int,Addr,Float,Double}Kind.\r
+ -- This is just a cheesy encoding of a bunch of ops.\r
+ -- Note that ForeignObjRep is not included -- the only way of\r
+ -- creating a ForeignObj is with a ccall or casm.\r
+ | IndexOffForeignObjOp PrimRep\r
+\r
+ | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp\r
+ | UnsafeThawArrayOp | UnsafeThawByteArrayOp\r
+ | SizeofByteArrayOp | SizeofMutableByteArrayOp\r
+\r
+ -- Mutable variables\r
+ | NewMutVarOp\r
+ | ReadMutVarOp\r
+ | WriteMutVarOp\r
+ | SameMutVarOp\r
+\r
+ -- for MVars\r
+ | NewMVarOp\r
+ | TakeMVarOp \r
+ | PutMVarOp\r
+ | SameMVarOp\r
+ | IsEmptyMVarOp\r
+\r
+ -- exceptions\r
+ | CatchOp\r
+ | RaiseOp\r
+\r
+ -- foreign objects\r
+ | MakeForeignObjOp\r
+ | WriteForeignObjOp\r
+\r
+ -- weak pointers\r
+ | MkWeakOp\r
+ | DeRefWeakOp\r
+ | FinalizeWeakOp\r
+\r
+ -- stable names\r
+ | MakeStableNameOp\r
+ | EqStableNameOp\r
+ | StableNameToIntOp\r
+\r
+ -- stable pointers\r
+ | MakeStablePtrOp\r
+ | DeRefStablePtrOp\r
+ | EqStablePtrOp\r
+\end{code}\r
+\r
+A special ``trap-door'' to use in making calls direct to C functions:\r
+\begin{code}\r
+ | CCallOp (Either \r
+ FAST_STRING -- Left fn => An "unboxed" ccall# to `fn'.\r
+ Unique) -- Right u => first argument (an Addr#) is the function pointer\r
+ -- (unique is used to generate a 'typedef' to cast\r
+ -- the function pointer if compiling the ccall# down to\r
+ -- .hc code - can't do this inline for tedious reasons.)\r
+ \r
+ Bool -- True <=> really a "casm"\r
+ Bool -- True <=> might invoke Haskell GC\r
+ CallConv -- calling convention to use.\r
+\r
+ -- (... to be continued ... )\r
+\end{code}\r
+\r
+The ``type'' of @CCallOp foo [t1, ... tm] r@ is @t1 -> ... tm -> r@.\r
+(See @primOpInfo@ for details.)\r
+\r
+Note: that first arg and part of the result should be the system state\r
+token (which we carry around to fool over-zealous optimisers) but\r
+which isn't actually passed.\r
+\r
+For example, we represent\r
+\begin{pseudocode}\r
+((ccall# foo [StablePtr# a, Int] Float) sp# i#) :: (Float, IoWorld)\r
+\end{pseudocode}\r
+by\r
+\begin{pseudocode}\r
+Case\r
+ ( Prim\r
+ (CCallOp "foo" [Universe#, StablePtr# a, Int#] FloatPrimAndUniverse False)\r
+ -- :: Universe# -> StablePtr# a -> Int# -> FloatPrimAndUniverse\r
+ []\r
+ [w#, sp# i#]\r
+ )\r
+ (AlgAlts [ ( FloatPrimAndIoWorld,\r
+ [f#, w#],\r
+ Con (TupleCon 2) [Float, IoWorld] [F# f#, World w#]\r
+ ) ]\r
+ NoDefault\r
+ )\r
+\end{pseudocode}\r
+\r
+Nota Bene: there are some people who find the empty list of types in\r
+the @Prim@ somewhat puzzling and would represent the above by\r
+\begin{pseudocode}\r
+Case\r
+ ( Prim\r
+ (CCallOp "foo" [alpha1, alpha2, alpha3] alpha4 False)\r
+ -- :: /\ alpha1, alpha2 alpha3, alpha4.\r
+ -- alpha1 -> alpha2 -> alpha3 -> alpha4\r
+ [Universe#, StablePtr# a, Int#, FloatPrimAndIoWorld]\r
+ [w#, sp# i#]\r
+ )\r
+ (AlgAlts [ ( FloatPrimAndIoWorld,\r
+ [f#, w#],\r
+ Con (TupleCon 2) [Float, IoWorld] [F# f#, World w#]\r
+ ) ]\r
+ NoDefault\r
+ )\r
+\end{pseudocode}\r
+\r
+But, this is a completely different way of using @CCallOp@. The most\r
+major changes required if we switch to this are in @primOpInfo@, and\r
+the desugarer. The major difficulty is in moving the HeapRequirement\r
+stuff somewhere appropriate. (The advantage is that we could simplify\r
+@CCallOp@ and record just the number of arguments with corresponding\r
+simplifications in reading pragma unfoldings, the simplifier,\r
+instantiation (etc) of core expressions, ... . Maybe we should think\r
+about using it this way?? ADR)\r
+\r
+\begin{code}\r
+ -- (... continued from above ... )\r
+\r
+ -- Operation to test two closure addresses for equality (yes really!)\r
+ -- BLAME ALASTAIR REID FOR THIS! THE REST OF US ARE INNOCENT!\r
+ | ReallyUnsafePtrEqualityOp\r
+\r
+ -- parallel stuff\r
+ | SeqOp\r
+ | ParOp\r
+\r
+ -- concurrency\r
+ | ForkOp\r
+ | KillThreadOp\r
+ | YieldOp\r
+ | MyThreadIdOp\r
+ | DelayOp\r
+ | WaitReadOp\r
+ | WaitWriteOp\r
+\r
+ -- more parallel stuff\r
+ | ParGlobalOp -- named global par\r
+ | ParLocalOp -- named local par\r
+ | ParAtOp -- specifies destination of local par\r
+ | ParAtAbsOp -- specifies destination of local par (abs processor)\r
+ | ParAtRelOp -- specifies destination of local par (rel processor)\r
+ | ParAtForNowOp -- specifies initial destination of global par\r
+ | CopyableOp -- marks copyable code\r
+ | NoFollowOp -- marks non-followup expression\r
+\r
+ -- tag-related\r
+ | DataToTagOp\r
+ | TagToEnumOp\r
+\end{code}\r
+\r
+Used for the Ord instance\r
+\r
+\begin{code}\r
+tagOf_PrimOp CharGtOp = (ILIT( 1) :: FAST_INT)\r
+tagOf_PrimOp CharGeOp = ILIT( 2)\r
+tagOf_PrimOp CharEqOp = ILIT( 3)\r
+tagOf_PrimOp CharNeOp = ILIT( 4)\r
+tagOf_PrimOp CharLtOp = ILIT( 5)\r
+tagOf_PrimOp CharLeOp = ILIT( 6)\r
+tagOf_PrimOp IntGtOp = ILIT( 7)\r
+tagOf_PrimOp IntGeOp = ILIT( 8)\r
+tagOf_PrimOp IntEqOp = ILIT( 9)\r
+tagOf_PrimOp IntNeOp = ILIT( 10)\r
+tagOf_PrimOp IntLtOp = ILIT( 11)\r
+tagOf_PrimOp IntLeOp = ILIT( 12)\r
+tagOf_PrimOp WordGtOp = ILIT( 13)\r
+tagOf_PrimOp WordGeOp = ILIT( 14)\r
+tagOf_PrimOp WordEqOp = ILIT( 15)\r
+tagOf_PrimOp WordNeOp = ILIT( 16)\r
+tagOf_PrimOp WordLtOp = ILIT( 17)\r
+tagOf_PrimOp WordLeOp = ILIT( 18)\r
+tagOf_PrimOp AddrGtOp = ILIT( 19)\r
+tagOf_PrimOp AddrGeOp = ILIT( 20)\r
+tagOf_PrimOp AddrEqOp = ILIT( 21)\r
+tagOf_PrimOp AddrNeOp = ILIT( 22)\r
+tagOf_PrimOp AddrLtOp = ILIT( 23)\r
+tagOf_PrimOp AddrLeOp = ILIT( 24)\r
+tagOf_PrimOp FloatGtOp = ILIT( 25)\r
+tagOf_PrimOp FloatGeOp = ILIT( 26)\r
+tagOf_PrimOp FloatEqOp = ILIT( 27)\r
+tagOf_PrimOp FloatNeOp = ILIT( 28)\r
+tagOf_PrimOp FloatLtOp = ILIT( 29)\r
+tagOf_PrimOp FloatLeOp = ILIT( 30)\r
+tagOf_PrimOp DoubleGtOp = ILIT( 31)\r
+tagOf_PrimOp DoubleGeOp = ILIT( 32)\r
+tagOf_PrimOp DoubleEqOp = ILIT( 33)\r
+tagOf_PrimOp DoubleNeOp = ILIT( 34)\r
+tagOf_PrimOp DoubleLtOp = ILIT( 35)\r
+tagOf_PrimOp DoubleLeOp = ILIT( 36)\r
+tagOf_PrimOp OrdOp = ILIT( 37)\r
+tagOf_PrimOp ChrOp = ILIT( 38)\r
+tagOf_PrimOp IntAddOp = ILIT( 39)\r
+tagOf_PrimOp IntSubOp = ILIT( 40)\r
+tagOf_PrimOp IntMulOp = ILIT( 41)\r
+tagOf_PrimOp IntQuotOp = ILIT( 42)\r
+tagOf_PrimOp IntRemOp = ILIT( 43)\r
+tagOf_PrimOp IntNegOp = ILIT( 44)\r
+tagOf_PrimOp IntAbsOp = ILIT( 45)\r
+tagOf_PrimOp WordQuotOp = ILIT( 46)\r
+tagOf_PrimOp WordRemOp = ILIT( 47)\r
+tagOf_PrimOp AndOp = ILIT( 48)\r
+tagOf_PrimOp OrOp = ILIT( 49)\r
+tagOf_PrimOp NotOp = ILIT( 50)\r
+tagOf_PrimOp XorOp = ILIT( 51)\r
+tagOf_PrimOp SllOp = ILIT( 52)\r
+tagOf_PrimOp SrlOp = ILIT( 53)\r
+tagOf_PrimOp ISllOp = ILIT( 54)\r
+tagOf_PrimOp ISraOp = ILIT( 55)\r
+tagOf_PrimOp ISrlOp = ILIT( 56)\r
+tagOf_PrimOp IntAddCOp = ILIT( 57)\r
+tagOf_PrimOp IntSubCOp = ILIT( 58)\r
+tagOf_PrimOp IntMulCOp = ILIT( 59)\r
+tagOf_PrimOp Int2WordOp = ILIT( 60)\r
+tagOf_PrimOp Word2IntOp = ILIT( 61)\r
+tagOf_PrimOp Int2AddrOp = ILIT( 62)\r
+tagOf_PrimOp Addr2IntOp = ILIT( 63)\r
+\r
+tagOf_PrimOp FloatAddOp = ILIT( 64)\r
+tagOf_PrimOp FloatSubOp = ILIT( 65)\r
+tagOf_PrimOp FloatMulOp = ILIT( 66)\r
+tagOf_PrimOp FloatDivOp = ILIT( 67)\r
+tagOf_PrimOp FloatNegOp = ILIT( 68)\r
+tagOf_PrimOp Float2IntOp = ILIT( 69)\r
+tagOf_PrimOp Int2FloatOp = ILIT( 70)\r
+tagOf_PrimOp FloatExpOp = ILIT( 71)\r
+tagOf_PrimOp FloatLogOp = ILIT( 72)\r
+tagOf_PrimOp FloatSqrtOp = ILIT( 73)\r
+tagOf_PrimOp FloatSinOp = ILIT( 74)\r
+tagOf_PrimOp FloatCosOp = ILIT( 75)\r
+tagOf_PrimOp FloatTanOp = ILIT( 76)\r
+tagOf_PrimOp FloatAsinOp = ILIT( 77)\r
+tagOf_PrimOp FloatAcosOp = ILIT( 78)\r
+tagOf_PrimOp FloatAtanOp = ILIT( 79)\r
+tagOf_PrimOp FloatSinhOp = ILIT( 80)\r
+tagOf_PrimOp FloatCoshOp = ILIT( 81)\r
+tagOf_PrimOp FloatTanhOp = ILIT( 82)\r
+tagOf_PrimOp FloatPowerOp = ILIT( 83)\r
+\r
+tagOf_PrimOp DoubleAddOp = ILIT( 84)\r
+tagOf_PrimOp DoubleSubOp = ILIT( 85)\r
+tagOf_PrimOp DoubleMulOp = ILIT( 86)\r
+tagOf_PrimOp DoubleDivOp = ILIT( 87)\r
+tagOf_PrimOp DoubleNegOp = ILIT( 88)\r
+tagOf_PrimOp Double2IntOp = ILIT( 89)\r
+tagOf_PrimOp Int2DoubleOp = ILIT( 90)\r
+tagOf_PrimOp Double2FloatOp = ILIT( 91)\r
+tagOf_PrimOp Float2DoubleOp = ILIT( 92)\r
+tagOf_PrimOp DoubleExpOp = ILIT( 93)\r
+tagOf_PrimOp DoubleLogOp = ILIT( 94)\r
+tagOf_PrimOp DoubleSqrtOp = ILIT( 95)\r
+tagOf_PrimOp DoubleSinOp = ILIT( 96)\r
+tagOf_PrimOp DoubleCosOp = ILIT( 97)\r
+tagOf_PrimOp DoubleTanOp = ILIT( 98)\r
+tagOf_PrimOp DoubleAsinOp = ILIT( 99)\r
+tagOf_PrimOp DoubleAcosOp = ILIT(100)\r
+tagOf_PrimOp DoubleAtanOp = ILIT(101)\r
+tagOf_PrimOp DoubleSinhOp = ILIT(102)\r
+tagOf_PrimOp DoubleCoshOp = ILIT(103)\r
+tagOf_PrimOp DoubleTanhOp = ILIT(104)\r
+tagOf_PrimOp DoublePowerOp = ILIT(105)\r
+\r
+tagOf_PrimOp IntegerAddOp = ILIT(106)\r
+tagOf_PrimOp IntegerSubOp = ILIT(107)\r
+tagOf_PrimOp IntegerMulOp = ILIT(108)\r
+tagOf_PrimOp IntegerGcdOp = ILIT(109)\r
+tagOf_PrimOp IntegerQuotRemOp = ILIT(110)\r
+tagOf_PrimOp IntegerDivModOp = ILIT(111)\r
+tagOf_PrimOp IntegerNegOp = ILIT(112)\r
+tagOf_PrimOp IntegerCmpOp = ILIT(113)\r
+tagOf_PrimOp IntegerCmpIntOp = ILIT(114)\r
+tagOf_PrimOp Integer2IntOp = ILIT(115)\r
+tagOf_PrimOp Integer2WordOp = ILIT(116)\r
+tagOf_PrimOp Int2IntegerOp = ILIT(117)\r
+tagOf_PrimOp Word2IntegerOp = ILIT(118)\r
+tagOf_PrimOp Addr2IntegerOp = ILIT(119)\r
+tagOf_PrimOp IntegerToInt64Op = ILIT(120)\r
+tagOf_PrimOp Int64ToIntegerOp = ILIT(121)\r
+tagOf_PrimOp IntegerToWord64Op = ILIT(122)\r
+tagOf_PrimOp Word64ToIntegerOp = ILIT(123)\r
+tagOf_PrimOp FloatDecodeOp = ILIT(125)\r
+tagOf_PrimOp DoubleDecodeOp = ILIT(127)\r
+\r
+tagOf_PrimOp NewArrayOp = ILIT(128)\r
+tagOf_PrimOp (NewByteArrayOp CharRep) = ILIT(129)\r
+tagOf_PrimOp (NewByteArrayOp IntRep) = ILIT(130)\r
+tagOf_PrimOp (NewByteArrayOp WordRep) = ILIT(131)\r
+tagOf_PrimOp (NewByteArrayOp AddrRep) = ILIT(132)\r
+tagOf_PrimOp (NewByteArrayOp FloatRep) = ILIT(133)\r
+tagOf_PrimOp (NewByteArrayOp DoubleRep) = ILIT(134)\r
+tagOf_PrimOp (NewByteArrayOp StablePtrRep) = ILIT(135)\r
+\r
+tagOf_PrimOp SameMutableArrayOp = ILIT(136)\r
+tagOf_PrimOp SameMutableByteArrayOp = ILIT(137)\r
+tagOf_PrimOp ReadArrayOp = ILIT(138)\r
+tagOf_PrimOp WriteArrayOp = ILIT(139)\r
+tagOf_PrimOp IndexArrayOp = ILIT(140)\r
+\r
+tagOf_PrimOp (ReadByteArrayOp CharRep) = ILIT(141)\r
+tagOf_PrimOp (ReadByteArrayOp IntRep) = ILIT(142)\r
+tagOf_PrimOp (ReadByteArrayOp WordRep) = ILIT(143)\r
+tagOf_PrimOp (ReadByteArrayOp AddrRep) = ILIT(144)\r
+tagOf_PrimOp (ReadByteArrayOp FloatRep) = ILIT(145)\r
+tagOf_PrimOp (ReadByteArrayOp DoubleRep) = ILIT(146)\r
+tagOf_PrimOp (ReadByteArrayOp StablePtrRep) = ILIT(147)\r
+tagOf_PrimOp (ReadByteArrayOp Int64Rep) = ILIT(148)\r
+tagOf_PrimOp (ReadByteArrayOp Word64Rep) = ILIT(149)\r
+\r
+tagOf_PrimOp (WriteByteArrayOp CharRep) = ILIT(150)\r
+tagOf_PrimOp (WriteByteArrayOp IntRep) = ILIT(151)\r
+tagOf_PrimOp (WriteByteArrayOp WordRep) = ILIT(152)\r
+tagOf_PrimOp (WriteByteArrayOp AddrRep) = ILIT(153)\r
+tagOf_PrimOp (WriteByteArrayOp FloatRep) = ILIT(154)\r
+tagOf_PrimOp (WriteByteArrayOp DoubleRep) = ILIT(155)\r
+tagOf_PrimOp (WriteByteArrayOp StablePtrRep) = ILIT(156)\r
+tagOf_PrimOp (WriteByteArrayOp Int64Rep) = ILIT(157)\r
+tagOf_PrimOp (WriteByteArrayOp Word64Rep) = ILIT(158)\r
+\r
+tagOf_PrimOp (IndexByteArrayOp CharRep) = ILIT(159)\r
+tagOf_PrimOp (IndexByteArrayOp IntRep) = ILIT(160)\r
+tagOf_PrimOp (IndexByteArrayOp WordRep) = ILIT(161)\r
+tagOf_PrimOp (IndexByteArrayOp AddrRep) = ILIT(162)\r
+tagOf_PrimOp (IndexByteArrayOp FloatRep) = ILIT(163)\r
+tagOf_PrimOp (IndexByteArrayOp DoubleRep) = ILIT(164)\r
+tagOf_PrimOp (IndexByteArrayOp StablePtrRep) = ILIT(165)\r
+tagOf_PrimOp (IndexByteArrayOp Int64Rep) = ILIT(166)\r
+tagOf_PrimOp (IndexByteArrayOp Word64Rep) = ILIT(167)\r
+\r
+tagOf_PrimOp (IndexOffAddrOp CharRep) = ILIT(168)\r
+tagOf_PrimOp (IndexOffAddrOp IntRep) = ILIT(169)\r
+tagOf_PrimOp (IndexOffAddrOp WordRep) = ILIT(170)\r
+tagOf_PrimOp (IndexOffAddrOp AddrRep) = ILIT(171)\r
+tagOf_PrimOp (IndexOffAddrOp FloatRep) = ILIT(172)\r
+tagOf_PrimOp (IndexOffAddrOp DoubleRep) = ILIT(173)\r
+tagOf_PrimOp (IndexOffAddrOp StablePtrRep) = ILIT(174)\r
+tagOf_PrimOp (IndexOffAddrOp Int64Rep) = ILIT(175)\r
+tagOf_PrimOp (IndexOffAddrOp Word64Rep) = ILIT(176)\r
+\r
+tagOf_PrimOp (IndexOffForeignObjOp CharRep) = ILIT(177)\r
+tagOf_PrimOp (IndexOffForeignObjOp IntRep) = ILIT(178)\r
+tagOf_PrimOp (IndexOffForeignObjOp WordRep) = ILIT(179)\r
+tagOf_PrimOp (IndexOffForeignObjOp AddrRep) = ILIT(180)\r
+tagOf_PrimOp (IndexOffForeignObjOp FloatRep) = ILIT(181)\r
+tagOf_PrimOp (IndexOffForeignObjOp DoubleRep) = ILIT(182)\r
+tagOf_PrimOp (IndexOffForeignObjOp StablePtrRep) = ILIT(183)\r
+tagOf_PrimOp (IndexOffForeignObjOp Int64Rep) = ILIT(184)\r
+tagOf_PrimOp (IndexOffForeignObjOp Word64Rep) = ILIT(185)\r
+\r
+tagOf_PrimOp (WriteOffAddrOp CharRep) = ILIT(186)\r
+tagOf_PrimOp (WriteOffAddrOp IntRep) = ILIT(187)\r
+tagOf_PrimOp (WriteOffAddrOp WordRep) = ILIT(188)\r
+tagOf_PrimOp (WriteOffAddrOp AddrRep) = ILIT(189)\r
+tagOf_PrimOp (WriteOffAddrOp FloatRep) = ILIT(190)\r
+tagOf_PrimOp (WriteOffAddrOp DoubleRep) = ILIT(191)\r
+tagOf_PrimOp (WriteOffAddrOp StablePtrRep) = ILIT(192)\r
+tagOf_PrimOp (WriteOffAddrOp ForeignObjRep) = ILIT(193)\r
+tagOf_PrimOp (WriteOffAddrOp Int64Rep) = ILIT(194)\r
+tagOf_PrimOp (WriteOffAddrOp Word64Rep) = ILIT(195)\r
+\r
+tagOf_PrimOp UnsafeFreezeArrayOp = ILIT(196)\r
+tagOf_PrimOp UnsafeFreezeByteArrayOp = ILIT(197)\r
+tagOf_PrimOp UnsafeThawArrayOp = ILIT(198)\r
+tagOf_PrimOp UnsafeThawByteArrayOp = ILIT(199)\r
+tagOf_PrimOp SizeofByteArrayOp = ILIT(200)\r
+tagOf_PrimOp SizeofMutableByteArrayOp = ILIT(201)\r
+\r
+tagOf_PrimOp NewMVarOp = ILIT(202)\r
+tagOf_PrimOp TakeMVarOp = ILIT(203)\r
+tagOf_PrimOp PutMVarOp = ILIT(204)\r
+tagOf_PrimOp SameMVarOp = ILIT(205)\r
+tagOf_PrimOp IsEmptyMVarOp = ILIT(206)\r
+tagOf_PrimOp MakeForeignObjOp = ILIT(207)\r
+tagOf_PrimOp WriteForeignObjOp = ILIT(208)\r
+tagOf_PrimOp MkWeakOp = ILIT(209)\r
+tagOf_PrimOp DeRefWeakOp = ILIT(210)\r
+tagOf_PrimOp FinalizeWeakOp = ILIT(211)\r
+tagOf_PrimOp MakeStableNameOp = ILIT(212)\r
+tagOf_PrimOp EqStableNameOp = ILIT(213)\r
+tagOf_PrimOp StableNameToIntOp = ILIT(214)\r
+tagOf_PrimOp MakeStablePtrOp = ILIT(215)\r
+tagOf_PrimOp DeRefStablePtrOp = ILIT(216)\r
+tagOf_PrimOp EqStablePtrOp = ILIT(217)\r
+tagOf_PrimOp (CCallOp _ _ _ _) = ILIT(218)\r
+tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(219)\r
+tagOf_PrimOp SeqOp = ILIT(220)\r
+tagOf_PrimOp ParOp = ILIT(221)\r
+tagOf_PrimOp ForkOp = ILIT(222)\r
+tagOf_PrimOp KillThreadOp = ILIT(223)\r
+tagOf_PrimOp YieldOp = ILIT(224)\r
+tagOf_PrimOp MyThreadIdOp = ILIT(225)\r
+tagOf_PrimOp DelayOp = ILIT(226)\r
+tagOf_PrimOp WaitReadOp = ILIT(227)\r
+tagOf_PrimOp WaitWriteOp = ILIT(228)\r
+tagOf_PrimOp ParGlobalOp = ILIT(229)\r
+tagOf_PrimOp ParLocalOp = ILIT(230)\r
+tagOf_PrimOp ParAtOp = ILIT(231)\r
+tagOf_PrimOp ParAtAbsOp = ILIT(232)\r
+tagOf_PrimOp ParAtRelOp = ILIT(233)\r
+tagOf_PrimOp ParAtForNowOp = ILIT(234)\r
+tagOf_PrimOp CopyableOp = ILIT(235)\r
+tagOf_PrimOp NoFollowOp = ILIT(236)\r
+tagOf_PrimOp NewMutVarOp = ILIT(237)\r
+tagOf_PrimOp ReadMutVarOp = ILIT(238)\r
+tagOf_PrimOp WriteMutVarOp = ILIT(239)\r
+tagOf_PrimOp SameMutVarOp = ILIT(240)\r
+tagOf_PrimOp CatchOp = ILIT(241)\r
+tagOf_PrimOp RaiseOp = ILIT(242)\r
+tagOf_PrimOp DataToTagOp = ILIT(243)\r
+tagOf_PrimOp TagToEnumOp = ILIT(244)\r
+\r
+tagOf_PrimOp op = pprPanic# "tagOf_PrimOp: pattern-match" (ppr op)\r
+--panic# "tagOf_PrimOp: pattern-match"\r
+\r
+instance Eq PrimOp where\r
+ op1 == op2 = tagOf_PrimOp op1 _EQ_ tagOf_PrimOp op2\r
+\r
+instance Ord PrimOp where\r
+ op1 < op2 = tagOf_PrimOp op1 _LT_ tagOf_PrimOp op2\r
+ op1 <= op2 = tagOf_PrimOp op1 _LE_ tagOf_PrimOp op2\r
+ op1 >= op2 = tagOf_PrimOp op1 _GE_ tagOf_PrimOp op2\r
+ op1 > op2 = tagOf_PrimOp op1 _GT_ tagOf_PrimOp op2\r
+ op1 `compare` op2 | op1 < op2 = LT\r
+ | op1 == op2 = EQ\r
+ | otherwise = GT\r
+\r
+instance Outputable PrimOp where\r
+ ppr op = pprPrimOp op\r
+\r
+instance Show PrimOp where\r
+ showsPrec p op = showsPrecSDoc p (pprPrimOp op)\r
+\end{code}\r
+\r
+An @Enum@-derived list would be better; meanwhile... (ToDo)\r
+\begin{code}\r
+allThePrimOps\r
+ = [ CharGtOp,\r
+ CharGeOp,\r
+ CharEqOp,\r
+ CharNeOp,\r
+ CharLtOp,\r
+ CharLeOp,\r
+ IntGtOp,\r
+ IntGeOp,\r
+ IntEqOp,\r
+ IntNeOp,\r
+ IntLtOp,\r
+ IntLeOp,\r
+ WordGtOp,\r
+ WordGeOp,\r
+ WordEqOp,\r
+ WordNeOp,\r
+ WordLtOp,\r
+ WordLeOp,\r
+ AddrGtOp,\r
+ AddrGeOp,\r
+ AddrEqOp,\r
+ AddrNeOp,\r
+ AddrLtOp,\r
+ AddrLeOp,\r
+ FloatGtOp,\r
+ FloatGeOp,\r
+ FloatEqOp,\r
+ FloatNeOp,\r
+ FloatLtOp,\r
+ FloatLeOp,\r
+ DoubleGtOp,\r
+ DoubleGeOp,\r
+ DoubleEqOp,\r
+ DoubleNeOp,\r
+ DoubleLtOp,\r
+ DoubleLeOp,\r
+ OrdOp,\r
+ ChrOp,\r
+ IntAddOp,\r
+ IntSubOp,\r
+ IntMulOp,\r
+ IntQuotOp,\r
+ IntRemOp,\r
+ IntNegOp,\r
+ WordQuotOp,\r
+ WordRemOp,\r
+ AndOp,\r
+ OrOp,\r
+ NotOp,\r
+ XorOp,\r
+ SllOp,\r
+ SrlOp,\r
+ ISllOp,\r
+ ISraOp,\r
+ ISrlOp,\r
+ IntAddCOp,\r
+ IntSubCOp,\r
+ IntMulCOp,\r
+ Int2WordOp,\r
+ Word2IntOp,\r
+ Int2AddrOp,\r
+ Addr2IntOp,\r
+\r
+ FloatAddOp,\r
+ FloatSubOp,\r
+ FloatMulOp,\r
+ FloatDivOp,\r
+ FloatNegOp,\r
+ Float2IntOp,\r
+ Int2FloatOp,\r
+ FloatExpOp,\r
+ FloatLogOp,\r
+ FloatSqrtOp,\r
+ FloatSinOp,\r
+ FloatCosOp,\r
+ FloatTanOp,\r
+ FloatAsinOp,\r
+ FloatAcosOp,\r
+ FloatAtanOp,\r
+ FloatSinhOp,\r
+ FloatCoshOp,\r
+ FloatTanhOp,\r
+ FloatPowerOp,\r
+ DoubleAddOp,\r
+ DoubleSubOp,\r
+ DoubleMulOp,\r
+ DoubleDivOp,\r
+ DoubleNegOp,\r
+ Double2IntOp,\r
+ Int2DoubleOp,\r
+ Double2FloatOp,\r
+ Float2DoubleOp,\r
+ DoubleExpOp,\r
+ DoubleLogOp,\r
+ DoubleSqrtOp,\r
+ DoubleSinOp,\r
+ DoubleCosOp,\r
+ DoubleTanOp,\r
+ DoubleAsinOp,\r
+ DoubleAcosOp,\r
+ DoubleAtanOp,\r
+ DoubleSinhOp,\r
+ DoubleCoshOp,\r
+ DoubleTanhOp,\r
+ DoublePowerOp,\r
+ IntegerAddOp,\r
+ IntegerSubOp,\r
+ IntegerMulOp,\r
+ IntegerGcdOp,\r
+ IntegerQuotRemOp,\r
+ IntegerDivModOp,\r
+ IntegerNegOp,\r
+ IntegerCmpOp,\r
+ IntegerCmpIntOp,\r
+ Integer2IntOp,\r
+ Integer2WordOp,\r
+ Int2IntegerOp,\r
+ Word2IntegerOp,\r
+ Addr2IntegerOp,\r
+ IntegerToInt64Op,\r
+ Int64ToIntegerOp,\r
+ IntegerToWord64Op,\r
+ Word64ToIntegerOp,\r
+ FloatDecodeOp,\r
+ DoubleDecodeOp,\r
+ NewArrayOp,\r
+ NewByteArrayOp CharRep,\r
+ NewByteArrayOp IntRep,\r
+ NewByteArrayOp WordRep,\r
+ NewByteArrayOp AddrRep,\r
+ NewByteArrayOp FloatRep,\r
+ NewByteArrayOp DoubleRep,\r
+ NewByteArrayOp StablePtrRep,\r
+ SameMutableArrayOp,\r
+ SameMutableByteArrayOp,\r
+ ReadArrayOp,\r
+ WriteArrayOp,\r
+ IndexArrayOp,\r
+ ReadByteArrayOp CharRep,\r
+ ReadByteArrayOp IntRep,\r
+ ReadByteArrayOp WordRep,\r
+ ReadByteArrayOp AddrRep,\r
+ ReadByteArrayOp FloatRep,\r
+ ReadByteArrayOp DoubleRep,\r
+ ReadByteArrayOp StablePtrRep,\r
+ ReadByteArrayOp Int64Rep,\r
+ ReadByteArrayOp Word64Rep,\r
+ WriteByteArrayOp CharRep,\r
+ WriteByteArrayOp IntRep,\r
+ WriteByteArrayOp WordRep,\r
+ WriteByteArrayOp AddrRep,\r
+ WriteByteArrayOp FloatRep,\r
+ WriteByteArrayOp DoubleRep,\r
+ WriteByteArrayOp StablePtrRep,\r
+ WriteByteArrayOp Int64Rep,\r
+ WriteByteArrayOp Word64Rep,\r
+ IndexByteArrayOp CharRep,\r
+ IndexByteArrayOp IntRep,\r
+ IndexByteArrayOp WordRep,\r
+ IndexByteArrayOp AddrRep,\r
+ IndexByteArrayOp FloatRep,\r
+ IndexByteArrayOp DoubleRep,\r
+ IndexByteArrayOp StablePtrRep,\r
+ IndexByteArrayOp Int64Rep,\r
+ IndexByteArrayOp Word64Rep,\r
+ IndexOffForeignObjOp CharRep,\r
+ IndexOffForeignObjOp AddrRep,\r
+ IndexOffForeignObjOp IntRep,\r
+ IndexOffForeignObjOp WordRep,\r
+ IndexOffForeignObjOp FloatRep,\r
+ IndexOffForeignObjOp DoubleRep,\r
+ IndexOffForeignObjOp StablePtrRep,\r
+ IndexOffForeignObjOp Int64Rep,\r
+ IndexOffForeignObjOp Word64Rep,\r
+ IndexOffAddrOp CharRep,\r
+ IndexOffAddrOp IntRep,\r
+ IndexOffAddrOp WordRep,\r
+ IndexOffAddrOp AddrRep,\r
+ IndexOffAddrOp FloatRep,\r
+ IndexOffAddrOp DoubleRep,\r
+ IndexOffAddrOp StablePtrRep,\r
+ IndexOffAddrOp Int64Rep,\r
+ IndexOffAddrOp Word64Rep,\r
+ WriteOffAddrOp CharRep,\r
+ WriteOffAddrOp IntRep,\r
+ WriteOffAddrOp WordRep,\r
+ WriteOffAddrOp AddrRep,\r
+ WriteOffAddrOp FloatRep,\r
+ WriteOffAddrOp DoubleRep,\r
+ WriteOffAddrOp ForeignObjRep,\r
+ WriteOffAddrOp StablePtrRep,\r
+ WriteOffAddrOp Int64Rep,\r
+ WriteOffAddrOp Word64Rep,\r
+ UnsafeFreezeArrayOp,\r
+ UnsafeFreezeByteArrayOp,\r
+ UnsafeThawArrayOp,\r
+ UnsafeThawByteArrayOp,\r
+ SizeofByteArrayOp,\r
+ SizeofMutableByteArrayOp,\r
+ NewMutVarOp,\r
+ ReadMutVarOp,\r
+ WriteMutVarOp,\r
+ SameMutVarOp,\r
+ CatchOp,\r
+ RaiseOp,\r
+ NewMVarOp,\r
+ TakeMVarOp,\r
+ PutMVarOp,\r
+ SameMVarOp,\r
+ IsEmptyMVarOp,\r
+ MakeForeignObjOp,\r
+ WriteForeignObjOp,\r
+ MkWeakOp,\r
+ DeRefWeakOp,\r
+ FinalizeWeakOp,\r
+ MakeStableNameOp,\r
+ EqStableNameOp,\r
+ StableNameToIntOp,\r
+ MakeStablePtrOp,\r
+ DeRefStablePtrOp,\r
+ EqStablePtrOp,\r
+ ReallyUnsafePtrEqualityOp,\r
+ ParGlobalOp,\r
+ ParLocalOp,\r
+ ParAtOp,\r
+ ParAtAbsOp,\r
+ ParAtRelOp,\r
+ ParAtForNowOp,\r
+ CopyableOp,\r
+ NoFollowOp,\r
+ SeqOp,\r
+ ParOp,\r
+ ForkOp,\r
+ KillThreadOp,\r
+ YieldOp,\r
+ MyThreadIdOp,\r
+ DelayOp,\r
+ WaitReadOp,\r
+ WaitWriteOp,\r
+ DataToTagOp,\r
+ TagToEnumOp\r
+ ]\r
+\end{code}\r
+\r
+%************************************************************************\r
+%* *\r
+\subsection[PrimOp-info]{The essential info about each @PrimOp@}\r
+%* *\r
+%************************************************************************\r
+\r
+The @String@ in the @PrimOpInfos@ is the ``base name'' by which the user may\r
+refer to the primitive operation. The conventional \tr{#}-for-\r
+unboxed ops is added on later.\r
+\r
+The reason for the funny characters in the names is so we do not\r
+interfere with the programmer's Haskell name spaces.\r
+\r
+We use @PrimKinds@ for the ``type'' information, because they're\r
+(slightly) more convenient to use than @TyCons@.\r
+\begin{code}\r
+data PrimOpInfo\r
+ = Dyadic OccName -- string :: T -> T -> T\r
+ Type\r
+ | Monadic OccName -- string :: T -> T\r
+ Type\r
+ | Compare OccName -- string :: T -> T -> Bool\r
+ Type\r
+\r
+ | GenPrimOp OccName -- string :: \/a1..an . T1 -> .. -> Tk -> T\r
+ [TyVar] \r
+ [Type] \r
+ Type \r
+\r
+mkDyadic str ty = Dyadic (mkSrcVarOcc str) ty\r
+mkMonadic str ty = Monadic (mkSrcVarOcc str) ty\r
+mkCompare str ty = Compare (mkSrcVarOcc str) ty\r
+mkGenPrimOp str tvs tys ty = GenPrimOp (mkSrcVarOcc str) tvs tys ty\r
+\end{code}\r
+\r
+Utility bits:\r
+\begin{code}\r
+one_Integer_ty = [intPrimTy, byteArrayPrimTy]\r
+two_Integer_tys\r
+ = [intPrimTy, byteArrayPrimTy, -- first Integer pieces\r
+ intPrimTy, byteArrayPrimTy] -- second '' pieces\r
+an_Integer_and_Int_tys\r
+ = [intPrimTy, byteArrayPrimTy, -- Integer\r
+ intPrimTy]\r
+\r
+unboxedPair = mkUnboxedTupleTy 2\r
+unboxedTriple = mkUnboxedTupleTy 3\r
+unboxedQuadruple = mkUnboxedTupleTy 4\r
+\r
+integerMonadic name = mkGenPrimOp name [] one_Integer_ty \r
+ (unboxedPair one_Integer_ty)\r
+\r
+integerDyadic name = mkGenPrimOp name [] two_Integer_tys \r
+ (unboxedPair one_Integer_ty)\r
+\r
+integerDyadic2Results name = mkGenPrimOp name [] two_Integer_tys \r
+ (unboxedQuadruple two_Integer_tys)\r
+\r
+integerCompare name = mkGenPrimOp name [] two_Integer_tys intPrimTy\r
+\end{code}\r
+\r
+%************************************************************************\r
+%* *\r
+\subsubsection{Strictness}\r
+%* *\r
+%************************************************************************\r
+\r
+Not all primops are strict!\r
+\r
+\begin{code}\r
+primOpStrictness :: PrimOp -> ([Demand], Bool)\r
+ -- See IdInfo.StrictnessInfo for discussion of what the results\r
+ -- **NB** as a cheap hack, to avoid having to look up the PrimOp's arity,\r
+ -- the list of demands may be infinite!\r
+ -- Use only the ones you ned.\r
+\r
+primOpStrictness SeqOp = ([wwStrict], False)\r
+ -- Seq is strict in its argument; see notes in ConFold.lhs\r
+\r
+primOpStrictness ParOp = ([wwLazy], False)\r
+ -- But Par is lazy, to avoid that the sparked thing\r
+ -- gets evaluted strictly, which it should *not* be\r
+\r
+primOpStrictness ForkOp = ([wwLazy, wwPrim], False)\r
+\r
+primOpStrictness NewArrayOp = ([wwPrim, wwLazy, wwPrim], False)\r
+primOpStrictness WriteArrayOp = ([wwPrim, wwPrim, wwLazy, wwPrim], False)\r
+\r
+primOpStrictness NewMutVarOp = ([wwLazy, wwPrim], False)\r
+primOpStrictness WriteMutVarOp = ([wwPrim, wwLazy, wwPrim], False)\r
+\r
+primOpStrictness PutMVarOp = ([wwPrim, wwLazy, wwPrim], False)\r
+\r
+primOpStrictness CatchOp = ([wwLazy, wwLazy], False)\r
+primOpStrictness RaiseOp = ([wwLazy], True) -- NB: True => result is bottom\r
+\r
+primOpStrictness MkWeakOp = ([wwLazy, wwLazy, wwLazy, wwPrim], False)\r
+primOpStrictness MakeStableNameOp = ([wwLazy, wwPrim], False)\r
+primOpStrictness MakeStablePtrOp = ([wwLazy, wwPrim], False)\r
+\r
+primOpStrictness DataToTagOp = ([wwLazy], False)\r
+\r
+ -- The rest all have primitive-typed arguments\r
+primOpStrictness other = (repeat wwPrim, False)\r
+\end{code}\r
+\r
+%************************************************************************\r
+%* *\r
+\subsubsection[PrimOp-comparison]{PrimOpInfo basic comparison ops}\r
+%* *\r
+%************************************************************************\r
+\r
+@primOpInfo@ gives all essential information (from which everything\r
+else, notably a type, can be constructed) for each @PrimOp@.\r
+\r
+\begin{code}\r
+primOpInfo :: PrimOp -> PrimOpInfo\r
+\end{code}\r
+\r
+There's plenty of this stuff!\r
+\r
+\begin{code}\r
+primOpInfo CharGtOp = mkCompare SLIT("gtChar#") charPrimTy\r
+primOpInfo CharGeOp = mkCompare SLIT("geChar#") charPrimTy\r
+primOpInfo CharEqOp = mkCompare SLIT("eqChar#") charPrimTy\r
+primOpInfo CharNeOp = mkCompare SLIT("neChar#") charPrimTy\r
+primOpInfo CharLtOp = mkCompare SLIT("ltChar#") charPrimTy\r
+primOpInfo CharLeOp = mkCompare SLIT("leChar#") charPrimTy\r
+\r
+primOpInfo IntGtOp = mkCompare SLIT(">#") intPrimTy\r
+primOpInfo IntGeOp = mkCompare SLIT(">=#") intPrimTy\r
+primOpInfo IntEqOp = mkCompare SLIT("==#") intPrimTy\r
+primOpInfo IntNeOp = mkCompare SLIT("/=#") intPrimTy\r
+primOpInfo IntLtOp = mkCompare SLIT("<#") intPrimTy\r
+primOpInfo IntLeOp = mkCompare SLIT("<=#") intPrimTy\r
+\r
+primOpInfo WordGtOp = mkCompare SLIT("gtWord#") wordPrimTy\r
+primOpInfo WordGeOp = mkCompare SLIT("geWord#") wordPrimTy\r
+primOpInfo WordEqOp = mkCompare SLIT("eqWord#") wordPrimTy\r
+primOpInfo WordNeOp = mkCompare SLIT("neWord#") wordPrimTy\r
+primOpInfo WordLtOp = mkCompare SLIT("ltWord#") wordPrimTy\r
+primOpInfo WordLeOp = mkCompare SLIT("leWord#") wordPrimTy\r
+\r
+primOpInfo AddrGtOp = mkCompare SLIT("gtAddr#") addrPrimTy\r
+primOpInfo AddrGeOp = mkCompare SLIT("geAddr#") addrPrimTy\r
+primOpInfo AddrEqOp = mkCompare SLIT("eqAddr#") addrPrimTy\r
+primOpInfo AddrNeOp = mkCompare SLIT("neAddr#") addrPrimTy\r
+primOpInfo AddrLtOp = mkCompare SLIT("ltAddr#") addrPrimTy\r
+primOpInfo AddrLeOp = mkCompare SLIT("leAddr#") addrPrimTy\r
+\r
+primOpInfo FloatGtOp = mkCompare SLIT("gtFloat#") floatPrimTy\r
+primOpInfo FloatGeOp = mkCompare SLIT("geFloat#") floatPrimTy\r
+primOpInfo FloatEqOp = mkCompare SLIT("eqFloat#") floatPrimTy\r
+primOpInfo FloatNeOp = mkCompare SLIT("neFloat#") floatPrimTy\r
+primOpInfo FloatLtOp = mkCompare SLIT("ltFloat#") floatPrimTy\r
+primOpInfo FloatLeOp = mkCompare SLIT("leFloat#") floatPrimTy\r
+\r
+primOpInfo DoubleGtOp = mkCompare SLIT(">##") doublePrimTy\r
+primOpInfo DoubleGeOp = mkCompare SLIT(">=##") doublePrimTy\r
+primOpInfo DoubleEqOp = mkCompare SLIT("==##") doublePrimTy\r
+primOpInfo DoubleNeOp = mkCompare SLIT("/=##") doublePrimTy\r
+primOpInfo DoubleLtOp = mkCompare SLIT("<##") doublePrimTy\r
+primOpInfo DoubleLeOp = mkCompare SLIT("<=##") doublePrimTy\r
+\r
+\end{code}\r
+\r
+%************************************************************************\r
+%* *\r
+\subsubsection[PrimOp-Char]{PrimOpInfo for @Char#@s}\r
+%* *\r
+%************************************************************************\r
+\r
+\begin{code}\r
+primOpInfo OrdOp = mkGenPrimOp SLIT("ord#") [] [charPrimTy] intPrimTy\r
+primOpInfo ChrOp = mkGenPrimOp SLIT("chr#") [] [intPrimTy] charPrimTy\r
+\end{code}\r
+\r
+%************************************************************************\r
+%* *\r
+\subsubsection[PrimOp-Int]{PrimOpInfo for @Int#@s}\r
+%* *\r
+%************************************************************************\r
+\r
+\begin{code}\r
+primOpInfo IntAddOp = mkDyadic SLIT("+#") intPrimTy\r
+primOpInfo IntSubOp = mkDyadic SLIT("-#") intPrimTy\r
+primOpInfo IntMulOp = mkDyadic SLIT("*#") intPrimTy\r
+primOpInfo IntQuotOp = mkDyadic SLIT("quotInt#") intPrimTy\r
+primOpInfo IntRemOp = mkDyadic SLIT("remInt#") intPrimTy\r
+\r
+primOpInfo IntNegOp = mkMonadic SLIT("negateInt#") intPrimTy\r
+primOpInfo IntAbsOp = mkMonadic SLIT("absInt#") intPrimTy\r
+\r
+primOpInfo IntAddCOp = \r
+ mkGenPrimOp SLIT("addIntC#") [] [intPrimTy, intPrimTy] \r
+ (unboxedPair [intPrimTy, intPrimTy])\r
+\r
+primOpInfo IntSubCOp = \r
+ mkGenPrimOp SLIT("subIntC#") [] [intPrimTy, intPrimTy] \r
+ (unboxedPair [intPrimTy, intPrimTy])\r
+\r
+primOpInfo IntMulCOp = \r
+ mkGenPrimOp SLIT("mulIntC#") [] [intPrimTy, intPrimTy] \r
+ (unboxedPair [intPrimTy, intPrimTy])\r
+\end{code}\r
+\r
+%************************************************************************\r
+%* *\r
+\subsubsection[PrimOp-Word]{PrimOpInfo for @Word#@s}\r
+%* *\r
+%************************************************************************\r
+\r
+A @Word#@ is an unsigned @Int#@.\r
+\r
+\begin{code}\r
+primOpInfo WordQuotOp = mkDyadic SLIT("quotWord#") wordPrimTy\r
+primOpInfo WordRemOp = mkDyadic SLIT("remWord#") wordPrimTy\r
+\r
+primOpInfo AndOp = mkDyadic SLIT("and#") wordPrimTy\r
+primOpInfo OrOp = mkDyadic SLIT("or#") wordPrimTy\r
+primOpInfo XorOp = mkDyadic SLIT("xor#") wordPrimTy\r
+primOpInfo NotOp = mkMonadic SLIT("not#") wordPrimTy\r
+\r
+primOpInfo SllOp\r
+ = mkGenPrimOp SLIT("shiftL#") [] [wordPrimTy, intPrimTy] wordPrimTy\r
+primOpInfo SrlOp\r
+ = mkGenPrimOp SLIT("shiftRL#") [] [wordPrimTy, intPrimTy] wordPrimTy\r
+\r
+primOpInfo ISllOp\r
+ = mkGenPrimOp SLIT("iShiftL#") [] [intPrimTy, intPrimTy] intPrimTy\r
+primOpInfo ISraOp\r
+ = mkGenPrimOp SLIT("iShiftRA#") [] [intPrimTy, intPrimTy] intPrimTy\r
+primOpInfo ISrlOp\r
+ = mkGenPrimOp SLIT("iShiftRL#") [] [intPrimTy, intPrimTy] intPrimTy\r
+\r
+primOpInfo Int2WordOp = mkGenPrimOp SLIT("int2Word#") [] [intPrimTy] wordPrimTy\r
+primOpInfo Word2IntOp = mkGenPrimOp SLIT("word2Int#") [] [wordPrimTy] intPrimTy\r
+\end{code}\r
+\r
+%************************************************************************\r
+%* *\r
+\subsubsection[PrimOp-Addr]{PrimOpInfo for @Addr#@s}\r
+%* *\r
+%************************************************************************\r
+\r
+\begin{code}\r
+primOpInfo Int2AddrOp = mkGenPrimOp SLIT("int2Addr#") [] [intPrimTy] addrPrimTy\r
+primOpInfo Addr2IntOp = mkGenPrimOp SLIT("addr2Int#") [] [addrPrimTy] intPrimTy\r
+\end{code}\r
+\r
+\r
+%************************************************************************\r
+%* *\r
+\subsubsection[PrimOp-Float]{PrimOpInfo for @Float#@s}\r
+%* *\r
+%************************************************************************\r
+\r
+@decodeFloat#@ is given w/ Integer-stuff (it's similar).\r
+\r
+\begin{code}\r
+primOpInfo FloatAddOp = mkDyadic SLIT("plusFloat#") floatPrimTy\r
+primOpInfo FloatSubOp = mkDyadic SLIT("minusFloat#") floatPrimTy\r
+primOpInfo FloatMulOp = mkDyadic SLIT("timesFloat#") floatPrimTy\r
+primOpInfo FloatDivOp = mkDyadic SLIT("divideFloat#") floatPrimTy\r
+primOpInfo FloatNegOp = mkMonadic SLIT("negateFloat#") floatPrimTy\r
+\r
+primOpInfo Float2IntOp = mkGenPrimOp SLIT("float2Int#") [] [floatPrimTy] intPrimTy\r
+primOpInfo Int2FloatOp = mkGenPrimOp SLIT("int2Float#") [] [intPrimTy] floatPrimTy\r
+\r
+primOpInfo FloatExpOp = mkMonadic SLIT("expFloat#") floatPrimTy\r
+primOpInfo FloatLogOp = mkMonadic SLIT("logFloat#") floatPrimTy\r
+primOpInfo FloatSqrtOp = mkMonadic SLIT("sqrtFloat#") floatPrimTy\r
+primOpInfo FloatSinOp = mkMonadic SLIT("sinFloat#") floatPrimTy\r
+primOpInfo FloatCosOp = mkMonadic SLIT("cosFloat#") floatPrimTy\r
+primOpInfo FloatTanOp = mkMonadic SLIT("tanFloat#") floatPrimTy\r
+primOpInfo FloatAsinOp = mkMonadic SLIT("asinFloat#") floatPrimTy\r
+primOpInfo FloatAcosOp = mkMonadic SLIT("acosFloat#") floatPrimTy\r
+primOpInfo FloatAtanOp = mkMonadic SLIT("atanFloat#") floatPrimTy\r
+primOpInfo FloatSinhOp = mkMonadic SLIT("sinhFloat#") floatPrimTy\r
+primOpInfo FloatCoshOp = mkMonadic SLIT("coshFloat#") floatPrimTy\r
+primOpInfo FloatTanhOp = mkMonadic SLIT("tanhFloat#") floatPrimTy\r
+primOpInfo FloatPowerOp = mkDyadic SLIT("powerFloat#") floatPrimTy\r
+\end{code}\r
+\r
+%************************************************************************\r
+%* *\r
+\subsubsection[PrimOp-Double]{PrimOpInfo for @Double#@s}\r
+%* *\r
+%************************************************************************\r
+\r
+@decodeDouble#@ is given w/ Integer-stuff (it's similar).\r
+\r
+\begin{code}\r
+primOpInfo DoubleAddOp = mkDyadic SLIT("+##") doublePrimTy\r
+primOpInfo DoubleSubOp = mkDyadic SLIT("-##") doublePrimTy\r
+primOpInfo DoubleMulOp = mkDyadic SLIT("*##") doublePrimTy\r
+primOpInfo DoubleDivOp = mkDyadic SLIT("/##") doublePrimTy\r
+primOpInfo DoubleNegOp = mkMonadic SLIT("negateDouble#") doublePrimTy\r
+\r
+primOpInfo Double2IntOp = mkGenPrimOp SLIT("double2Int#") [] [doublePrimTy] intPrimTy\r
+primOpInfo Int2DoubleOp = mkGenPrimOp SLIT("int2Double#") [] [intPrimTy] doublePrimTy\r
+\r
+primOpInfo Double2FloatOp = mkGenPrimOp SLIT("double2Float#") [] [doublePrimTy] floatPrimTy\r
+primOpInfo Float2DoubleOp = mkGenPrimOp SLIT("float2Double#") [] [floatPrimTy] doublePrimTy\r
+\r
+primOpInfo DoubleExpOp = mkMonadic SLIT("expDouble#") doublePrimTy\r
+primOpInfo DoubleLogOp = mkMonadic SLIT("logDouble#") doublePrimTy\r
+primOpInfo DoubleSqrtOp = mkMonadic SLIT("sqrtDouble#") doublePrimTy\r
+primOpInfo DoubleSinOp = mkMonadic SLIT("sinDouble#") doublePrimTy\r
+primOpInfo DoubleCosOp = mkMonadic SLIT("cosDouble#") doublePrimTy\r
+primOpInfo DoubleTanOp = mkMonadic SLIT("tanDouble#") doublePrimTy\r
+primOpInfo DoubleAsinOp = mkMonadic SLIT("asinDouble#") doublePrimTy\r
+primOpInfo DoubleAcosOp = mkMonadic SLIT("acosDouble#") doublePrimTy\r
+primOpInfo DoubleAtanOp = mkMonadic SLIT("atanDouble#") doublePrimTy\r
+primOpInfo DoubleSinhOp = mkMonadic SLIT("sinhDouble#") doublePrimTy\r
+primOpInfo DoubleCoshOp = mkMonadic SLIT("coshDouble#") doublePrimTy\r
+primOpInfo DoubleTanhOp = mkMonadic SLIT("tanhDouble#") doublePrimTy\r
+primOpInfo DoublePowerOp= mkDyadic SLIT("**##") doublePrimTy\r
+\end{code}\r
+\r
+%************************************************************************\r
+%* *\r
+\subsubsection[PrimOp-Integer]{PrimOpInfo for @Integer@ (and related!)}\r
+%* *\r
+%************************************************************************\r
+\r
+\begin{code}\r
+primOpInfo IntegerNegOp = integerMonadic SLIT("negateInteger#")\r
+\r
+primOpInfo IntegerAddOp = integerDyadic SLIT("plusInteger#")\r
+primOpInfo IntegerSubOp = integerDyadic SLIT("minusInteger#")\r
+primOpInfo IntegerMulOp = integerDyadic SLIT("timesInteger#")\r
+primOpInfo IntegerGcdOp = integerDyadic SLIT("gcdInteger#")\r
+\r
+primOpInfo IntegerCmpOp = integerCompare SLIT("cmpInteger#")\r
+primOpInfo IntegerCmpIntOp \r
+ = mkGenPrimOp SLIT("cmpIntegerInt#") [] an_Integer_and_Int_tys intPrimTy\r
+\r
+primOpInfo IntegerQuotRemOp = integerDyadic2Results SLIT("quotRemInteger#")\r
+primOpInfo IntegerDivModOp = integerDyadic2Results SLIT("divModInteger#")\r
+\r
+primOpInfo Integer2IntOp\r
+ = mkGenPrimOp SLIT("integer2Int#") [] one_Integer_ty intPrimTy\r
+\r
+primOpInfo Integer2WordOp\r
+ = mkGenPrimOp SLIT("integer2Word#") [] one_Integer_ty wordPrimTy\r
+\r
+primOpInfo Int2IntegerOp\r
+ = mkGenPrimOp SLIT("int2Integer#") [] [intPrimTy] \r
+ (unboxedPair one_Integer_ty)\r
+\r
+primOpInfo Word2IntegerOp\r
+ = mkGenPrimOp SLIT("word2Integer#") [] [wordPrimTy] \r
+ (unboxedPair one_Integer_ty)\r
+\r
+primOpInfo Addr2IntegerOp\r
+ = mkGenPrimOp SLIT("addr2Integer#") [] [addrPrimTy] \r
+ (unboxedPair one_Integer_ty)\r
+\r
+primOpInfo IntegerToInt64Op\r
+ = mkGenPrimOp SLIT("integerToInt64#") [] one_Integer_ty int64PrimTy\r
+\r
+primOpInfo Int64ToIntegerOp\r
+ = mkGenPrimOp SLIT("int64ToInteger#") [] [int64PrimTy]\r
+ (unboxedPair one_Integer_ty)\r
+\r
+primOpInfo Word64ToIntegerOp\r
+ = mkGenPrimOp SLIT("word64ToInteger#") [] [word64PrimTy] \r
+ (unboxedPair one_Integer_ty)\r
+\r
+primOpInfo IntegerToWord64Op\r
+ = mkGenPrimOp SLIT("integerToWord64#") [] one_Integer_ty word64PrimTy\r
+\end{code}\r
+\r
+Decoding of floating-point numbers is sorta Integer-related. Encoding\r
+is done with plain ccalls now (see PrelNumExtra.lhs).\r
+\r
+\begin{code}\r
+primOpInfo FloatDecodeOp\r
+ = mkGenPrimOp SLIT("decodeFloat#") [] [floatPrimTy] \r
+ (unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy])\r
+primOpInfo DoubleDecodeOp\r
+ = mkGenPrimOp SLIT("decodeDouble#") [] [doublePrimTy] \r
+ (unboxedTriple [intPrimTy, intPrimTy, byteArrayPrimTy])\r
+\end{code}\r
+\r
+%************************************************************************\r
+%* *\r
+\subsubsection[PrimOp-Arrays]{PrimOpInfo for primitive arrays}\r
+%* *\r
+%************************************************************************\r
+\r
+\begin{verbatim}\r
+newArray# :: Int# -> a -> State# s -> (# State# s, MutArr# s a #)\r
+newFooArray# :: Int# -> State# s -> (# State# s, MutByteArr# s #)\r
+\end{verbatim}\r
+\r
+\begin{code}\r
+primOpInfo NewArrayOp\r
+ = let {\r
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;\r
+ state = mkStatePrimTy s\r
+ } in\r
+ mkGenPrimOp SLIT("newArray#") [s_tv, elt_tv] \r
+ [intPrimTy, elt, state]\r
+ (unboxedPair [state, mkMutableArrayPrimTy s elt])\r
+\r
+primOpInfo (NewByteArrayOp kind)\r
+ = let\r
+ s = alphaTy; s_tv = alphaTyVar\r
+\r
+ op_str = _PK_ ("new" ++ primRepString kind ++ "Array#")\r
+ state = mkStatePrimTy s\r
+ in\r
+ mkGenPrimOp op_str [s_tv]\r
+ [intPrimTy, state]\r
+ (unboxedPair [state, mkMutableByteArrayPrimTy s])\r
+\r
+---------------------------------------------------------------------------\r
+\r
+{-\r
+sameMutableArray# :: MutArr# s a -> MutArr# s a -> Bool\r
+sameMutableByteArray# :: MutByteArr# s -> MutByteArr# s -> Bool\r
+-}\r
+\r
+primOpInfo SameMutableArrayOp\r
+ = let {\r
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;\r
+ mut_arr_ty = mkMutableArrayPrimTy s elt\r
+ } in\r
+ mkGenPrimOp SLIT("sameMutableArray#") [s_tv, elt_tv] [mut_arr_ty, mut_arr_ty]\r
+ boolTy\r
+\r
+primOpInfo SameMutableByteArrayOp\r
+ = let {\r
+ s = alphaTy; s_tv = alphaTyVar;\r
+ mut_arr_ty = mkMutableByteArrayPrimTy s\r
+ } in\r
+ mkGenPrimOp SLIT("sameMutableByteArray#") [s_tv] [mut_arr_ty, mut_arr_ty]\r
+ boolTy\r
+\r
+---------------------------------------------------------------------------\r
+-- Primitive arrays of Haskell pointers:\r
+\r
+{-\r
+readArray# :: MutArr# s a -> Int# -> State# s -> (# State# s, a #)\r
+writeArray# :: MutArr# s a -> Int# -> a -> State# s -> State# s\r
+indexArray# :: Array# a -> Int# -> (# a #)\r
+-}\r
+\r
+primOpInfo ReadArrayOp\r
+ = let {\r
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;\r
+ state = mkStatePrimTy s\r
+ } in\r
+ mkGenPrimOp SLIT("readArray#") [s_tv, elt_tv]\r
+ [mkMutableArrayPrimTy s elt, intPrimTy, state]\r
+ (unboxedPair [state, elt])\r
+\r
+\r
+primOpInfo WriteArrayOp\r
+ = let {\r
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar\r
+ } in\r
+ mkGenPrimOp SLIT("writeArray#") [s_tv, elt_tv]\r
+ [mkMutableArrayPrimTy s elt, intPrimTy, elt, mkStatePrimTy s]\r
+ (mkStatePrimTy s)\r
+\r
+primOpInfo IndexArrayOp\r
+ = let { elt = alphaTy; elt_tv = alphaTyVar } in\r
+ mkGenPrimOp SLIT("indexArray#") [elt_tv] [mkArrayPrimTy elt, intPrimTy]\r
+ (mkUnboxedTupleTy 1 [elt])\r
+\r
+---------------------------------------------------------------------------\r
+-- Primitive arrays full of unboxed bytes:\r
+\r
+primOpInfo (ReadByteArrayOp kind)\r
+ = let\r
+ s = alphaTy; s_tv = alphaTyVar\r
+\r
+ op_str = _PK_ ("read" ++ primRepString kind ++ "Array#")\r
+ (tvs, prim_ty) = mkPrimTyApp betaTyVars kind\r
+ state = mkStatePrimTy s\r
+ in\r
+ mkGenPrimOp op_str (s_tv:tvs)\r
+ [mkMutableByteArrayPrimTy s, intPrimTy, state]\r
+ (unboxedPair [state, prim_ty])\r
+\r
+primOpInfo (WriteByteArrayOp kind)\r
+ = let\r
+ s = alphaTy; s_tv = alphaTyVar\r
+ op_str = _PK_ ("write" ++ primRepString kind ++ "Array#")\r
+ (tvs, prim_ty) = mkPrimTyApp betaTyVars kind\r
+ in\r
+ mkGenPrimOp op_str (s_tv:tvs)\r
+ [mkMutableByteArrayPrimTy s, intPrimTy, prim_ty, mkStatePrimTy s]\r
+ (mkStatePrimTy s)\r
+\r
+primOpInfo (IndexByteArrayOp kind)\r
+ = let\r
+ op_str = _PK_ ("index" ++ primRepString kind ++ "Array#")\r
+ (tvs, prim_ty) = mkPrimTyApp alphaTyVars kind\r
+ in\r
+ mkGenPrimOp op_str tvs [byteArrayPrimTy, intPrimTy] prim_ty\r
+\r
+primOpInfo (IndexOffForeignObjOp kind)\r
+ = let\r
+ op_str = _PK_ ("index" ++ primRepString kind ++ "OffForeignObj#")\r
+ (tvs, prim_ty) = mkPrimTyApp alphaTyVars kind\r
+ in\r
+ mkGenPrimOp op_str tvs [foreignObjPrimTy, intPrimTy] prim_ty\r
+\r
+primOpInfo (IndexOffAddrOp kind)\r
+ = let\r
+ op_str = _PK_ ("index" ++ primRepString kind ++ "OffAddr#")\r
+ (tvs, prim_ty) = mkPrimTyApp alphaTyVars kind\r
+ in\r
+ mkGenPrimOp op_str tvs [addrPrimTy, intPrimTy] prim_ty\r
+\r
+primOpInfo (WriteOffAddrOp kind)\r
+ = let\r
+ s = alphaTy; s_tv = alphaTyVar\r
+ op_str = _PK_ ("write" ++ primRepString kind ++ "OffAddr#")\r
+ (tvs, prim_ty) = mkPrimTyApp betaTyVars kind\r
+ in\r
+ mkGenPrimOp op_str (s_tv:tvs)\r
+ [addrPrimTy, intPrimTy, prim_ty, mkStatePrimTy s]\r
+ (mkStatePrimTy s)\r
+\r
+---------------------------------------------------------------------------\r
+{-\r
+unsafeFreezeArray# :: MutArr# s a -> State# s -> (# State# s, Array# a #)\r
+unsafeFreezeByteArray# :: MutByteArr# s -> State# s -> (# State# s, ByteArray# #)\r
+unsafeThawArray# :: Array# a -> State# s -> (# State# s, MutArr# s a #)\r
+unsafeThawByteArray# :: ByteArray# -> State# s -> (# State# s, MutByteArr# s #)\r
+-}\r
+\r
+primOpInfo UnsafeFreezeArrayOp\r
+ = let {\r
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;\r
+ state = mkStatePrimTy s\r
+ } in\r
+ mkGenPrimOp SLIT("unsafeFreezeArray#") [s_tv, elt_tv]\r
+ [mkMutableArrayPrimTy s elt, state]\r
+ (unboxedPair [state, mkArrayPrimTy elt])\r
+\r
+primOpInfo UnsafeFreezeByteArrayOp\r
+ = let { \r
+ s = alphaTy; s_tv = alphaTyVar;\r
+ state = mkStatePrimTy s\r
+ } in\r
+ mkGenPrimOp SLIT("unsafeFreezeByteArray#") [s_tv]\r
+ [mkMutableByteArrayPrimTy s, state]\r
+ (unboxedPair [state, byteArrayPrimTy])\r
+\r
+primOpInfo UnsafeThawArrayOp\r
+ = let {\r
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;\r
+ state = mkStatePrimTy s\r
+ } in\r
+ mkGenPrimOp SLIT("unsafeThawArray#") [s_tv, elt_tv]\r
+ [mkArrayPrimTy elt, state]\r
+ (unboxedPair [state, mkMutableArrayPrimTy s elt])\r
+\r
+primOpInfo UnsafeThawByteArrayOp\r
+ = let { \r
+ s = alphaTy; s_tv = alphaTyVar;\r
+ state = mkStatePrimTy s\r
+ } in\r
+ mkGenPrimOp SLIT("unsafeThawByteArray#") [s_tv]\r
+ [byteArrayPrimTy, state]\r
+ (unboxedPair [state, mkMutableByteArrayPrimTy s])\r
+\r
+---------------------------------------------------------------------------\r
+primOpInfo SizeofByteArrayOp\r
+ = mkGenPrimOp\r
+ SLIT("sizeofByteArray#") []\r
+ [byteArrayPrimTy]\r
+ intPrimTy\r
+\r
+primOpInfo SizeofMutableByteArrayOp\r
+ = let { s = alphaTy; s_tv = alphaTyVar } in\r
+ mkGenPrimOp\r
+ SLIT("sizeofMutableByteArray#") [s_tv]\r
+ [mkMutableByteArrayPrimTy s]\r
+ intPrimTy\r
+\end{code}\r
+\r
+\r
+%************************************************************************\r
+%* *\r
+\subsubsection[PrimOp-MutVars]{PrimOpInfo for mutable variable ops}\r
+%* *\r
+%************************************************************************\r
+\r
+\begin{code}\r
+primOpInfo NewMutVarOp\r
+ = let {\r
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;\r
+ state = mkStatePrimTy s\r
+ } in\r
+ mkGenPrimOp SLIT("newMutVar#") [s_tv, elt_tv] \r
+ [elt, state]\r
+ (unboxedPair [state, mkMutVarPrimTy s elt])\r
+\r
+primOpInfo ReadMutVarOp\r
+ = let {\r
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;\r
+ state = mkStatePrimTy s\r
+ } in\r
+ mkGenPrimOp SLIT("readMutVar#") [s_tv, elt_tv]\r
+ [mkMutVarPrimTy s elt, state]\r
+ (unboxedPair [state, elt])\r
+\r
+\r
+primOpInfo WriteMutVarOp\r
+ = let {\r
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar\r
+ } in\r
+ mkGenPrimOp SLIT("writeMutVar#") [s_tv, elt_tv]\r
+ [mkMutVarPrimTy s elt, elt, mkStatePrimTy s]\r
+ (mkStatePrimTy s)\r
+\r
+primOpInfo SameMutVarOp\r
+ = let {\r
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar;\r
+ mut_var_ty = mkMutVarPrimTy s elt\r
+ } in\r
+ mkGenPrimOp SLIT("sameMutVar#") [s_tv, elt_tv] [mut_var_ty, mut_var_ty]\r
+ boolTy\r
+\end{code}\r
+\r
+%************************************************************************\r
+%* *\r
+\subsubsection[PrimOp-Exceptions]{PrimOpInfo for exceptions}\r
+%* *\r
+%************************************************************************\r
+\r
+catch :: IO a -> (IOError -> IO a) -> IO a\r
+catch# :: a -> (b -> a) -> a\r
+\r
+\begin{code}\r
+primOpInfo CatchOp \r
+ = let\r
+ a = alphaTy; a_tv = alphaTyVar\r
+ b = betaTy; b_tv = betaTyVar;\r
+ in\r
+ mkGenPrimOp SLIT("catch#") [a_tv, b_tv] [a, mkFunTy b a] a\r
+\r
+primOpInfo RaiseOp\r
+ = let\r
+ a = alphaTy; a_tv = alphaTyVar\r
+ b = betaTy; b_tv = betaTyVar;\r
+ in\r
+ mkGenPrimOp SLIT("raise#") [a_tv, b_tv] [a] b\r
+\end{code}\r
+\r
+%************************************************************************\r
+%* *\r
+\subsubsection[PrimOp-MVars]{PrimOpInfo for synchronizing Variables}\r
+%* *\r
+%************************************************************************\r
+\r
+\begin{code}\r
+primOpInfo NewMVarOp\r
+ = let\r
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar\r
+ state = mkStatePrimTy s\r
+ in\r
+ mkGenPrimOp SLIT("newMVar#") [s_tv, elt_tv] [state]\r
+ (unboxedPair [state, mkMVarPrimTy s elt])\r
+\r
+primOpInfo TakeMVarOp\r
+ = let\r
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar\r
+ state = mkStatePrimTy s\r
+ in\r
+ mkGenPrimOp SLIT("takeMVar#") [s_tv, elt_tv]\r
+ [mkMVarPrimTy s elt, state]\r
+ (unboxedPair [state, elt])\r
+\r
+primOpInfo PutMVarOp\r
+ = let\r
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar\r
+ in\r
+ mkGenPrimOp SLIT("putMVar#") [s_tv, elt_tv]\r
+ [mkMVarPrimTy s elt, elt, mkStatePrimTy s]\r
+ (mkStatePrimTy s)\r
+\r
+primOpInfo SameMVarOp\r
+ = let\r
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar\r
+ mvar_ty = mkMVarPrimTy s elt\r
+ in\r
+ mkGenPrimOp SLIT("sameMVar#") [s_tv, elt_tv] [mvar_ty, mvar_ty] boolTy\r
+\r
+primOpInfo IsEmptyMVarOp\r
+ = let\r
+ elt = alphaTy; elt_tv = alphaTyVar; s = betaTy; s_tv = betaTyVar\r
+ state = mkStatePrimTy s\r
+ in\r
+ mkGenPrimOp SLIT("isEmptyMVar#") [s_tv, elt_tv]\r
+ [mkMVarPrimTy s elt, mkStatePrimTy s]\r
+ (unboxedPair [state, intPrimTy])\r
+\r
+\end{code}\r
+\r
+%************************************************************************\r
+%* *\r
+\subsubsection[PrimOp-Wait]{PrimOpInfo for delay/wait operations}\r
+%* *\r
+%************************************************************************\r
+\r
+\begin{code}\r
+\r
+primOpInfo DelayOp\r
+ = let {\r
+ s = alphaTy; s_tv = alphaTyVar\r
+ } in\r
+ mkGenPrimOp SLIT("delay#") [s_tv]\r
+ [intPrimTy, mkStatePrimTy s] (mkStatePrimTy s)\r
+\r
+primOpInfo WaitReadOp\r
+ = let {\r
+ s = alphaTy; s_tv = alphaTyVar\r
+ } in\r
+ mkGenPrimOp SLIT("waitRead#") [s_tv]\r
+ [intPrimTy, mkStatePrimTy s] (mkStatePrimTy s)\r
+\r
+primOpInfo WaitWriteOp\r
+ = let {\r
+ s = alphaTy; s_tv = alphaTyVar\r
+ } in\r
+ mkGenPrimOp SLIT("waitWrite#") [s_tv]\r
+ [intPrimTy, mkStatePrimTy s] (mkStatePrimTy s)\r
+\end{code}\r
+\r
+%************************************************************************\r
+%* *\r
+\subsubsection[PrimOp-Concurrency]{Concurrency Primitives}\r
+%* *\r
+%************************************************************************\r
+\r
+\begin{code}\r
+-- fork# :: a -> State# RealWorld -> (# State# RealWorld, ThreadId# #)\r
+primOpInfo ForkOp \r
+ = mkGenPrimOp SLIT("fork#") [alphaTyVar] \r
+ [alphaTy, realWorldStatePrimTy]\r
+ (unboxedPair [realWorldStatePrimTy, threadIdPrimTy])\r
+\r
+-- killThread# :: ThreadId# -> exception -> State# RealWorld -> State# RealWorld\r
+primOpInfo KillThreadOp\r
+ = mkGenPrimOp SLIT("killThread#") [alphaTyVar] \r
+ [threadIdPrimTy, alphaTy, realWorldStatePrimTy]\r
+ realWorldStatePrimTy\r
+\r
+-- yield# :: State# RealWorld -> State# RealWorld\r
+primOpInfo YieldOp\r
+ = mkGenPrimOp SLIT("yield#") [] \r
+ [realWorldStatePrimTy]\r
+ realWorldStatePrimTy\r
+\r
+-- myThreadId# :: State# RealWorld -> (# State# RealWorld, ThreadId# #)\r
+primOpInfo MyThreadIdOp\r
+ = mkGenPrimOp SLIT("myThreadId#") [] \r
+ [realWorldStatePrimTy]\r
+ (unboxedPair [realWorldStatePrimTy, threadIdPrimTy])\r
+\end{code}\r
+\r
+************************************************************************\r
+%* *\r
+\subsubsection[PrimOps-Foreign]{PrimOpInfo for Foreign Objects}\r
+%* *\r
+%************************************************************************\r
+\r
+\begin{code}\r
+primOpInfo MakeForeignObjOp\r
+ = mkGenPrimOp SLIT("makeForeignObj#") [] \r
+ [addrPrimTy, realWorldStatePrimTy] \r
+ (unboxedPair [realWorldStatePrimTy, foreignObjPrimTy])\r
+\r
+primOpInfo WriteForeignObjOp\r
+ = let {\r
+ s = alphaTy; s_tv = alphaTyVar\r
+ } in\r
+ mkGenPrimOp SLIT("writeForeignObj#") [s_tv]\r
+ [foreignObjPrimTy, addrPrimTy, mkStatePrimTy s] (mkStatePrimTy s)\r
+\end{code}\r
+\r
+************************************************************************\r
+%* *\r
+\subsubsection[PrimOps-Weak]{PrimOpInfo for Weak Pointers}\r
+%* *\r
+%************************************************************************\r
+\r
+A @Weak@ Pointer is created by the @mkWeak#@ primitive:\r
+\r
+ mkWeak# :: k -> v -> f -> State# RealWorld \r
+ -> (# State# RealWorld, Weak# v #)\r
+\r
+In practice, you'll use the higher-level\r
+\r
+ data Weak v = Weak# v\r
+ mkWeak :: k -> v -> IO () -> IO (Weak v)\r
+\r
+\begin{code}\r
+primOpInfo MkWeakOp\r
+ = mkGenPrimOp SLIT("mkWeak#") [alphaTyVar, betaTyVar, gammaTyVar] \r
+ [alphaTy, betaTy, gammaTy, realWorldStatePrimTy]\r
+ (unboxedPair [realWorldStatePrimTy, mkWeakPrimTy betaTy])\r
+\end{code}\r
+\r
+The following operation dereferences a weak pointer. The weak pointer\r
+may have been finalized, so the operation returns a result code which\r
+must be inspected before looking at the dereferenced value.\r
+\r
+ deRefWeak# :: Weak# v -> State# RealWorld ->\r
+ (# State# RealWorld, v, Int# #)\r
+\r
+Only look at v if the Int# returned is /= 0 !!\r
+\r
+The higher-level op is\r
+\r
+ deRefWeak :: Weak v -> IO (Maybe v)\r
+\r
+\begin{code}\r
+primOpInfo DeRefWeakOp\r
+ = mkGenPrimOp SLIT("deRefWeak#") [alphaTyVar]\r
+ [mkWeakPrimTy alphaTy, realWorldStatePrimTy]\r
+ (unboxedTriple [realWorldStatePrimTy, intPrimTy, alphaTy])\r
+\end{code}\r
+\r
+Weak pointers can be finalized early by using the finalize# operation:\r
+ \r
+ finalizeWeak# :: Weak# v -> State# RealWorld -> \r
+ (# State# RealWorld, Int#, IO () #)\r
+\r
+The Int# returned is either\r
+\r
+ 0 if the weak pointer has already been finalized, or it has no\r
+ finalizer (the third component is then invalid).\r
+\r
+ 1 if the weak pointer is still alive, with the finalizer returned\r
+ as the third component.\r
+\r
+\begin{code}\r
+primOpInfo FinalizeWeakOp\r
+ = mkGenPrimOp SLIT("finalizeWeak#") [alphaTyVar]\r
+ [mkWeakPrimTy alphaTy, realWorldStatePrimTy]\r
+ (unboxedTriple [realWorldStatePrimTy, intPrimTy,\r
+ mkFunTy realWorldStatePrimTy \r
+ (unboxedPair [realWorldStatePrimTy,unitTy])])\r
+\end{code}\r
+\r
+%************************************************************************\r
+%* *\r
+\subsubsection[PrimOp-stable-pointers]{PrimOpInfo for stable pointers and stable names}\r
+%* *\r
+%************************************************************************\r
+\r
+A {\em stable name/pointer} is an index into a table of stable name\r
+entries. Since the garbage collector is told about stable pointers,\r
+it is safe to pass a stable pointer to external systems such as C\r
+routines.\r
+\r
+\begin{verbatim}\r
+makeStablePtr# :: a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #)\r
+freeStablePtr :: StablePtr# a -> State# RealWorld -> State# RealWorld\r
+deRefStablePtr# :: StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #)\r
+eqStablePtr# :: StablePtr# a -> StablePtr# a -> Int#\r
+\end{verbatim}\r
+\r
+It may seem a bit surprising that @makeStablePtr#@ is a @IO@\r
+operation since it doesn't (directly) involve IO operations. The\r
+reason is that if some optimisation pass decided to duplicate calls to\r
+@makeStablePtr#@ and we only pass one of the stable pointers over, a\r
+massive space leak can result. Putting it into the IO monad\r
+prevents this. (Another reason for putting them in a monad is to\r
+ensure correct sequencing wrt the side-effecting @freeStablePtr@\r
+operation.)\r
+\r
+An important property of stable pointers is that if you call\r
+makeStablePtr# twice on the same object you get the same stable\r
+pointer back.\r
+\r
+Note that we can implement @freeStablePtr#@ using @_ccall_@ (and,\r
+besides, it's not likely to be used from Haskell) so it's not a\r
+primop.\r
+\r
+Question: Why @RealWorld@ - won't any instance of @_ST@ do the job? [ADR]\r
+\r
+Stable Names\r
+~~~~~~~~~~~~\r
+\r
+A stable name is like a stable pointer, but with three important differences:\r
+\r
+ (a) You can't deRef one to get back to the original object.\r
+ (b) You can convert one to an Int.\r
+ (c) You don't need to 'freeStableName'\r
+\r
+The existence of a stable name doesn't guarantee to keep the object it\r
+points to alive (unlike a stable pointer), hence (a).\r
+\r
+Invariants:\r
+ \r
+ (a) makeStableName always returns the same value for a given\r
+ object (same as stable pointers).\r
+\r
+ (b) if two stable names are equal, it implies that the objects\r
+ from which they were created were the same.\r
+\r
+ (c) stableNameToInt always returns the same Int for a given\r
+ stable name.\r
+\r
+\begin{code}\r
+primOpInfo MakeStablePtrOp\r
+ = mkGenPrimOp SLIT("makeStablePtr#") [alphaTyVar]\r
+ [alphaTy, realWorldStatePrimTy]\r
+ (unboxedPair [realWorldStatePrimTy, \r
+ mkTyConApp stablePtrPrimTyCon [alphaTy]])\r
+\r
+primOpInfo DeRefStablePtrOp\r
+ = mkGenPrimOp SLIT("deRefStablePtr#") [alphaTyVar]\r
+ [mkStablePtrPrimTy alphaTy, realWorldStatePrimTy]\r
+ (unboxedPair [realWorldStatePrimTy, alphaTy])\r
+\r
+primOpInfo EqStablePtrOp\r
+ = mkGenPrimOp SLIT("eqStablePtr#") [alphaTyVar, betaTyVar]\r
+ [mkStablePtrPrimTy alphaTy, mkStablePtrPrimTy betaTy]\r
+ intPrimTy\r
+\r
+primOpInfo MakeStableNameOp\r
+ = mkGenPrimOp SLIT("makeStableName#") [alphaTyVar]\r
+ [alphaTy, realWorldStatePrimTy]\r
+ (unboxedPair [realWorldStatePrimTy, \r
+ mkTyConApp stableNamePrimTyCon [alphaTy]])\r
+\r
+primOpInfo EqStableNameOp\r
+ = mkGenPrimOp SLIT("eqStableName#") [alphaTyVar, betaTyVar]\r
+ [mkStableNamePrimTy alphaTy, mkStableNamePrimTy betaTy]\r
+ intPrimTy\r
+\r
+primOpInfo StableNameToIntOp\r
+ = mkGenPrimOp SLIT("stableNameToInt#") [alphaTyVar]\r
+ [mkStableNamePrimTy alphaTy]\r
+ intPrimTy\r
+\end{code}\r
+\r
+%************************************************************************\r
+%* *\r
+\subsubsection[PrimOp-unsafePointerEquality]{PrimOpInfo for Pointer Equality}\r
+%* *\r
+%************************************************************************\r
+\r
+[Alastair Reid is to blame for this!]\r
+\r
+These days, (Glasgow) Haskell seems to have a bit of everything from\r
+other languages: strict operations, mutable variables, sequencing,\r
+pointers, etc. About the only thing left is LISP's ability to test\r
+for pointer equality. So, let's add it in!\r
+\r
+\begin{verbatim}\r
+reallyUnsafePtrEquality :: a -> a -> Int#\r
+\end{verbatim}\r
+\r
+which tests any two closures (of the same type) to see if they're the\r
+same. (Returns $0$ for @False@, $\neq 0$ for @True@ - to avoid\r
+difficulties of trying to box up the result.)\r
+\r
+NB This is {\em really unsafe\/} because even something as trivial as\r
+a garbage collection might change the answer by removing indirections.\r
+Still, no-one's forcing you to use it. If you're worried about little\r
+things like loss of referential transparency, you might like to wrap\r
+it all up in a monad-like thing as John O'Donnell and John Hughes did\r
+for non-determinism (1989 (Fraserburgh) Glasgow FP Workshop\r
+Proceedings?)\r
+\r
+I'm thinking of using it to speed up a critical equality test in some\r
+graphics stuff in a context where the possibility of saying that\r
+denotationally equal things aren't isn't a problem (as long as it\r
+doesn't happen too often.) ADR\r
+\r
+To Will: Jim said this was already in, but I can't see it so I'm\r
+adding it. Up to you whether you add it. (Note that this could have\r
+been readily implemented using a @veryDangerousCCall@ before they were\r
+removed...)\r
+\r
+\begin{code}\r
+primOpInfo ReallyUnsafePtrEqualityOp\r
+ = mkGenPrimOp SLIT("reallyUnsafePtrEquality#") [alphaTyVar]\r
+ [alphaTy, alphaTy] intPrimTy\r
+\end{code}\r
+\r
+%************************************************************************\r
+%* *\r
+\subsubsection[PrimOp-parallel]{PrimOpInfo for parallelism op(s)}\r
+%* *\r
+%************************************************************************\r
+\r
+\begin{code}\r
+primOpInfo SeqOp -- seq# :: a -> Int#\r
+ = mkGenPrimOp SLIT("seq#") [alphaTyVar] [alphaTy] intPrimTy\r
+\r
+primOpInfo ParOp -- par# :: a -> Int#\r
+ = mkGenPrimOp SLIT("par#") [alphaTyVar] [alphaTy] intPrimTy\r
+\end{code}\r
+\r
+\begin{code}\r
+-- HWL: The first 4 Int# in all par... annotations denote:\r
+-- name, granularity info, size of result, degree of parallelism\r
+-- Same structure as _seq_ i.e. returns Int#\r
+-- KSW: v, the second arg in parAt# and parAtForNow#, is used only to determine\r
+-- `the processor containing the expression v'; it is not evaluated\r
+\r
+primOpInfo ParGlobalOp -- parGlobal# :: a -> Int# -> Int# -> Int# -> Int# -> b -> Int#\r
+ = mkGenPrimOp SLIT("parGlobal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy\r
+\r
+primOpInfo ParLocalOp -- parLocal# :: a -> Int# -> Int# -> Int# -> Int# -> b -> Int#\r
+ = mkGenPrimOp SLIT("parLocal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy\r
+\r
+primOpInfo ParAtOp -- parAt# :: a -> v -> Int# -> Int# -> Int# -> Int# -> b -> Int#\r
+ = mkGenPrimOp SLIT("parAt#") [alphaTyVar,betaTyVar,gammaTyVar] [betaTy,alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] intPrimTy\r
+\r
+primOpInfo ParAtAbsOp -- parAtAbs# :: a -> Int# -> Int# -> Int# -> Int# -> Int# -> b -> Int#\r
+ = mkGenPrimOp SLIT("parAtAbs#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy\r
+\r
+primOpInfo ParAtRelOp -- parAtRel# :: a -> Int# -> Int# -> Int# -> Int# -> Int# -> b -> Int#\r
+ = mkGenPrimOp SLIT("parAtRel#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTy\r
+\r
+primOpInfo ParAtForNowOp -- parAtForNow# :: a -> v -> Int# -> Int# -> Int# -> Int# -> b -> Int#\r
+ = mkGenPrimOp SLIT("parAtForNow#") [alphaTyVar,betaTyVar,gammaTyVar] [betaTy,alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] intPrimTy\r
+\r
+primOpInfo CopyableOp -- copyable# :: a -> Int#\r
+ = mkGenPrimOp SLIT("copyable#") [alphaTyVar] [alphaTy] intPrimTy\r
+\r
+primOpInfo NoFollowOp -- noFollow# :: a -> Int#\r
+ = mkGenPrimOp SLIT("noFollow#") [alphaTyVar] [alphaTy] intPrimTy\r
+\end{code}\r
+\r
+%************************************************************************\r
+%* *\r
+\subsubsection[PrimOp-IO-etc]{PrimOpInfo for C calls, and I/O-ish things}\r
+%* *\r
+%************************************************************************\r
+\r
+\begin{code}\r
+primOpInfo (CCallOp _ _ _ _)\r
+ = mkGenPrimOp SLIT("ccall#") [alphaTyVar] [] alphaTy\r
+\r
+{-\r
+primOpInfo (CCallOp _ _ _ _ arg_tys result_ty)\r
+ = mkGenPrimOp SLIT("ccall#") [] arg_tys result_tycon tys_applied\r
+ where\r
+ (result_tycon, tys_applied, _) = splitAlgTyConApp result_ty\r
+-}\r
+\end{code}\r
+\r
+%************************************************************************\r
+%* *\r
+\subsubsection[PrimOp-tag]{PrimOpInfo for @dataToTag#@ and @tagToEnum#@}\r
+%* *\r
+%************************************************************************\r
+\r
+These primops are pretty wierd.\r
+\r
+ dataToTag# :: a -> Int (arg must be an evaluated data type)\r
+ tagToEnum# :: Int -> a (result type must be an enumerated type)\r
+\r
+The constraints aren't currently checked by the front end, but the\r
+code generator will fall over if they aren't satisfied.\r
+\r
+\begin{code}\r
+primOpInfo DataToTagOp\r
+ = mkGenPrimOp SLIT("dataToTag#") [alphaTyVar] [alphaTy] intPrimTy\r
+\r
+primOpInfo TagToEnumOp\r
+ = mkGenPrimOp SLIT("tagToEnum#") [alphaTyVar] [intPrimTy] alphaTy\r
+\r
+#ifdef DEBUG\r
+primOpInfo op = panic ("primOpInfo:"++ show (I# (tagOf_PrimOp op)))\r
+#endif\r
+\end{code}\r
+\r
+%************************************************************************\r
+%* *\r
+\subsubsection[PrimOp-ool]{Which PrimOps are out-of-line}\r
+%* *\r
+%************************************************************************\r
+\r
+Some PrimOps need to be called out-of-line because they either need to\r
+perform a heap check or they block.\r
+\r
+\begin{code}\r
+primOpOutOfLine op\r
+ = case op of\r
+ TakeMVarOp -> True\r
+ PutMVarOp -> True\r
+ DelayOp -> True\r
+ WaitReadOp -> True\r
+ WaitWriteOp -> True\r
+ CatchOp -> True\r
+ RaiseOp -> True\r
+ NewArrayOp -> True\r
+ NewByteArrayOp _ -> True\r
+ IntegerAddOp -> True\r
+ IntegerSubOp -> True\r
+ IntegerMulOp -> True\r
+ IntegerGcdOp -> True\r
+ IntegerQuotRemOp -> True\r
+ IntegerDivModOp -> True\r
+ Int2IntegerOp -> True\r
+ Word2IntegerOp -> True\r
+ Addr2IntegerOp -> True\r
+ Word64ToIntegerOp -> True\r
+ Int64ToIntegerOp -> True\r
+ FloatDecodeOp -> True\r
+ DoubleDecodeOp -> True\r
+ MkWeakOp -> True\r
+ FinalizeWeakOp -> True\r
+ MakeStableNameOp -> True\r
+ MakeForeignObjOp -> True\r
+ NewMutVarOp -> True\r
+ NewMVarOp -> True\r
+ ForkOp -> True\r
+ KillThreadOp -> True\r
+ YieldOp -> True\r
+ CCallOp _ _ may_gc@True _ -> True -- _ccall_GC_\r
+ -- the next one doesn't perform any heap checks,\r
+ -- but it is of such an esoteric nature that\r
+ -- it is done out-of-line rather than require\r
+ -- the NCG to implement it.\r
+ UnsafeThawArrayOp -> True\r
+ _ -> False\r
+\end{code}\r
+\r
+Sometimes we may choose to execute a PrimOp even though it isn't\r
+certain that its result will be required; ie execute them\r
+``speculatively''. The same thing as ``cheap eagerness.'' Usually\r
+this is OK, because PrimOps are usually cheap, but it isn't OK for\r
+(a)~expensive PrimOps and (b)~PrimOps which can fail.\r
+\r
+See also @primOpIsCheap@ (below).\r
+\r
+PrimOps that have side effects also should not be executed speculatively\r
+or by data dependencies.\r
+\r
+\begin{code}\r
+primOpOkForSpeculation :: PrimOp -> Bool\r
+primOpOkForSpeculation op \r
+ = not (primOpCanFail op || primOpHasSideEffects op || primOpOutOfLine op)\r
+\end{code}\r
+\r
+@primOpIsCheap@, as used in \tr{SimplUtils.lhs}. For now (HACK\r
+WARNING), we just borrow some other predicates for a\r
+what-should-be-good-enough test. "Cheap" means willing to call it more\r
+than once. Evaluation order is unaffected.\r
+\r
+\begin{code}\r
+primOpIsCheap op = not (primOpHasSideEffects op || primOpOutOfLine op)\r
+\end{code}\r
+\r
+primOpIsDupable means that the use of the primop is small enough to\r
+duplicate into different case branches. See CoreUtils.exprIsDupable.\r
+\r
+\begin{code}\r
+primOpIsDupable (CCallOp _ _ _ _) = False\r
+primOpIsDupable op = not (primOpOutOfLine op)\r
+\end{code}\r
+\r
+\r
+\begin{code}\r
+primOpCanFail :: PrimOp -> Bool\r
+-- Int.\r
+primOpCanFail IntQuotOp = True -- Divide by zero\r
+primOpCanFail IntRemOp = True -- Divide by zero\r
+\r
+-- Integer\r
+primOpCanFail IntegerQuotRemOp = True -- Divide by zero\r
+primOpCanFail IntegerDivModOp = True -- Divide by zero\r
+\r
+-- Float. ToDo: tan? tanh?\r
+primOpCanFail FloatDivOp = True -- Divide by zero\r
+primOpCanFail FloatLogOp = True -- Log of zero\r
+primOpCanFail FloatAsinOp = True -- Arg out of domain\r
+primOpCanFail FloatAcosOp = True -- Arg out of domain\r
+\r
+-- Double. ToDo: tan? tanh?\r
+primOpCanFail DoubleDivOp = True -- Divide by zero\r
+primOpCanFail DoubleLogOp = True -- Log of zero\r
+primOpCanFail DoubleAsinOp = True -- Arg out of domain\r
+primOpCanFail DoubleAcosOp = True -- Arg out of domain\r
+\r
+primOpCanFail other_op = False\r
+\end{code}\r
+\r
+And some primops have side-effects and so, for example, must not be\r
+duplicated.\r
+\r
+\begin{code}\r
+primOpHasSideEffects :: PrimOp -> Bool\r
+\r
+primOpHasSideEffects TakeMVarOp = True\r
+primOpHasSideEffects DelayOp = True\r
+primOpHasSideEffects WaitReadOp = True\r
+primOpHasSideEffects WaitWriteOp = True\r
+\r
+primOpHasSideEffects ParOp = True\r
+primOpHasSideEffects ForkOp = True\r
+primOpHasSideEffects KillThreadOp = True\r
+primOpHasSideEffects YieldOp = True\r
+primOpHasSideEffects SeqOp = True\r
+\r
+primOpHasSideEffects MakeForeignObjOp = True\r
+primOpHasSideEffects WriteForeignObjOp = True\r
+primOpHasSideEffects MkWeakOp = True\r
+primOpHasSideEffects DeRefWeakOp = True\r
+primOpHasSideEffects FinalizeWeakOp = True\r
+primOpHasSideEffects MakeStablePtrOp = True\r
+primOpHasSideEffects MakeStableNameOp = True\r
+primOpHasSideEffects EqStablePtrOp = True -- SOF\r
+primOpHasSideEffects DeRefStablePtrOp = True -- ??? JSM & ADR\r
+\r
+primOpHasSideEffects ParGlobalOp = True\r
+primOpHasSideEffects ParLocalOp = True\r
+primOpHasSideEffects ParAtOp = True\r
+primOpHasSideEffects ParAtAbsOp = True\r
+primOpHasSideEffects ParAtRelOp = True\r
+primOpHasSideEffects ParAtForNowOp = True\r
+primOpHasSideEffects CopyableOp = True -- Possibly not. ASP \r
+primOpHasSideEffects NoFollowOp = True -- Possibly not. ASP\r
+\r
+-- CCall\r
+primOpHasSideEffects (CCallOp _ _ _ _) = True\r
+\r
+primOpHasSideEffects other = False\r
+\end{code}\r
+\r
+Inline primitive operations that perform calls need wrappers to save\r
+any live variables that are stored in caller-saves registers.\r
+\r
+\begin{code}\r
+primOpNeedsWrapper :: PrimOp -> Bool\r
+\r
+primOpNeedsWrapper (CCallOp _ _ _ _) = True\r
+\r
+primOpNeedsWrapper Integer2IntOp = True\r
+primOpNeedsWrapper Integer2WordOp = True\r
+primOpNeedsWrapper IntegerCmpOp = True\r
+primOpNeedsWrapper IntegerCmpIntOp = True\r
+\r
+primOpNeedsWrapper FloatExpOp = True\r
+primOpNeedsWrapper FloatLogOp = True\r
+primOpNeedsWrapper FloatSqrtOp = True\r
+primOpNeedsWrapper FloatSinOp = True\r
+primOpNeedsWrapper FloatCosOp = True\r
+primOpNeedsWrapper FloatTanOp = True\r
+primOpNeedsWrapper FloatAsinOp = True\r
+primOpNeedsWrapper FloatAcosOp = True\r
+primOpNeedsWrapper FloatAtanOp = True\r
+primOpNeedsWrapper FloatSinhOp = True\r
+primOpNeedsWrapper FloatCoshOp = True\r
+primOpNeedsWrapper FloatTanhOp = True\r
+primOpNeedsWrapper FloatPowerOp = True\r
+\r
+primOpNeedsWrapper DoubleExpOp = True\r
+primOpNeedsWrapper DoubleLogOp = True\r
+primOpNeedsWrapper DoubleSqrtOp = True\r
+primOpNeedsWrapper DoubleSinOp = True\r
+primOpNeedsWrapper DoubleCosOp = True\r
+primOpNeedsWrapper DoubleTanOp = True\r
+primOpNeedsWrapper DoubleAsinOp = True\r
+primOpNeedsWrapper DoubleAcosOp = True\r
+primOpNeedsWrapper DoubleAtanOp = True\r
+primOpNeedsWrapper DoubleSinhOp = True\r
+primOpNeedsWrapper DoubleCoshOp = True\r
+primOpNeedsWrapper DoubleTanhOp = True\r
+primOpNeedsWrapper DoublePowerOp = True\r
+\r
+primOpNeedsWrapper MakeStableNameOp = True\r
+primOpNeedsWrapper DeRefStablePtrOp = True\r
+\r
+primOpNeedsWrapper DelayOp = True\r
+primOpNeedsWrapper WaitReadOp = True\r
+primOpNeedsWrapper WaitWriteOp = True\r
+\r
+primOpNeedsWrapper other_op = False\r
+\end{code}\r
+\r
+\begin{code}\r
+primOpType :: PrimOp -> Type -- you may want to use primOpSig instead\r
+primOpType op\r
+ = case (primOpInfo op) of\r
+ Dyadic occ ty -> dyadic_fun_ty ty\r
+ Monadic occ ty -> monadic_fun_ty ty\r
+ Compare occ ty -> compare_fun_ty ty\r
+\r
+ GenPrimOp occ tyvars arg_tys res_ty -> \r
+ mkForAllTys tyvars (mkFunTys arg_tys res_ty)\r
+\r
+mkPrimOpIdName :: PrimOp -> Id -> Name\r
+ -- Make the name for the PrimOp's Id\r
+ -- We have to pass in the Id itself because it's a WiredInId\r
+ -- and hence recursive\r
+mkPrimOpIdName op id\r
+ = mkWiredInIdName key pREL_GHC occ_name id\r
+ where\r
+ occ_name = primOpOcc op\r
+ key = mkPrimOpIdUnique (IBOX(tagOf_PrimOp op))\r
+\r
+\r
+primOpRdrName :: PrimOp -> RdrName \r
+primOpRdrName op = mkRdrQual pREL_GHC_Name (primOpOcc op)\r
+\r
+primOpOcc :: PrimOp -> OccName\r
+primOpOcc op = case (primOpInfo op) of\r
+ Dyadic occ _ -> occ\r
+ Monadic occ _ -> occ\r
+ Compare occ _ -> occ\r
+ GenPrimOp occ _ _ _ -> occ\r
+\r
+-- primOpSig is like primOpType but gives the result split apart:\r
+-- (type variables, argument types, result type)\r
+\r
+primOpSig :: PrimOp -> ([TyVar],[Type],Type)\r
+primOpSig op\r
+ = case (primOpInfo op) of\r
+ Monadic occ ty -> ([], [ty], ty )\r
+ Dyadic occ ty -> ([], [ty,ty], ty )\r
+ Compare occ ty -> ([], [ty,ty], boolTy)\r
+ GenPrimOp occ tyvars arg_tys res_ty\r
+ -> (tyvars, arg_tys, res_ty)\r
+\r
+-- primOpUsg is like primOpSig but the types it yields are the\r
+-- appropriate sigma (i.e., usage-annotated) types,\r
+-- as required by the UsageSP inference.\r
+\r
+primOpUsg :: PrimOp -> ([TyVar],[Type],Type)\r
+primOpUsg op\r
+ = case op of\r
+\r
+ -- Refer to comment by `otherwise' clause; we need consider here\r
+ -- *only* primops that have arguments or results containing Haskell\r
+ -- pointers (things that are pointed). Unpointed values are\r
+ -- irrelevant to the usage analysis. The issue is whether pointed\r
+ -- values may be entered or duplicated by the primop.\r
+\r
+ -- Remember that primops are *never* partially applied.\r
+\r
+ NewArrayOp -> mangle [mkP, mkM, mkP ] mkM\r
+ SameMutableArrayOp -> mangle [mkP, mkP ] mkM\r
+ ReadArrayOp -> mangle [mkM, mkP, mkP ] mkM\r
+ WriteArrayOp -> mangle [mkM, mkP, mkM, mkP] mkR\r
+ IndexArrayOp -> mangle [mkM, mkP ] mkM\r
+ UnsafeFreezeArrayOp -> mangle [mkM, mkP ] mkM\r
+ UnsafeThawArrayOp -> mangle [mkM, mkP ] mkM\r
+\r
+ NewMutVarOp -> mangle [mkM, mkP ] mkM\r
+ ReadMutVarOp -> mangle [mkM, mkP ] mkM\r
+ WriteMutVarOp -> mangle [mkM, mkM, mkP ] mkR\r
+ SameMutVarOp -> mangle [mkP, mkP ] mkM\r
+\r
+ CatchOp -> -- [mkO, mkO . (inFun mkM mkO)] mkO\r
+ mangle [mkM, mkM . (inFun mkM mkM)] mkM\r
+ -- might use caught action multiply\r
+ RaiseOp -> mangle [mkM ] mkM\r
+\r
+ NewMVarOp -> mangle [mkP ] mkR\r
+ TakeMVarOp -> mangle [mkM, mkP ] mkM\r
+ PutMVarOp -> mangle [mkM, mkM, mkP ] mkR\r
+ SameMVarOp -> mangle [mkP, mkP ] mkM\r
+ IsEmptyMVarOp -> mangle [mkP, mkP ] mkM\r
+\r
+ ForkOp -> mangle [mkO, mkP ] mkR\r
+ KillThreadOp -> mangle [mkP, mkM, mkP ] mkR\r
+\r
+ MkWeakOp -> mangle [mkZ, mkM, mkM, mkP] mkM\r
+ DeRefWeakOp -> mangle [mkM, mkP ] mkM\r
+ FinalizeWeakOp -> mangle [mkM, mkP ] (mkR . (inUB [id,id,inFun mkR mkM]))\r
+\r
+ MakeStablePtrOp -> mangle [mkM, mkP ] mkM\r
+ DeRefStablePtrOp -> mangle [mkM, mkP ] mkM\r
+ EqStablePtrOp -> mangle [mkP, mkP ] mkR\r
+ MakeStableNameOp -> mangle [mkZ, mkP ] mkR\r
+ EqStableNameOp -> mangle [mkP, mkP ] mkR\r
+ StableNameToIntOp -> mangle [mkP ] mkR\r
+\r
+ ReallyUnsafePtrEqualityOp -> mangle [mkZ, mkZ ] mkR\r
+\r
+ SeqOp -> mangle [mkO ] mkR\r
+ ParOp -> mangle [mkO ] mkR\r
+ ParGlobalOp -> mangle [mkO, mkP, mkP, mkP, mkP, mkM] mkM\r
+ ParLocalOp -> mangle [mkO, mkP, mkP, mkP, mkP, mkM] mkM\r
+ ParAtOp -> mangle [mkO, mkZ, mkP, mkP, mkP, mkP, mkM] mkM\r
+ ParAtAbsOp -> mangle [mkO, mkP, mkP, mkP, mkP, mkM] mkM\r
+ ParAtRelOp -> mangle [mkO, mkP, mkP, mkP, mkP, mkM] mkM\r
+ ParAtForNowOp -> mangle [mkO, mkZ, mkP, mkP, mkP, mkP, mkM] mkM\r
+ CopyableOp -> mangle [mkZ ] mkR\r
+ NoFollowOp -> mangle [mkZ ] mkR\r
+\r
+ CCallOp _ _ _ _ -> mangle [ ] mkM\r
+\r
+ -- Things with no Haskell pointers inside: in actuality, usages are\r
+ -- irrelevant here (hence it doesn't matter that some of these\r
+ -- apparently permit duplication; since such arguments are never \r
+ -- ENTERed anyway, the usage annotation they get is entirely irrelevant\r
+ -- except insofar as it propagates to infect other values that *are*\r
+ -- pointed.\r
+\r
+ otherwise -> nomangle\r
+ \r
+ where mkZ = mkUsgTy UsOnce -- pointed argument used zero\r
+ mkO = mkUsgTy UsOnce -- pointed argument used once\r
+ mkM = mkUsgTy UsMany -- pointed argument used multiply\r
+ mkP = mkUsgTy UsOnce -- unpointed argument\r
+ mkR = mkUsgTy UsMany -- unpointed result\r
+ \r
+ (tyvars, arg_tys, res_ty)\r
+ = primOpSig op\r
+\r
+ nomangle = (tyvars, map mkP arg_tys, mkR res_ty)\r
+\r
+ mangle fs g = (tyvars, zipWithEqual "primOpUsg" ($) fs arg_tys, g res_ty)\r
+\r
+ inFun f g ty = case splitFunTy_maybe ty of\r
+ Just (a,b) -> mkFunTy (f a) (g b)\r
+ Nothing -> pprPanic "primOpUsg:inFun" (ppr op <+> ppr ty)\r
+\r
+ inUB fs ty = case splitTyConApp_maybe ty of\r
+ Just (tc,tys) -> ASSERT( tc == unboxedTupleTyCon (length fs) )\r
+ mkUnboxedTupleTy (length fs) (zipWithEqual "primOpUsg"\r
+ ($) fs tys)\r
+ Nothing -> pprPanic "primOpUsg:inUB" (ppr op <+> ppr ty)\r
+\end{code}\r
+\r
+\begin{code}\r
+data PrimOpResultInfo\r
+ = ReturnsPrim PrimRep\r
+ | ReturnsAlg TyCon\r
+\r
+-- Some PrimOps need not return a manifest primitive or algebraic value\r
+-- (i.e. they might return a polymorphic value). These PrimOps *must*\r
+-- be out of line, or the code generator won't work.\r
+\r
+getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo\r
+getPrimOpResultInfo op\r
+ = case (primOpInfo op) of\r
+ Dyadic _ ty -> ReturnsPrim (typePrimRep ty)\r
+ Monadic _ ty -> ReturnsPrim (typePrimRep ty)\r
+ Compare _ ty -> ReturnsAlg boolTyCon\r
+ GenPrimOp _ _ _ ty -> \r
+ let rep = typePrimRep ty in\r
+ case rep of\r
+ PtrRep -> case splitAlgTyConApp_maybe ty of\r
+ Nothing -> panic "getPrimOpResultInfo"\r
+ Just (tc,_,_) -> ReturnsAlg tc\r
+ other -> ReturnsPrim other\r
+\r
+isCompareOp :: PrimOp -> Bool\r
+isCompareOp op\r
+ = case primOpInfo op of\r
+ Compare _ _ -> True\r
+ _ -> False\r
+\end{code}\r
+\r
+The commutable ops are those for which we will try to move constants\r
+to the right hand side for strength reduction.\r
+\r
+\begin{code}\r
+commutableOp :: PrimOp -> Bool\r
+\r
+commutableOp CharEqOp = True\r
+commutableOp CharNeOp = True\r
+commutableOp IntAddOp = True\r
+commutableOp IntMulOp = True\r
+commutableOp AndOp = True\r
+commutableOp OrOp = True\r
+commutableOp XorOp = True\r
+commutableOp IntEqOp = True\r
+commutableOp IntNeOp = True\r
+commutableOp IntegerAddOp = True\r
+commutableOp IntegerMulOp = True\r
+commutableOp IntegerGcdOp = True\r
+commutableOp FloatAddOp = True\r
+commutableOp FloatMulOp = True\r
+commutableOp FloatEqOp = True\r
+commutableOp FloatNeOp = True\r
+commutableOp DoubleAddOp = True\r
+commutableOp DoubleMulOp = True\r
+commutableOp DoubleEqOp = True\r
+commutableOp DoubleNeOp = True\r
+commutableOp _ = False\r
+\end{code}\r
+\r
+Utils:\r
+\begin{code}\r
+mkPrimTyApp :: [TyVar] -> PrimRep -> ([TyVar], Type)\r
+ -- CharRep --> ([], Char#)\r
+ -- StablePtrRep --> ([a], StablePtr# a)\r
+mkPrimTyApp tvs kind\r
+ = (forall_tvs, mkTyConApp tycon (mkTyVarTys forall_tvs))\r
+ where\r
+ tycon = primRepTyCon kind\r
+ forall_tvs = take (tyConArity tycon) tvs\r
+\r
+dyadic_fun_ty ty = mkFunTys [ty, ty] ty\r
+monadic_fun_ty ty = mkFunTy ty ty\r
+compare_fun_ty ty = mkFunTys [ty, ty] boolTy\r
+\end{code}\r
+\r
+Output stuff:\r
+\begin{code}\r
+pprPrimOp :: PrimOp -> SDoc\r
+\r
+pprPrimOp (CCallOp fun is_casm may_gc cconv)\r
+ = let\r
+ callconv = text "{-" <> pprCallConv cconv <> text "-}"\r
+\r
+ before\r
+ | is_casm && may_gc = "casm_GC ``"\r
+ | is_casm = "casm ``"\r
+ | may_gc = "ccall_GC "\r
+ | otherwise = "ccall "\r
+\r
+ after\r
+ | is_casm = text "''"\r
+ | otherwise = empty\r
+ \r
+ ppr_dyn =\r
+ case fun of\r
+ Right _ -> text "dyn_"\r
+ _ -> empty\r
+\r
+ ppr_fun =\r
+ case fun of\r
+ Right _ -> text "\"\""\r
+ Left fn -> ptext fn\r
+ \r
+ in\r
+ hcat [ ifPprDebug callconv\r
+ , text "__", ppr_dyn\r
+ , text before , ppr_fun , after]\r
+\r
+pprPrimOp other_op\r
+ = getPprStyle $ \ sty ->\r
+ if ifaceStyle sty then -- For interfaces Print it qualified with PrelGHC.\r
+ ptext SLIT("PrelGHC.") <> pprOccName occ\r
+ else\r
+ pprOccName occ\r
+ where\r
+ occ = primOpOcc other_op\r
+\end{code}\r
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section[SimplCore]{Driver for simplifying @Core@ programs}
-
-\begin{code}
-module SimplCore ( core2core ) where
-
-#include "HsVersions.h"
-
-import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..),
- SwitchResult(..), switchIsOn, intSwitchSet,
- opt_D_dump_occur_anal, opt_D_dump_rules,
- opt_D_dump_simpl_iterations,
- opt_D_dump_simpl_stats,
- opt_D_dump_simpl, opt_D_dump_rules,
- opt_D_verbose_core2core,
- opt_D_dump_occur_anal,
- opt_UsageSPOn,
- )
-import CoreLint ( beginPass, endPass )
-import CoreTidy ( tidyCorePgm )
-import CoreSyn
-import Rules ( RuleBase, ProtoCoreRule(..), pprProtoCoreRule, prepareRuleBase, orphanRule )
-import CoreUnfold
-import PprCore ( pprCoreBindings )
-import OccurAnal ( occurAnalyseBinds )
-import CoreUtils ( exprIsTrivial, coreExprType )
-import Simplify ( simplTopBinds, simplExpr )
-import SimplUtils ( etaCoreExpr, findDefault, simplBinders )
-import SimplMonad
-import Const ( Con(..), Literal(..), literalType, mkMachInt )
-import ErrUtils ( dumpIfSet )
-import FloatIn ( floatInwards )
-import FloatOut ( floatOutwards )
-import Id ( Id, mkSysLocal, mkVanillaId, isBottomingId,
- idType, setIdType, idName, idInfo, setIdNoDiscard
- )
-import IdInfo ( InlinePragInfo(..), specInfo, setSpecInfo,
- inlinePragInfo, setInlinePragInfo,
- setUnfoldingInfo, setDemandInfo
- )
-import Demand ( wwLazy )
-import VarEnv
-import VarSet
-import Module ( Module )
-import Name ( mkLocalName, tidyOccName, tidyTopName,
- NamedThing(..), OccName
- )
-import TyCon ( TyCon, isDataTyCon )
-import PrimOp ( PrimOp(..) )
-import PrelInfo ( unpackCStringId, unpackCString2Id, addr2IntegerId )
-import Type ( Type, splitAlgTyConApp_maybe,
- isUnLiftedType,
- tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,
- Type
- )
-import TysWiredIn ( smallIntegerDataCon, isIntegerTy )
-import LiberateCase ( liberateCase )
-import SAT ( doStaticArgs )
-import Specialise ( specProgram)
-import UsageSPInf ( doUsageSPInf )
-import StrictAnal ( saBinds )
-import WorkWrap ( wwTopBinds )
-import CprAnalyse ( cprAnalyse )
-
-import Unique ( Unique, Uniquable(..),
- ratioTyConKey
- )
-import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupply )
-import Constants ( tARGET_MIN_INT, tARGET_MAX_INT )
-import Util ( mapAccumL )
-import SrcLoc ( noSrcLoc )
-import Bag
-import Maybes
-import IO ( hPutStr, stderr )
-import Outputable
-
-import Ratio ( numerator, denominator )
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{The driver for the simplifier}
-%* *
-%************************************************************************
-
-\begin{code}
-core2core :: [CoreToDo] -- Spec of what core-to-core passes to do
- -> [CoreBind] -- Binds in
- -> [ProtoCoreRule] -- Rules
- -> IO ([CoreBind], [ProtoCoreRule])
-
-core2core core_todos binds rules
- = do
- us <- mkSplitUniqSupply 's'
- let (cp_us, us1) = splitUniqSupply us
- (ru_us, ps_us) = splitUniqSupply us1
-
- better_rules <- simplRules ru_us rules binds
-
- let (binds1, rule_base) = prepareRuleBase binds better_rules
-
- -- Do the main business
- (stats, processed_binds) <- doCorePasses zeroSimplCount cp_us binds1
- rule_base core_todos
-
- dumpIfSet opt_D_dump_simpl_stats
- "Grand total simplifier statistics"
- (pprSimplCount stats)
-
- -- Do the post-simplification business
- post_simpl_binds <- doPostSimplification ps_us processed_binds
-
- -- Return results
- return (post_simpl_binds, filter orphanRule better_rules)
-
-
-doCorePasses stats us binds irs []
- = return (stats, binds)
-
-doCorePasses stats us binds irs (to_do : to_dos)
- = do
- let (us1, us2) = splitUniqSupply us
- (stats1, binds1) <- doCorePass us1 binds irs to_do
- doCorePasses (stats `plusSimplCount` stats1) us2 binds1 irs to_dos
-
-doCorePass us binds rb (CoreDoSimplify sw_chkr) = _scc_ "Simplify" simplifyPgm rb sw_chkr us binds
-doCorePass us binds rb CoreLiberateCase = _scc_ "LiberateCase" noStats (liberateCase binds)
-doCorePass us binds rb CoreDoFloatInwards = _scc_ "FloatInwards" noStats (floatInwards binds)
-doCorePass us binds rb CoreDoFullLaziness = _scc_ "FloatOutwards" noStats (floatOutwards us binds)
-doCorePass us binds rb CoreDoStaticArgs = _scc_ "StaticArgs" noStats (doStaticArgs us binds)
-doCorePass us binds rb CoreDoStrictness = _scc_ "Stranal" noStats (saBinds binds)
-doCorePass us binds rb CoreDoWorkerWrapper = _scc_ "WorkWrap" noStats (wwTopBinds us binds)
-doCorePass us binds rb CoreDoSpecialising = _scc_ "Specialise" noStats (specProgram us binds)
-doCorePass us binds rb CoreDoCPResult = _scc_ "CPResult" noStats (cprAnalyse binds)
-doCorePass us binds rb CoreDoPrintCore = _scc_ "PrintCore" noStats (printCore binds)
-doCorePass us binds rb CoreDoUSPInf
- = _scc_ "CoreUsageSPInf"
- if opt_UsageSPOn then
- noStats (doUsageSPInf us binds)
- else
- trace "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on" $
- noStats (return binds)
-
-printCore binds = do dumpIfSet True "Print Core"
- (pprCoreBindings binds)
- return binds
-
-noStats thing = do { result <- thing; return (zeroSimplCount, result) }
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Dealing with rules}
-%* *
-%************************************************************************
-
-We must do some gentle simplifiation on the template (but not the RHS)
-of each rule. The case that forced me to add this was the fold/build rule,
-which without simplification looked like:
- fold k z (build (/\a. g a)) ==> ...
-This doesn't match unless you do eta reduction on the build argument.
-
-\begin{code}
-simplRules :: UniqSupply -> [ProtoCoreRule] -> [CoreBind] -> IO [ProtoCoreRule]
-simplRules us rules binds
- = do let (better_rules,_) = initSmpl sw_chkr us bind_vars black_list_all (mapSmpl simplRule rules)
-
- dumpIfSet opt_D_dump_rules
- "Transformation rules"
- (vcat (map pprProtoCoreRule better_rules))
-
- return better_rules
- where
- black_list_all v = True -- This stops all inlining
- sw_chkr any = SwBool False -- A bit bogus
-
- -- Boringly, we need to gather the in-scope set.
- -- Typically this thunk won't even be force, but the test in
- -- simpVar fails if it isn't right, and it might conceivably matter
- bind_vars = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
-
-
-simplRule rule@(ProtoCoreRule is_local id (Rule name bndrs args rhs))
- | not is_local
- = returnSmpl rule -- No need to fiddle with imported rules
- | otherwise
- = simplBinders bndrs $ \ bndrs' ->
- mapSmpl simplExpr args `thenSmpl` \ args' ->
- simplExpr rhs `thenSmpl` \ rhs' ->
- returnSmpl (ProtoCoreRule is_local id (Rule name bndrs' args' rhs'))
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{The driver for the simplifier}
-%* *
-%************************************************************************
-
-\begin{code}
-simplifyPgm :: RuleBase
- -> (SimplifierSwitch -> SwitchResult)
- -> UniqSupply
- -> [CoreBind] -- Input
- -> IO (SimplCount, [CoreBind]) -- New bindings
-
-simplifyPgm (imported_rule_ids, rule_lhs_fvs)
- sw_chkr us binds
- = do {
- beginPass "Simplify";
-
- -- Glom all binds together in one Rec, in case any
- -- transformations have introduced any new dependencies
- let { recd_binds = [Rec (flattenBinds binds)] };
-
- (termination_msg, it_count, counts_out, binds') <- iteration us 1 zeroSimplCount recd_binds;
-
- dumpIfSet (opt_D_verbose_core2core && opt_D_dump_simpl_stats)
- "Simplifier statistics"
- (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
- text "",
- pprSimplCount counts_out]);
-
- endPass "Simplify"
- (opt_D_verbose_core2core && not opt_D_dump_simpl_iterations)
- binds' ;
-
- return (counts_out, binds')
- }
- where
- max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
- black_list_fn = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)
-
- core_iter_dump binds | opt_D_verbose_core2core = pprCoreBindings binds
- | otherwise = empty
-
- iteration us iteration_no counts binds
- = do {
- -- Occurrence analysis
- let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;
-
- dumpIfSet opt_D_dump_occur_anal "Occurrence analysis"
- (pprCoreBindings tagged_binds);
-
- -- Simplify
- let { (binds', counts') = initSmpl sw_chkr us1 imported_rule_ids
- black_list_fn
- (simplTopBinds tagged_binds);
- all_counts = counts `plusSimplCount` counts'
- } ;
-
- -- Stop if nothing happened; don't dump output
- if isZeroSimplCount counts' then
- return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
- else do {
-
- -- Dump the result of this iteration
- dumpIfSet opt_D_dump_simpl_iterations
- ("Simplifier iteration " ++ show iteration_no
- ++ " out of " ++ show max_iterations)
- (pprSimplCount counts') ;
-
- if opt_D_dump_simpl_iterations then
- endPass ("Simplifier iteration " ++ show iteration_no ++ " result")
- opt_D_verbose_core2core
- binds'
- else
- return [] ;
-
- -- Stop if we've run out of iterations
- if iteration_no == max_iterations then
- do {
- if max_iterations > 2 then
- hPutStr stderr ("NOTE: Simplifier still going after " ++
- show max_iterations ++
- " iterations; bailing out.\n")
- else return ();
-
- return ("Simplifier baled out", iteration_no, all_counts, binds')
- }
-
- -- Else loop
- else iteration us2 (iteration_no + 1) all_counts binds'
- } }
- where
- (us1, us2) = splitUniqSupply us
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{PostSimplification}
-%* *
-%************************************************************************
-
-Several tasks are performed by the post-simplification pass
-
-1. Make the representation of NoRep literals explicit, and
- float their bindings to the top level. We only do the floating
- part for NoRep lits inside a lambda (else no gain). We need to
- take care with let x = "foo" in e
- that we don't end up with a silly binding
- let x = y in e
- with a floated "foo". What a bore.
-
-2. *Mangle* cases involving par# in the discriminant. The unfolding
- for par in PrelConc.lhs include case expressions with integer
- results solely to fool the strictness analyzer, the simplifier,
- and anyone else who might want to fool with the evaluation order.
- At this point in the compiler our evaluation order is safe.
- Therefore, we convert expressions of the form:
-
- case par# e of
- 0# -> rhs
- _ -> parError#
- ==>
- case par# e of
- _ -> rhs
-
- fork# isn't handled like this - it's an explicit IO operation now.
- The reason is that fork# returns a ThreadId#, which gets in the
- way of the above scheme. And anyway, IO is the only guaranteed
- way to enforce ordering --SDM.
-
-4. Do eta reduction for lambda abstractions appearing in:
- - the RHS of case alternatives
- - the body of a let
-
- These will otherwise turn into local bindings during Core->STG;
- better to nuke them if possible. (In general the simplifier does
- eta expansion not eta reduction, up to this point. It does eta
- on the RHSs of bindings but not the RHSs of case alternatives and
- let bodies)
-
-
-------------------- NOT DONE ANY MORE ------------------------
-[March 98] Indirections are now elimianted by the occurrence analyser
-1. Eliminate indirections. The point here is to transform
- x_local = E
- x_exported = x_local
- ==>
- x_exported = E
-
-[Dec 98] [Not now done because there is no penalty in the code
- generator for using the former form]
-2. Convert
- case x of {...; x' -> ...x'...}
- ==>
- case x of {...; _ -> ...x... }
- See notes in SimplCase.lhs, near simplDefault for the reasoning here.
---------------------------------------------------------------
-
-Special case
-~~~~~~~~~~~~
-
-NOT ENABLED AT THE MOMENT (because the floated Ids are global-ish
-things, and we need local Ids for non-floated stuff):
-
- Don't float stuff out of a binder that's marked as a bottoming Id.
- Reason: it doesn't do any good, and creates more CAFs that increase
- the size of SRTs.
-
-eg.
-
- f = error "string"
-
-is translated to
-
- f' = unpackCString# "string"
- f = error f'
-
-hence f' and f become CAFs. Instead, the special case for
-tidyTopBinding below makes sure this comes out as
-
- f = let f' = unpackCString# "string" in error f'
-
-and we can safely ignore f as a CAF, since it can only ever be entered once.
-
-
-
-\begin{code}
-doPostSimplification :: UniqSupply -> [CoreBind] -> IO [CoreBind]
-doPostSimplification us binds_in
- = do
- beginPass "Post-simplification pass"
- let binds_out = initPM us (postSimplTopBinds binds_in)
- endPass "Post-simplification pass" opt_D_verbose_core2core binds_out
-
-postSimplTopBinds :: [CoreBind] -> PostM [CoreBind]
-postSimplTopBinds binds
- = mapPM postSimplTopBind binds `thenPM` \ binds' ->
- returnPM (bagToList (unionManyBags binds'))
-
-postSimplTopBind :: CoreBind -> PostM (Bag CoreBind)
-postSimplTopBind (NonRec bndr rhs)
- | isBottomingId bndr -- Don't lift out floats for bottoming Ids
- -- See notes above
- = getFloatsPM (postSimplExpr rhs) `thenPM` \ (rhs', floats) ->
- returnPM (unitBag (NonRec bndr (foldrBag Let rhs' floats)))
-
-postSimplTopBind bind
- = getFloatsPM (postSimplBind bind) `thenPM` \ (bind', floats) ->
- returnPM (floats `snocBag` bind')
-
-postSimplBind (NonRec bndr rhs)
- = postSimplExpr rhs `thenPM` \ rhs' ->
- returnPM (NonRec bndr rhs')
-
-postSimplBind (Rec pairs)
- = mapPM postSimplExpr rhss `thenPM` \ rhss' ->
- returnPM (Rec (bndrs `zip` rhss'))
- where
- (bndrs, rhss) = unzip pairs
-\end{code}
-
-
-Expressions
-~~~~~~~~~~~
-\begin{code}
-postSimplExpr (Var v) = returnPM (Var v)
-postSimplExpr (Type ty) = returnPM (Type ty)
-
-postSimplExpr (App fun arg)
- = postSimplExpr fun `thenPM` \ fun' ->
- postSimplExpr arg `thenPM` \ arg' ->
- returnPM (App fun' arg')
-
-postSimplExpr (Con (Literal lit) args)
- = ASSERT( null args )
- litToRep lit `thenPM` \ (lit_ty, lit_expr) ->
- getInsideLambda `thenPM` \ in_lam ->
- if in_lam && not (exprIsTrivial lit_expr) then
- -- It must have been a no-rep literal with a
- -- non-trivial representation; and we're inside a lambda;
- -- so float it to the top
- addTopFloat lit_ty lit_expr `thenPM` \ v ->
- returnPM (Var v)
- else
- returnPM lit_expr
-
-postSimplExpr (Con con args)
- = mapPM postSimplExpr args `thenPM` \ args' ->
- returnPM (Con con args')
-
-postSimplExpr (Lam bndr body)
- = insideLambda bndr $
- postSimplExpr body `thenPM` \ body' ->
- returnPM (Lam bndr body')
-
-postSimplExpr (Let bind body)
- = postSimplBind bind `thenPM` \ bind' ->
- postSimplExprEta body `thenPM` \ body' ->
- returnPM (Let bind' body')
-
-postSimplExpr (Note note body)
- = postSimplExprEta body `thenPM` \ body' ->
- returnPM (Note note body')
-
--- par#: see notes above.
-postSimplExpr (Case scrut@(Con (PrimOp op) args) bndr alts)
- | funnyParallelOp op && maybeToBool maybe_default
- = postSimplExpr scrut `thenPM` \ scrut' ->
- postSimplExprEta default_rhs `thenPM` \ rhs' ->
- returnPM (Case scrut' bndr [(DEFAULT,[],rhs')])
- where
- (other_alts, maybe_default) = findDefault alts
- Just default_rhs = maybe_default
-
-postSimplExpr (Case scrut case_bndr alts)
- = postSimplExpr scrut `thenPM` \ scrut' ->
- mapPM ps_alt alts `thenPM` \ alts' ->
- returnPM (Case scrut' case_bndr alts')
- where
- ps_alt (con,bndrs,rhs) = postSimplExprEta rhs `thenPM` \ rhs' ->
- returnPM (con, bndrs, rhs')
-
-postSimplExprEta e = postSimplExpr e `thenPM` \ e' ->
- returnPM (etaCoreExpr e')
-\end{code}
-
-\begin{code}
-funnyParallelOp ParOp = True
-funnyParallelOp _ = False
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[coreToStg-lits]{Converting literals}
-%* *
-%************************************************************************
-
-Literals: the NoRep kind need to be de-no-rep'd.
-We always replace them with a simple variable, and float a suitable
-binding out to the top level.
-
-\begin{code}
-litToRep :: Literal -> PostM (Type, CoreExpr)
-
-litToRep (NoRepStr s ty)
- = returnPM (ty, rhs)
- where
- rhs = if (any is_NUL (_UNPK_ s))
-
- then -- Must cater for NULs in literal string
- mkApps (Var unpackCString2Id)
- [mkLit (MachStr s),
- mkLit (mkMachInt (toInteger (_LENGTH_ s)))]
-
- else -- No NULs in the string
- App (Var unpackCStringId) (mkLit (MachStr s))
-
- is_NUL c = c == '\0'
-\end{code}
-
-If an Integer is small enough (Haskell implementations must support
-Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
-otherwise, wrap with @addr2Integer@.
-
-\begin{code}
-litToRep (NoRepInteger i integer_ty)
- = returnPM (integer_ty, rhs)
- where
- rhs | i > tARGET_MIN_INT && -- Small enough, so start from an Int
- i < tARGET_MAX_INT
- = Con (DataCon smallIntegerDataCon) [Con (Literal (mkMachInt i)) []]
-
- | otherwise -- Big, so start from a string
- = App (Var addr2IntegerId) (Con (Literal (MachStr (_PK_ (show i)))) [])
-
-
-litToRep (NoRepRational r rational_ty)
- = postSimplExpr (mkLit (NoRepInteger (numerator r) integer_ty)) `thenPM` \ num_arg ->
- postSimplExpr (mkLit (NoRepInteger (denominator r) integer_ty)) `thenPM` \ denom_arg ->
- returnPM (rational_ty, mkConApp ratio_data_con [Type integer_ty, num_arg, denom_arg])
- where
- (ratio_data_con, integer_ty)
- = case (splitAlgTyConApp_maybe rational_ty) of
- Just (tycon, [i_ty], [con])
- -> ASSERT(isIntegerTy i_ty && getUnique tycon == ratioTyConKey)
- (con, i_ty)
-
- _ -> (panic "ratio_data_con", panic "integer_ty")
-
-litToRep other_lit = returnPM (literalType other_lit, mkLit other_lit)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{The monad}
-%* *
-%************************************************************************
-
-\begin{code}
-type PostM a = Bool -- True <=> inside a *value* lambda
- -> (UniqSupply, Bag CoreBind) -- Unique supply and Floats in
- -> (a, (UniqSupply, Bag CoreBind))
-
-initPM :: UniqSupply -> PostM a -> a
-initPM us m
- = case m False {- not inside lambda -} (us, emptyBag) of
- (result, _) -> result
-
-returnPM v in_lam usf = (v, usf)
-thenPM m k in_lam usf = case m in_lam usf of
- (r, usf') -> k r in_lam usf'
-
-mapPM f [] = returnPM []
-mapPM f (x:xs) = f x `thenPM` \ r ->
- mapPM f xs `thenPM` \ rs ->
- returnPM (r:rs)
-
-insideLambda :: CoreBndr -> PostM a -> PostM a
-insideLambda bndr m in_lam usf | isId bndr = m True usf
- | otherwise = m in_lam usf
-
-getInsideLambda :: PostM Bool
-getInsideLambda in_lam usf = (in_lam, usf)
-
-getFloatsPM :: PostM a -> PostM (a, Bag CoreBind)
-getFloatsPM m in_lam (us, floats)
- = let
- (a, (us', floats')) = m in_lam (us, emptyBag)
- in
- ((a, floats'), (us', floats))
-
-addTopFloat :: Type -> CoreExpr -> PostM Id
-addTopFloat lit_ty lit_rhs in_lam (us, floats)
- = let
- (us1, us2) = splitUniqSupply us
- uniq = uniqFromSupply us1
- lit_id = mkSysLocal SLIT("lf") uniq lit_ty
- in
- (lit_id, (us2, floats `snocBag` NonRec lit_id lit_rhs))
-\end{code}
-
-
+%\r
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998\r
+%\r
+\section[SimplCore]{Driver for simplifying @Core@ programs}\r
+\r
+\begin{code}\r
+module SimplCore ( core2core ) where\r
+\r
+#include "HsVersions.h"\r
+\r
+import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), \r
+ SwitchResult(..), switchIsOn, intSwitchSet,\r
+ opt_D_dump_occur_anal, opt_D_dump_rules,\r
+ opt_D_dump_simpl_iterations,\r
+ opt_D_dump_simpl_stats,\r
+ opt_D_dump_simpl, opt_D_dump_rules,\r
+ opt_D_verbose_core2core,\r
+ opt_D_dump_occur_anal,\r
+ opt_UsageSPOn,\r
+ )\r
+import CoreLint ( beginPass, endPass )\r
+import CoreTidy ( tidyCorePgm )\r
+import CoreSyn\r
+import Rules ( RuleBase, ProtoCoreRule(..), pprProtoCoreRule, prepareRuleBase, orphanRule )\r
+import CoreUnfold\r
+import PprCore ( pprCoreBindings )\r
+import OccurAnal ( occurAnalyseBinds )\r
+import CoreUtils ( exprIsTrivial, coreExprType )\r
+import Simplify ( simplTopBinds, simplExpr )\r
+import SimplUtils ( etaCoreExpr, findDefault, simplBinders )\r
+import SimplMonad\r
+import Const ( Con(..), Literal(..), literalType, mkMachInt )\r
+import ErrUtils ( dumpIfSet )\r
+import FloatIn ( floatInwards )\r
+import FloatOut ( floatOutwards )\r
+import Id ( Id, mkSysLocal, mkVanillaId, isBottomingId,\r
+ idType, setIdType, idName, idInfo, setIdNoDiscard\r
+ )\r
+import VarEnv\r
+import VarSet\r
+import Module ( Module )\r
+import Name ( mkLocalName, tidyOccName, tidyTopName, \r
+ NamedThing(..), OccName\r
+ )\r
+import TyCon ( TyCon, isDataTyCon )\r
+import PrimOp ( PrimOp(..) )\r
+import PrelInfo ( unpackCStringId, unpackCString2Id, addr2IntegerId )\r
+import Type ( Type, splitAlgTyConApp_maybe, \r
+ isUnLiftedType,\r
+ tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,\r
+ Type\r
+ )\r
+import TysWiredIn ( smallIntegerDataCon, isIntegerTy )\r
+import LiberateCase ( liberateCase )\r
+import SAT ( doStaticArgs )\r
+import Specialise ( specProgram)\r
+import UsageSPInf ( doUsageSPInf )\r
+import StrictAnal ( saBinds )\r
+import WorkWrap ( wwTopBinds )\r
+import CprAnalyse ( cprAnalyse )\r
+\r
+import Unique ( Unique, Uniquable(..),\r
+ ratioTyConKey\r
+ )\r
+import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupply )\r
+import Constants ( tARGET_MIN_INT, tARGET_MAX_INT )\r
+import Util ( mapAccumL )\r
+import SrcLoc ( noSrcLoc )\r
+import Bag\r
+import Maybes\r
+import IO ( hPutStr, stderr )\r
+import Outputable\r
+\r
+import Ratio ( numerator, denominator )\r
+\end{code}\r
+\r
+%************************************************************************\r
+%* *\r
+\subsection{The driver for the simplifier}\r
+%* *\r
+%************************************************************************\r
+\r
+\begin{code}\r
+core2core :: [CoreToDo] -- Spec of what core-to-core passes to do\r
+ -> [CoreBind] -- Binds in\r
+ -> [ProtoCoreRule] -- Rules\r
+ -> IO ([CoreBind], [ProtoCoreRule])\r
+\r
+core2core core_todos binds rules\r
+ = do\r
+ us <- mkSplitUniqSupply 's'\r
+ let (cp_us, us1) = splitUniqSupply us\r
+ (ru_us, ps_us) = splitUniqSupply us1\r
+\r
+ better_rules <- simplRules ru_us rules binds\r
+\r
+ let (binds1, rule_base) = prepareRuleBase binds better_rules\r
+\r
+ -- Do the main business\r
+ (stats, processed_binds) <- doCorePasses zeroSimplCount cp_us binds1 \r
+ rule_base core_todos\r
+\r
+ dumpIfSet opt_D_dump_simpl_stats\r
+ "Grand total simplifier statistics"\r
+ (pprSimplCount stats)\r
+\r
+ -- Do the post-simplification business\r
+ post_simpl_binds <- doPostSimplification ps_us processed_binds\r
+\r
+ -- Return results\r
+ return (post_simpl_binds, filter orphanRule better_rules)\r
+ \r
+\r
+doCorePasses stats us binds irs []\r
+ = return (stats, binds)\r
+\r
+doCorePasses stats us binds irs (to_do : to_dos) \r
+ = do\r
+ let (us1, us2) = splitUniqSupply us\r
+ (stats1, binds1) <- doCorePass us1 binds irs to_do\r
+ doCorePasses (stats `plusSimplCount` stats1) us2 binds1 irs to_dos\r
+\r
+doCorePass us binds rb (CoreDoSimplify sw_chkr) = _scc_ "Simplify" simplifyPgm rb sw_chkr us binds\r
+doCorePass us binds rb CoreLiberateCase = _scc_ "LiberateCase" noStats (liberateCase binds)\r
+doCorePass us binds rb CoreDoFloatInwards = _scc_ "FloatInwards" noStats (floatInwards binds)\r
+doCorePass us binds rb CoreDoFullLaziness = _scc_ "FloatOutwards" noStats (floatOutwards us binds)\r
+doCorePass us binds rb CoreDoStaticArgs = _scc_ "StaticArgs" noStats (doStaticArgs us binds)\r
+doCorePass us binds rb CoreDoStrictness = _scc_ "Stranal" noStats (saBinds binds)\r
+doCorePass us binds rb CoreDoWorkerWrapper = _scc_ "WorkWrap" noStats (wwTopBinds us binds)\r
+doCorePass us binds rb CoreDoSpecialising = _scc_ "Specialise" noStats (specProgram us binds)\r
+doCorePass us binds rb CoreDoCPResult = _scc_ "CPResult" noStats (cprAnalyse binds)\r
+doCorePass us binds rb CoreDoPrintCore = _scc_ "PrintCore" noStats (printCore binds)\r
+doCorePass us binds rb CoreDoUSPInf\r
+ = _scc_ "CoreUsageSPInf" \r
+ if opt_UsageSPOn then\r
+ noStats (doUsageSPInf us binds)\r
+ else\r
+ trace "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on" $\r
+ noStats (return binds)\r
+\r
+printCore binds = do dumpIfSet True "Print Core"\r
+ (pprCoreBindings binds)\r
+ return binds\r
+\r
+noStats thing = do { result <- thing; return (zeroSimplCount, result) }\r
+\end{code}\r
+\r
+\r
+%************************************************************************\r
+%* *\r
+\subsection{Dealing with rules}\r
+%* *\r
+%************************************************************************\r
+\r
+We must do some gentle simplifiation on the template (but not the RHS)\r
+of each rule. The case that forced me to add this was the fold/build rule,\r
+which without simplification looked like:\r
+ fold k z (build (/\a. g a)) ==> ...\r
+This doesn't match unless you do eta reduction on the build argument.\r
+\r
+\begin{code}\r
+simplRules :: UniqSupply -> [ProtoCoreRule] -> [CoreBind] -> IO [ProtoCoreRule]\r
+simplRules us rules binds\r
+ = do let (better_rules,_) = initSmpl sw_chkr us bind_vars black_list_all (mapSmpl simplRule rules)\r
+ \r
+ dumpIfSet opt_D_dump_rules\r
+ "Transformation rules"\r
+ (vcat (map pprProtoCoreRule better_rules))\r
+\r
+ return better_rules\r
+ where\r
+ black_list_all v = True -- This stops all inlining\r
+ sw_chkr any = SwBool False -- A bit bogus\r
+\r
+ -- Boringly, we need to gather the in-scope set.\r
+ -- Typically this thunk won't even be force, but the test in\r
+ -- simpVar fails if it isn't right, and it might conceivably matter\r
+ bind_vars = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds\r
+\r
+\r
+simplRule rule@(ProtoCoreRule is_local id (Rule name bndrs args rhs))\r
+ | not is_local\r
+ = returnSmpl rule -- No need to fiddle with imported rules\r
+ | otherwise\r
+ = simplBinders bndrs $ \ bndrs' -> \r
+ mapSmpl simplExpr args `thenSmpl` \ args' ->\r
+ simplExpr rhs `thenSmpl` \ rhs' ->\r
+ returnSmpl (ProtoCoreRule is_local id (Rule name bndrs' args' rhs'))\r
+\end{code}\r
+\r
+%************************************************************************\r
+%* *\r
+\subsection{The driver for the simplifier}\r
+%* *\r
+%************************************************************************\r
+\r
+\begin{code}\r
+simplifyPgm :: RuleBase\r
+ -> (SimplifierSwitch -> SwitchResult)\r
+ -> UniqSupply\r
+ -> [CoreBind] -- Input\r
+ -> IO (SimplCount, [CoreBind]) -- New bindings\r
+\r
+simplifyPgm (imported_rule_ids, rule_lhs_fvs) \r
+ sw_chkr us binds\r
+ = do {\r
+ beginPass "Simplify";\r
+\r
+ -- Glom all binds together in one Rec, in case any\r
+ -- transformations have introduced any new dependencies\r
+ let { recd_binds = [Rec (flattenBinds binds)] };\r
+\r
+ (termination_msg, it_count, counts_out, binds') <- iteration us 1 zeroSimplCount recd_binds;\r
+\r
+ dumpIfSet (opt_D_verbose_core2core && opt_D_dump_simpl_stats)\r
+ "Simplifier statistics"\r
+ (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",\r
+ text "",\r
+ pprSimplCount counts_out]);\r
+\r
+ endPass "Simplify" \r
+ (opt_D_verbose_core2core && not opt_D_dump_simpl_iterations)\r
+ binds' ;\r
+\r
+ return (counts_out, binds')\r
+ }\r
+ where\r
+ max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations\r
+ black_list_fn = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)\r
+\r
+ core_iter_dump binds | opt_D_verbose_core2core = pprCoreBindings binds\r
+ | otherwise = empty\r
+\r
+ iteration us iteration_no counts binds\r
+ = do {\r
+ -- Occurrence analysis\r
+ let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;\r
+\r
+ dumpIfSet opt_D_dump_occur_anal "Occurrence analysis"\r
+ (pprCoreBindings tagged_binds);\r
+\r
+ -- Simplify\r
+ let { (binds', counts') = initSmpl sw_chkr us1 imported_rule_ids \r
+ black_list_fn \r
+ (simplTopBinds tagged_binds);\r
+ all_counts = counts `plusSimplCount` counts'\r
+ } ;\r
+\r
+ -- Stop if nothing happened; don't dump output\r
+ if isZeroSimplCount counts' then\r
+ return ("Simplifier reached fixed point", iteration_no, all_counts, binds')\r
+ else do {\r
+\r
+ -- Dump the result of this iteration\r
+ dumpIfSet opt_D_dump_simpl_iterations\r
+ ("Simplifier iteration " ++ show iteration_no \r
+ ++ " out of " ++ show max_iterations)\r
+ (pprSimplCount counts') ;\r
+\r
+ if opt_D_dump_simpl_iterations then\r
+ endPass ("Simplifier iteration " ++ show iteration_no ++ " result")\r
+ opt_D_verbose_core2core\r
+ binds'\r
+ else\r
+ return [] ;\r
+\r
+ -- Stop if we've run out of iterations\r
+ if iteration_no == max_iterations then\r
+ do {\r
+ if max_iterations > 2 then\r
+ hPutStr stderr ("NOTE: Simplifier still going after " ++ \r
+ show max_iterations ++ \r
+ " iterations; bailing out.\n")\r
+ else return ();\r
+\r
+ return ("Simplifier baled out", iteration_no, all_counts, binds')\r
+ }\r
+\r
+ -- Else loop\r
+ else iteration us2 (iteration_no + 1) all_counts binds'\r
+ } }\r
+ where\r
+ (us1, us2) = splitUniqSupply us\r
+\end{code}\r
+\r
+\r
+%************************************************************************\r
+%* *\r
+\subsection{PostSimplification}\r
+%* *\r
+%************************************************************************\r
+\r
+Several tasks are performed by the post-simplification pass\r
+\r
+1. Make the representation of NoRep literals explicit, and\r
+ float their bindings to the top level. We only do the floating\r
+ part for NoRep lits inside a lambda (else no gain). We need to\r
+ take care with let x = "foo" in e\r
+ that we don't end up with a silly binding\r
+ let x = y in e\r
+ with a floated "foo". What a bore.\r
+ \r
+4. Do eta reduction for lambda abstractions appearing in:\r
+ - the RHS of case alternatives\r
+ - the body of a let\r
+\r
+ These will otherwise turn into local bindings during Core->STG;\r
+ better to nuke them if possible. (In general the simplifier does\r
+ eta expansion not eta reduction, up to this point. It does eta\r
+ on the RHSs of bindings but not the RHSs of case alternatives and\r
+ let bodies)\r
+\r
+\r
+------------------- NOT DONE ANY MORE ------------------------\r
+[March 98] Indirections are now elimianted by the occurrence analyser\r
+1. Eliminate indirections. The point here is to transform\r
+ x_local = E\r
+ x_exported = x_local\r
+ ==>\r
+ x_exported = E\r
+\r
+[Dec 98] [Not now done because there is no penalty in the code\r
+ generator for using the former form]\r
+2. Convert\r
+ case x of {...; x' -> ...x'...}\r
+ ==>\r
+ case x of {...; _ -> ...x... }\r
+ See notes in SimplCase.lhs, near simplDefault for the reasoning here.\r
+--------------------------------------------------------------\r
+\r
+Special case\r
+~~~~~~~~~~~~\r
+\r
+NOT ENABLED AT THE MOMENT (because the floated Ids are global-ish\r
+things, and we need local Ids for non-floated stuff):\r
+\r
+ Don't float stuff out of a binder that's marked as a bottoming Id.\r
+ Reason: it doesn't do any good, and creates more CAFs that increase\r
+ the size of SRTs.\r
+\r
+eg.\r
+\r
+ f = error "string"\r
+\r
+is translated to\r
+\r
+ f' = unpackCString# "string"\r
+ f = error f'\r
+\r
+hence f' and f become CAFs. Instead, the special case for\r
+tidyTopBinding below makes sure this comes out as\r
+\r
+ f = let f' = unpackCString# "string" in error f'\r
+\r
+and we can safely ignore f as a CAF, since it can only ever be entered once.\r
+\r
+\r
+\r
+\begin{code}\r
+doPostSimplification :: UniqSupply -> [CoreBind] -> IO [CoreBind]\r
+doPostSimplification us binds_in\r
+ = do\r
+ beginPass "Post-simplification pass"\r
+ let binds_out = initPM us (postSimplTopBinds binds_in)\r
+ endPass "Post-simplification pass" opt_D_verbose_core2core binds_out\r
+\r
+postSimplTopBinds :: [CoreBind] -> PostM [CoreBind]\r
+postSimplTopBinds binds\r
+ = mapPM postSimplTopBind binds `thenPM` \ binds' ->\r
+ returnPM (bagToList (unionManyBags binds'))\r
+\r
+postSimplTopBind :: CoreBind -> PostM (Bag CoreBind)\r
+postSimplTopBind (NonRec bndr rhs)\r
+ | isBottomingId bndr -- Don't lift out floats for bottoming Ids\r
+ -- See notes above\r
+ = getFloatsPM (postSimplExpr rhs) `thenPM` \ (rhs', floats) ->\r
+ returnPM (unitBag (NonRec bndr (foldrBag Let rhs' floats)))\r
+\r
+postSimplTopBind bind\r
+ = getFloatsPM (postSimplBind bind) `thenPM` \ (bind', floats) ->\r
+ returnPM (floats `snocBag` bind')\r
+\r
+postSimplBind (NonRec bndr rhs)\r
+ = postSimplExpr rhs `thenPM` \ rhs' ->\r
+ returnPM (NonRec bndr rhs')\r
+\r
+postSimplBind (Rec pairs)\r
+ = mapPM postSimplExpr rhss `thenPM` \ rhss' ->\r
+ returnPM (Rec (bndrs `zip` rhss'))\r
+ where\r
+ (bndrs, rhss) = unzip pairs\r
+\end{code}\r
+\r
+\r
+Expressions\r
+~~~~~~~~~~~\r
+\begin{code}\r
+postSimplExpr (Var v) = returnPM (Var v)\r
+postSimplExpr (Type ty) = returnPM (Type ty)\r
+\r
+postSimplExpr (App fun arg)\r
+ = postSimplExpr fun `thenPM` \ fun' ->\r
+ postSimplExpr arg `thenPM` \ arg' ->\r
+ returnPM (App fun' arg')\r
+\r
+postSimplExpr (Con (Literal lit) args)\r
+ = ASSERT( null args )\r
+ litToRep lit `thenPM` \ (lit_ty, lit_expr) ->\r
+ getInsideLambda `thenPM` \ in_lam ->\r
+ if in_lam && not (exprIsTrivial lit_expr) then\r
+ -- It must have been a no-rep literal with a\r
+ -- non-trivial representation; and we're inside a lambda;\r
+ -- so float it to the top\r
+ addTopFloat lit_ty lit_expr `thenPM` \ v ->\r
+ returnPM (Var v)\r
+ else\r
+ returnPM lit_expr\r
+\r
+postSimplExpr (Con con args)\r
+ = mapPM postSimplExpr args `thenPM` \ args' ->\r
+ returnPM (Con con args')\r
+\r
+postSimplExpr (Lam bndr body)\r
+ = insideLambda bndr $\r
+ postSimplExpr body `thenPM` \ body' ->\r
+ returnPM (Lam bndr body')\r
+\r
+postSimplExpr (Let bind body)\r
+ = postSimplBind bind `thenPM` \ bind' ->\r
+ postSimplExprEta body `thenPM` \ body' ->\r
+ returnPM (Let bind' body')\r
+\r
+postSimplExpr (Note note body)\r
+ = postSimplExprEta body `thenPM` \ body' ->\r
+ returnPM (Note note body')\r
+\r
+postSimplExpr (Case scrut case_bndr alts)\r
+ = postSimplExpr scrut `thenPM` \ scrut' ->\r
+ mapPM ps_alt alts `thenPM` \ alts' ->\r
+ returnPM (Case scrut' case_bndr alts')\r
+ where\r
+ ps_alt (con,bndrs,rhs) = postSimplExprEta rhs `thenPM` \ rhs' ->\r
+ returnPM (con, bndrs, rhs')\r
+\r
+postSimplExprEta e = postSimplExpr e `thenPM` \ e' ->\r
+ returnPM (etaCoreExpr e')\r
+\end{code}\r
+\r
+\r
+%************************************************************************\r
+%* *\r
+\subsection[coreToStg-lits]{Converting literals}\r
+%* *\r
+%************************************************************************\r
+\r
+Literals: the NoRep kind need to be de-no-rep'd.\r
+We always replace them with a simple variable, and float a suitable\r
+binding out to the top level.\r
+\r
+\begin{code}\r
+litToRep :: Literal -> PostM (Type, CoreExpr)\r
+\r
+litToRep (NoRepStr s ty)\r
+ = returnPM (ty, rhs)\r
+ where\r
+ rhs = if (any is_NUL (_UNPK_ s))\r
+\r
+ then -- Must cater for NULs in literal string\r
+ mkApps (Var unpackCString2Id)\r
+ [mkLit (MachStr s),\r
+ mkLit (mkMachInt (toInteger (_LENGTH_ s)))]\r
+\r
+ else -- No NULs in the string\r
+ App (Var unpackCStringId) (mkLit (MachStr s))\r
+\r
+ is_NUL c = c == '\0'\r
+\end{code}\r
+\r
+If an Integer is small enough (Haskell implementations must support\r
+Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;\r
+otherwise, wrap with @addr2Integer@.\r
+\r
+\begin{code}\r
+litToRep (NoRepInteger i integer_ty)\r
+ = returnPM (integer_ty, rhs)\r
+ where\r
+ rhs | i > tARGET_MIN_INT && -- Small enough, so start from an Int\r
+ i < tARGET_MAX_INT\r
+ = Con (DataCon smallIntegerDataCon) [Con (Literal (mkMachInt i)) []]\r
+ \r
+ | otherwise -- Big, so start from a string\r
+ = App (Var addr2IntegerId) (Con (Literal (MachStr (_PK_ (show i)))) [])\r
+\r
+\r
+litToRep (NoRepRational r rational_ty)\r
+ = postSimplExpr (mkLit (NoRepInteger (numerator r) integer_ty)) `thenPM` \ num_arg ->\r
+ postSimplExpr (mkLit (NoRepInteger (denominator r) integer_ty)) `thenPM` \ denom_arg ->\r
+ returnPM (rational_ty, mkConApp ratio_data_con [Type integer_ty, num_arg, denom_arg])\r
+ where\r
+ (ratio_data_con, integer_ty)\r
+ = case (splitAlgTyConApp_maybe rational_ty) of\r
+ Just (tycon, [i_ty], [con])\r
+ -> ASSERT(isIntegerTy i_ty && getUnique tycon == ratioTyConKey)\r
+ (con, i_ty)\r
+\r
+ _ -> (panic "ratio_data_con", panic "integer_ty")\r
+\r
+litToRep other_lit = returnPM (literalType other_lit, mkLit other_lit)\r
+\end{code}\r
+\r
+\r
+%************************************************************************\r
+%* *\r
+\subsection{The monad}\r
+%* *\r
+%************************************************************************\r
+\r
+\begin{code}\r
+type PostM a = Bool -- True <=> inside a *value* lambda\r
+ -> (UniqSupply, Bag CoreBind) -- Unique supply and Floats in \r
+ -> (a, (UniqSupply, Bag CoreBind))\r
+\r
+initPM :: UniqSupply -> PostM a -> a\r
+initPM us m\r
+ = case m False {- not inside lambda -} (us, emptyBag) of \r
+ (result, _) -> result\r
+\r
+returnPM v in_lam usf = (v, usf)\r
+thenPM m k in_lam usf = case m in_lam usf of\r
+ (r, usf') -> k r in_lam usf'\r
+\r
+mapPM f [] = returnPM []\r
+mapPM f (x:xs) = f x `thenPM` \ r ->\r
+ mapPM f xs `thenPM` \ rs ->\r
+ returnPM (r:rs)\r
+\r
+insideLambda :: CoreBndr -> PostM a -> PostM a\r
+insideLambda bndr m in_lam usf | isId bndr = m True usf\r
+ | otherwise = m in_lam usf\r
+\r
+getInsideLambda :: PostM Bool\r
+getInsideLambda in_lam usf = (in_lam, usf)\r
+\r
+getFloatsPM :: PostM a -> PostM (a, Bag CoreBind)\r
+getFloatsPM m in_lam (us, floats)\r
+ = let\r
+ (a, (us', floats')) = m in_lam (us, emptyBag)\r
+ in\r
+ ((a, floats'), (us', floats))\r
+\r
+addTopFloat :: Type -> CoreExpr -> PostM Id\r
+addTopFloat lit_ty lit_rhs in_lam (us, floats)\r
+ = let\r
+ (us1, us2) = splitUniqSupply us\r
+ uniq = uniqFromSupply us1\r
+ lit_id = mkSysLocal SLIT("lf") uniq lit_ty\r
+ in\r
+ (lit_id, (us2, floats `snocBag` NonRec lit_id lit_rhs))\r
+\end{code}\r
+\r
+\r
projects / ghc-hetmet.git / commitdiff