diff options
| -rw-r--r-- | ghc/compiler/basicTypes/Name.lhs | 4 | ||||
| -rw-r--r-- | ghc/compiler/codeGen/CgTailCall.lhs | 15 | ||||
| -rw-r--r-- | ghc/compiler/coreSyn/CoreLint.lhs | 2 | ||||
| -rw-r--r-- | ghc/compiler/coreSyn/CoreUnfold.lhs | 1295 | ||||
| -rw-r--r-- | ghc/compiler/prelude/PrimOp.lhs | 4759 | ||||
| -rw-r--r-- | ghc/compiler/simplCore/ConFold.lhs | 15 | ||||
| -rw-r--r-- | ghc/compiler/simplCore/SimplCore.lhs | 1161 | ||||
| -rw-r--r-- | ghc/compiler/stgSyn/CoreToStg.lhs | 78 | ||||
| -rw-r--r-- | ghc/compiler/stranal/SaAbsInt.lhs | 4 | ||||
| -rw-r--r-- | ghc/compiler/stranal/StrictAnal.lhs | 3 | ||||
| -rw-r--r-- | ghc/compiler/stranal/WwLib.lhs | 22 | ||||
| -rw-r--r-- | ghc/compiler/typecheck/TcTyDecls.lhs | 15 |
12 files changed, 3708 insertions, 3665 deletions
diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 0bd95d211a..59b0510cd8 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -463,8 +463,8 @@ instance Eq Name where a /= b = case (a `compare` b) of { EQ -> False; _ -> True } instance Ord Name where - a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } - a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } compare a b = cmpName a b diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs index 168cde42ae..96ceff561b 100644 --- a/ghc/compiler/codeGen/CgTailCall.lhs +++ b/ghc/compiler/codeGen/CgTailCall.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgTailCall.lhs,v 1.19 1999/05/13 17:30:58 simonm Exp $ +% $Id: CgTailCall.lhs,v 1.20 1999/05/28 19:24:28 simonpj Exp $ % %******************************************************** %* * @@ -47,7 +47,7 @@ import CmdLineOpts ( opt_DoSemiTagging ) import Id ( Id, idType, idName ) import DataCon ( DataCon, dataConTyCon, dataConTag, fIRST_TAG ) import Const ( mkMachInt ) -import Maybes ( assocMaybe ) +import Maybes ( assocMaybe, maybeToBool ) import PrimRep ( PrimRep(..) ) import StgSyn ( StgArg, GenStgArg(..) ) import Type ( isUnLiftedType ) @@ -390,7 +390,8 @@ doTailCall -> (Sequel->Code) -- code to perform jump -> Int -- number of "fast" stack arguments -> AbstractC -- pending assignments - -> Maybe VirtualSpOffset -- sp offset to trim stack to + -> Maybe VirtualSpOffset -- sp offset to trim stack to: + -- USED iff destination is a let-no-escape -> Bool -- node points to the closure to enter -> Code @@ -449,7 +450,13 @@ doTailCall arg_amodes arg_regs finish_code arity pending_assts -- push a return address if necessary -- (after the assignments above, in case we clobber a live -- stack location) - pushReturnAddress eob `thenC` + + -- DONT push the return address when we're about + -- to jump to a let-no-escape: the final tail call + -- in the let-no-escape will do this. + (if (maybeToBool maybe_join_sp) + then nopC + else pushReturnAddress eob) `thenC` -- Final adjustment of stack pointer adjustRealSp final_sp `thenC` diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index ef38305a05..95d411808d 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -379,6 +379,7 @@ checkAllCasesCovered e scrut_ty alts if isPrimTyCon tycon then checkL (hasDefault alts) (nonExhaustiveAltsMsg e) else +{- No longer needed #ifdef DEBUG -- Algebraic cases are not necessarily exhaustive, because -- the simplifer correctly eliminates case that can't @@ -398,6 +399,7 @@ checkAllCasesCovered e scrut_ty alts nopL else #endif +-} nopL } hasDefault [] = False diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 44fe5a7799..a42e65949d 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -1,648 +1,647 @@ -% -% (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. - +%
+% (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 OccurAnal ( occurAnalyseGlobalExpr )
+import BinderInfo ( )
+import CoreUtils ( coreExprType, exprIsTrivial, mkFormSummary, whnfOrBottom,
+ 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.
+
diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index ab78b8d402..24bead229e 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -1,2377 +1,2382 @@ -% -% (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} +%
+% (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 = ([wwStrict], False)
+ -- Seq is strict in its argument; see notes in ConFold.lhs
+
+primOpStrictness ParOp = ([wwLazy], False)
+ -- But Par is lazy, to avoid that the sparked thing
+ -- gets evaluted strictly, which it should *not* be
+
+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}
diff --git a/ghc/compiler/simplCore/ConFold.lhs b/ghc/compiler/simplCore/ConFold.lhs index e6f4be7fbb..9299be2dca 100644 --- a/ghc/compiler/simplCore/ConFold.lhs +++ b/ghc/compiler/simplCore/ConFold.lhs @@ -21,7 +21,8 @@ import TysWiredIn ( trueDataCon, falseDataCon ) import TyCon ( tyConDataCons, isEnumerationTyCon ) import DataCon ( dataConTag, fIRST_TAG ) import Const ( conOkForAlt ) -import CoreUnfold ( Unfolding(..) ) +import CoreUnfold ( Unfolding(..), isEvaldUnfolding ) +import CoreUtils ( exprIsValue ) import Type ( splitTyConApp_maybe ) import Char ( ord, chr ) @@ -89,13 +90,13 @@ NB: If we ever do case-floating, we have an extra worry: The second case must never be floated outside of the first! -\begin{code}p -tryPrimOp SeqOp [Type ty, Con (Literal lit) _] +\begin{code} +tryPrimOp SeqOp [Type ty, arg] + | is_evald arg = Just (Con (Literal (mkMachInt 1)) []) - -tryPrimOp SeqOp args@[Type ty, Var var] - | isEvaluated (getIdUnfolding var) = Just (Con (Literal (mkMachInt 1)) [])) -- var is eval'd - | otherwise = Nothing -- var not eval'd + where + is_evald (Var v) = isEvaldUnfolding (getIdUnfolding v) + is_evald arg = exprIsValue arg \end{code} \begin{code} diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 2a305073f7..7e17ed1266 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -1,600 +1,561 @@ -% -% (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} - - +%
+% (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 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.
+
+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')
+
+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}
+
+
+%************************************************************************
+%* *
+\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}
+
+
diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 8db87aad81..b7110f8ada 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -463,10 +463,16 @@ coreExprToStgFloat env expr@(Lam _ _) dem \begin{code} coreExprToStgFloat env expr@(App _ _) dem = let - (fun,rads,_,_) = collect_args expr - ads = reverse rads + (fun,rads,_,ss) = collect_args expr + ads = reverse rads + final_ads | null ss = ads + | otherwise = zap ads -- Too few args to satisfy strictness info + -- so we have to ignore all the strictness info + -- e.g. + (error "urk") + -- Here, we can't evaluate the arg strictly, + -- because this partial application might be seq'd in - coreArgsToStg env ads `thenUs` \ (arg_floats, stg_args) -> + coreArgsToStg env final_ads `thenUs` \ (arg_floats, stg_args) -> -- Now deal with the function case (fun, stg_args) of @@ -504,12 +510,11 @@ coreExprToStgFloat env expr@(App _ _) dem collect_args (App fun (Type tyarg)) = let (the_fun,ads,fun_ty,ss) = collect_args fun in (the_fun,ads,applyTy fun_ty tyarg,ss) collect_args (App fun arg) - = case ss of - [] -> -- Strictness info has run out - (the_fun, (arg, mkDemTy wwLazy arg_ty) : zap ads, res_ty, repeat wwLazy) - (ss1:ss_rest) -> -- Enough strictness info - (the_fun, (arg, mkDemTy ss1 arg_ty) : ads, res_ty, ss_rest) + = (the_fun, (arg, mkDemTy ss1 arg_ty) : ads, res_ty, ss_rest) where + (ss1, ss_rest) = case ss of + (ss1:ss_rest) -> (ss1, ss_rest) + [] -> (wwLazy, []) (the_fun, ads, fun_ty, ss) = collect_args fun (arg_ty, res_ty) = expectJust "coreExprToStgFloat:collect_args" $ splitFunTy_maybe fun_ty @@ -582,33 +587,68 @@ coreExprToStgFloat env expr@(Con con args) dem %* * %************************************************************************ -Mangle cases involving seq# in the discriminant. Up to this -point, seq# will appear like this: +First, two special cases. We mangle cases involving + par# and seq# +inthe scrutinee. + +Up to this point, seq# will appear like this: case seq# e of 0# -> seqError# - _ -> ... + _ -> <stuff> + +This code comes from an unfolding for 'seq' in Prelude.hs. +The 0# branch is purely to bamboozle the strictness analyser. +For example, if <stuff> is strict in x, and there was no seqError# +branch, the strictness analyser would conclude that the whole expression +was strict in x, and perhaps evaluate x first -- but that would be a DISASTER. -where the 0# branch is purely to bamboozle the strictness analyser -This code comes from an unfolding for 'seq' in Prelude.hs. We -translate this into +Now that the evaluation order is safe, we translate this into case e of _ -> ... -Now that the evaluation order is safe. - This used to be done in the post-simplification phase, but we need unfoldings involving seq# to appear unmangled in the interface file, hence we do this mangling here. +Similarly, par# has an unfolding in PrelConc.lhs that makes it show +up like this: + + 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. + + \begin{code} coreExprToStgFloat env (Case scrut@(Con (PrimOp SeqOp) [Type ty, e]) bndr alts) dem = coreExprToStgFloat env (Case e new_bndr [(DEFAULT,[],default_rhs)]) dem - where new_bndr = setIdType bndr ty - (other_alts, maybe_default) = findDefault alts - Just default_rhs = maybe_default + where + new_bndr = setIdType bndr ty + (other_alts, maybe_default) = findDefault alts + Just default_rhs = maybe_default + +coreExprToStgFloat env + (Case scrut@(Con (PrimOp ParOp) args) bndr alts) dem + | maybeToBool maybe_default + = coreExprToStgFloat env scrut (bdrDem bndr) `thenUs` \ (binds, scrut') -> + newEvaldLocalId env bndr `thenUs` \ (env', bndr') -> + coreExprToStg env' default_rhs dem `thenUs` \ default_rhs' -> + returnUs (binds, mkStgCase scrut' bndr' (StgPrimAlts (idType bndr) [] (StgBindDefault default_rhs'))) + where + (other_alts, maybe_default) = findDefault alts + Just default_rhs = maybe_default \end{code} Now for normal case expressions... diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs index 37e9248d87..94c4b0f397 100644 --- a/ghc/compiler/stranal/SaAbsInt.lhs +++ b/ghc/compiler/stranal/SaAbsInt.lhs @@ -632,7 +632,9 @@ findStrictness tys str_val abs_val where tys_w_index = tys `zip` [(1::Int) ..] - find_str (ty,n) = findRecDemand str_fn abs_fn ty + find_str (ty,n) = -- let res = + -- in pprTrace "findStr" (ppr ty <+> int n <+> ppr res) res + findRecDemand str_fn abs_fn ty where str_fn val = foldl (absApply StrAnal) str_val (map (mk_arg val n) tys_w_index) diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs index f3a2ad0eb7..bc2174e3ee 100644 --- a/ghc/compiler/stranal/StrictAnal.lhs +++ b/ghc/compiler/stranal/StrictAnal.lhs @@ -328,7 +328,8 @@ addStrictnessInfoToId str_val abs_val binder body -- We could use 'collectBindersIgnoringNotes', but then the -- strictness info may have more items than the visible binders -- used by WorkWrap.tryWW - (binders, rhs) -> binder `setIdStrictness` + (binders, rhs) -> -- pprTrace "addStr" (ppr binder $$ ppr strictness) $ + binder `setIdStrictness` mkStrictnessInfo strictness where tys = [idType id | id <- binders, isId id] diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index 0633054990..de7f7d25fc 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -15,8 +15,9 @@ module WwLib ( import CoreSyn import Id ( Id, idType, mkSysLocal, getIdDemandInfo, setIdDemandInfo, - mkWildId ) -import IdInfo ( CprInfo(..), noCprInfo ) + mkWildId, setIdInfo + ) +import IdInfo ( CprInfo(..), noCprInfo, vanillaIdInfo ) import Const ( Con(..), DataCon ) import DataCon ( dataConArgTys ) import Demand ( Demand(..) ) @@ -561,14 +562,27 @@ mk_unpk_case NewType arg unpk_args boxing_con boxing_tycon body -- A newtype! Use a coercion not a case = ASSERT( null other_args ) Case (Note (Coerce (idType unpk_arg) (idType arg)) (Var arg)) - unpk_arg + (sanitiseCaseBndr unpk_arg) [(DEFAULT,[],body)] where (unpk_arg:other_args) = unpk_args mk_unpk_case DataType arg unpk_args boxing_con boxing_tycon body -- A data type - = Case (Var arg) arg [(DataCon boxing_con, unpk_args, body)] + = Case (Var arg) + (sanitiseCaseBndr arg) + [(DataCon boxing_con, unpk_args, body)] + +sanitiseCaseBndr :: Id -> Id +-- The argument we are scrutinising has the right type to be +-- a case binder, so it's convenient to re-use it for that purpose. +-- But we *must* throw away all its IdInfo. In particular, the argument +-- will have demand info on it, and that demand info may be incorrect for +-- the case binder. e.g. case ww_arg of ww_arg { I# x -> ... } +-- Quite likely ww_arg isn't used in '...'. The case may get discarded +-- if the case binder says "I'm demanded". This happened in a situation +-- like (x+y) `seq` .... +sanitiseCaseBndr id = id `setIdInfo` vanillaIdInfo mk_pk_let NewType arg boxing_con con_tys unpk_args body = ASSERT( null other_args ) diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 202dd14682..282b30ecdb 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -39,7 +39,7 @@ import Id ( getIdUnfolding ) import CoreUnfold ( getUnfoldingTemplate ) import FieldLabel import Var ( Id, TyVar ) -import Name ( Name, isLocallyDefined, OccName, NamedThing(..) ) +import Name ( Name, isLocallyDefined, OccName, NamedThing(..), nameUnique ) import Outputable import TyCon ( TyCon, ArgVrcs, mkSynTyCon, mkAlgTyCon, isAlgTyCon, isSynTyCon, tyConDataCons, isNewTyCon @@ -303,7 +303,18 @@ mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields) -- Check that all the fields in the group have the same type -- This check assumes that all the constructors of a given -- data type use the same type variables - = checkTc (all (== field_ty) other_tys) + = (if null other_fields then (\x->x) else + let lbls = [fieldLabelName f | (_,f) <- fields] + uniqs = [nameUnique l | l <- lbls] + + in + pprTrace "mkRecordSelector" (vcat [ppr fields, + ppr lbls, + ppr uniqs, + hsep [text (show (field_name `compare` fieldLabelName f)) | (_,f) <- fields] + ])) + + checkTc (all (== field_ty) other_tys) (fieldTypeMisMatch field_name) `thenTc_` returnTc selector_id where |