summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ghc/compiler/NOTES144
-rw-r--r--ghc/compiler/coreSyn/CoreUnfold.lhs1309
-rw-r--r--ghc/compiler/coreSyn/CoreUtils.lhs11
-rw-r--r--ghc/compiler/hsSyn/HsBinds.lhs2
-rw-r--r--ghc/compiler/prelude/PrimOp.lhs4766
-rw-r--r--ghc/compiler/rename/RnIfaces.lhs2
-rw-r--r--ghc/compiler/rename/RnNames.lhs1393
-rw-r--r--ghc/compiler/simplCore/FloatIn.lhs5
-rw-r--r--ghc/compiler/simplCore/FoldrBuildWW.lhs182
-rw-r--r--ghc/compiler/simplCore/MagicUFs.hi-boot6
-rw-r--r--ghc/compiler/simplCore/MagicUFs.hi-boot-54
-rw-r--r--ghc/compiler/simplCore/OccurAnal.lhs19
-rw-r--r--ghc/compiler/simplCore/Simplify.lhs2
-rw-r--r--ghc/compiler/specialise/Rules.lhs55
-rw-r--r--ghc/compiler/stranal/SaAbsInt.lhs4
-rw-r--r--ghc/compiler/stranal/StrictAnal.lhs3
-rw-r--r--ghc/compiler/typecheck/TcClassDcl.lhs120
-rw-r--r--ghc/compiler/typecheck/TcTyDecls.lhs13
18 files changed, 3880 insertions, 4160 deletions
diff --git a/ghc/compiler/NOTES b/ghc/compiler/NOTES
index 72b3be03b8..d0332b1115 100644
--- a/ghc/compiler/NOTES
+++ b/ghc/compiler/NOTES
@@ -1,28 +1,14 @@
-cvs remove TcGRHSs.hi-boot TcGRHSs.hi-boot-5 TcGRHSs.lhs
-cvs remove pbinding.ugn
-cvs add grhsb.ugn gdexp.ugn
-cvs add basicTypes/OccName.lhs
+Notes June 99
+~~~~~~~~~~~~~
+* In nofib/spectral/mandel2/Main.check_radius, there's a call to (fromIntegral m), where
+ m is defined at top level. The full-laziness pass doesn't catch this because by
+ the time it runs, enough inlining has happened that it looks like
+ case ccall ... of (# a,b #) -> ...
+ and the full laziness pass doesn't float unboxed things.
+* The same function is an excellent example of where liberate-case would be a win.
-New in 4.02
-* Scoped type variables
-* Warnings for unused variables should work now (they didn't before)
-* Simplifier improvements:
- - Much better treatment of strict arguments
- - Better treatment of bottoming Ids
- - No need for w/w split for fns that are merely strict
- - Fewer iterations needed, I hope
-* Less gratuitous renaming in interface files and abs C
-* OccName is a separate module, and is an abstract data type
-
------------------------
-
-
-* CHECK that the things seek_liftable found are done in Core
-
-* CHECK that there aren't too many indirections in STG
- local = ...
- global = local Int
+* Don't forget to try CSE
Interface files
~~~~~~~~~~~~~~~
@@ -37,115 +23,3 @@ Interface files
We can't say T(T,A,B) and T(A,B) to export or not-export T respectively,
because the type T might have a constructor T.
-===========================================================================
-
- Nofib failures
- ~~~~~~~~~~~~~~
-
-* spectral/hartel/wave4main, wang, spectral/simple, real/symalg
-
-Bus error
-
-* real/anna
-
-expected stdout not matched by reality
-*** big.sum.out Thu Aug 22 14:37:05 1996
---- /tmp/runtest21900.1 Mon Jan 20 17:57:49 1997
-***************
-*** 1 ****
-! 12796 49
---- 1 ----
-! 63325 97
-
-
-* /real/compress2
-
-expected stderr not matched by reality
-Warning: missing newline at end of file /tmp/runtest14691.2
-*** /tmp/no_stderr14691 Thu Jan 23 14:33:29 1997
---- /tmp/runtest14691.2 Thu Jan 23 14:33:29 1997
-***************
-*** 0 ****
---- 1,2 ----
-+
-+ Fail: Prelude.Enum.Char.toEnum:out of range
-
-
-* real/ebnf2ps
-
-IOSupplement.hs: 43: value not in scope: getEnv
-
- ...and...
-
-HappyParser.hs: 127: Couldn't match the type
- [HappyParser.Token'] against PrelBase.Int
- Expected: HappyParser.HappyReduction
- Inferred: PrelBase.Int -> HappyParser.Token' -> HappyParser.HappyState HappyParser.Token' ([HappyParser.HappyAbsSyn] -> [AbstractSyntax.Production]) -> PrelBase.Int -> PrelBase.Int -> o{-a1yN-} -> o{-a1yO-} -> [HappyParser.Token'] -> a{-a1yP-}
- In an equation for function HappyParser.action_1:
- HappyParser.action_1 _ = HappyParser.happyFail
-
-
-* GHC_ONLY/bugs/andy_cherry
-
-DataTypes.lhs: 3: Could not find valid interface file for `GenUtils'
-
-Need "make depend"
-
-* GHC_ONLY/bugs/lex
-
-Pattern match fail in lex; must be producing empty or multi-valued result
-
-Aggravated by dreadful error messages:
-+
-+ Fail: In irrefutable pattern
-+ Fail: In pattern-matching
-+ Fail: In pattern-matching
-+ Fail: In pattern-matching
-+ Fail: In pattern-matching
-+ Fail: In pattern-matching
-+ Fail: In pattern-matching
-+ Fail: In pattern-matching
-+ Fail: In pattern-matching
-+ Fail: In pattern-matching
-+ Fail: In pattern-matching
-+ Fail: In pattern-matching
-+ Fail: In pattern-matching
-+ Fail: In pattern-matching
-+ Fail: In pattern-matching
-+ Fail: In pattern-matchingtoo many nested calls to `error'
-
-
-* GHC_ONLY/bugs/jtod_circint
-
-Main.hs: 12: No instance for: Signal.Signal (Signal.Stream Bit.Bit)
- Main.hs: 12: at a use of an overloaded identifier: `Signal.one'
-
-instance-decl slurping is WRONG
-
-* GHC_ONLY/arith005
-
-ceiling doesn't work properly
-
---- 1,3 ----
-+ [1, 1, 2, 3, 4, 5, 0, -2, -3, -4, 1000013, 124, 101, 103, 1, 0, 17001, 0, 1, 4]
-+ [1, 1, 2, 3, 4, 5, 0, -2, -3, -4, 1000013, 124, 101, 103, 1, 0, 17001, 0, 1, 4]
- [0, 0, 2, 3, 4, 5, -1, -2, -3, -4, 1000012, 124, 101, 103, 1, 0, 17000, 0, 1, 4]
-***************
-*** 2,5 ****
- [0, 0, 2, 3, 4, 5, -1, -2, -3, -4, 1000012, 124, 101, 103, 1, 0, 17000, 0, 1, 4]
-- [0, 0, 2, 3, 4, 5, -1, -2, -3, -4, 1000012, 124, 101, 103, 1, 0, 17000, 0, 1, 4]
-- [0, 0, 2, 3, 4, 5, -1, -2, -3, -4, 1000012, 124, 101, 103, 1, 0, 17000, 0, 1, 4]
- [0, 0, 1, 2, 3, 4, -1, -3, -4, -5, 1000012, 123, 100, 102, 0, -1, 17000, -1, 0, 3]
---- 4,5 ----
-
-
-* GHC_ONLY/bugs/lennart_array
-
-Wrong array semantics (but who cares?)
-
-* GHC_ONLY/bugs/life_space_leak
-
--n *** sum I got:
-0 0
--n *** sum I expected:
-02845 1350
diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index a42e65949d..39740c7938 100644
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -1,647 +1,662 @@
-%
-% (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.
-
+%
+% (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 [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
+
+ ------------
+ size_up_app (App fun arg) args = size_up_app fun (arg:args)
+ size_up_app fun args = foldr (addSize . size_up) (fun_discount fun) args
+
+ -- A function application with at least one value argument
+ -- so if the function is an argument give it an arg-discount
+ -- Also behave specially if the function is a build
+ fun_discount (Var fun) | idUnique fun == buildIdKey = buildSize
+ | fun `is_elem` args = scrutArg fun
+ fun_discount other = sizeZero
+
+ ------------
+ 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.
+
+buildSize = SizeIs (-2#) emptyBag 4#
+ -- We really want to inline applications of build
+ -- build t (\cn -> e) should cost only the cost of e (because build will be inlined later)
+ -- Indeed, we should add a result_discount becuause build is
+ -- very like a constructor. We don't bother to check that the
+ -- build is saturated (it usually is). The "-2" discounts for the \c n
+ -- The "4" is rather arbitrary.
+
+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.
+ = WARN( case in_lam of { NotInsideLam -> True; other -> False },
+ text "callSiteInline:oneOcc" <+> ppr id )
+ -- If it has one occurrence, not inside a lambda, PreInlineUnconditionally
+ -- should have zapped it already
+ 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
+ -- evidence 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/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index 4e3b22ea00..49bbf15126 100644
--- a/ghc/compiler/coreSyn/CoreUtils.lhs
+++ b/ghc/compiler/coreSyn/CoreUtils.lhs
@@ -149,10 +149,13 @@ mkFormSummary expr
-- We want selectors to look like values
-- e.g. case x of { (a,b) -> a }
- -- should give a ValueForm, so that it will be inlined
- -- vigorously
- go n expr@(Case _ _ _) | exprIsCheap expr = ValueForm
- | otherwise = OtherForm
+ -- should give a ValueForm, so that it will be inlined vigorously
+ -- [June 99. I can't remember why this is a good idea. It means that
+ -- all overloading selectors get inlined at their usage sites, which is
+ -- not at all necessarily a good thing. So I'm rescinding this decision for now.]
+-- go n expr@(Case _ _ _) | exprIsCheap expr = ValueForm
+
+ go n expr@(Case _ _ _) = OtherForm
go 0 (Lam x e) | isId x = ValueForm -- NB: \x.bottom /= bottom!
| otherwise = go 0 e
diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs
index 8a559f3f8e..375fe31ef6 100644
--- a/ghc/compiler/hsSyn/HsBinds.lhs
+++ b/ghc/compiler/hsSyn/HsBinds.lhs
@@ -194,7 +194,7 @@ ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
= sep [ptext SLIT("AbsBinds"),
brackets (interpp'SP tyvars),
brackets (interpp'SP dictvars),
- brackets (interpp'SP exports),
+ brackets (sep (punctuate comma (map ppr exports))),
brackets (interpp'SP (nameSetToList inlines))]
$$
nest 4 (ppr val_binds)
diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs
index 24bead229e..41793af100 100644
--- a/ghc/compiler/prelude/PrimOp.lhs
+++ b/ghc/compiler/prelude/PrimOp.lhs
@@ -1,2382 +1,2384 @@
-%
-% (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}
+%
+% (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 _ _ might_gc _) = not might_gc
+ -- If the ccall can't GC then the call is pretty cheap, and
+ -- we're happy to duplicate
+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/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index deff6b7ea5..ff32230fef 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -13,7 +13,7 @@ module RnIfaces (
checkUpToDate,
- getDeclBinders
+ getDeclBinders, getDeclSysBinders
) where
#include "HsVersions.h"
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 633735bd1c..4df3ffbf3e 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -1,694 +1,699 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section[RnNames]{Extracting imported and top-level names in scope}
-
-\begin{code}
-module RnNames (
- getGlobalNames
- ) where
-
-#include "HsVersions.h"
-
-import CmdLineOpts ( opt_NoImplicitPrelude, opt_WarnDuplicateExports,
- opt_SourceUnchanged, opt_WarnUnusedBinds
- )
-
-import HsSyn ( HsModule(..), HsDecl(..), TyClDecl(..),
- IE(..), ieName,
- ForeignDecl(..), ForKind(..), isDynamic,
- FixitySig(..), Sig(..), ImportDecl(..),
- collectTopBinders
- )
-import RdrHsSyn ( RdrNameIE, RdrNameImportDecl,
- RdrNameHsModule, RdrNameHsDecl
- )
-import RnIfaces ( getInterfaceExports, getDeclBinders,
- recordSlurp, checkUpToDate
- )
-import RnEnv
-import RnMonad
-
-import FiniteMap
-import PrelMods
-import PrelInfo ( main_RDR )
-import UniqFM ( lookupUFM )
-import Bag ( bagToList )
-import Maybes ( maybeToBool )
-import Module ( ModuleName, mkThisModule, pprModuleName, WhereFrom(..) )
-import NameSet
-import Name ( Name, ExportFlag(..), ImportReason(..), Provenance(..),
- isLocallyDefined, setNameProvenance,
- nameOccName, getSrcLoc, pprProvenance, getNameProvenance
- )
-import RdrName ( RdrName, rdrNameOcc, mkRdrQual, mkRdrUnqual, isQual )
-import SrcLoc ( SrcLoc )
-import NameSet ( elemNameSet, emptyNameSet )
-import Outputable
-import Unique ( getUnique )
-import Util ( removeDups, equivClassesByUniq, sortLt )
-import List ( partition )
-\end{code}
-
-
-
-%************************************************************************
-%* *
-\subsection{Get global names}
-%* *
-%************************************************************************
-
-\begin{code}
-getGlobalNames :: RdrNameHsModule
- -> RnMG (Maybe (ExportEnv,
- GlobalRdrEnv,
- FixityEnv, -- Fixities for local decls only
- NameEnv AvailInfo -- Maps a name to its parent AvailInfo
- -- Just for in-scope things only
- ))
- -- Nothing => no need to recompile
-
-getGlobalNames (HsModule this_mod _ exports imports decls mod_loc)
- = -- These two fix-loops are to get the right
- -- provenance information into a Name
- fixRn (\ ~(rec_gbl_env, rec_exported_avails, _) ->
-
- let
- rec_unqual_fn :: Name -> Bool -- Is this chap in scope unqualified?
- rec_unqual_fn = unQualInScope rec_gbl_env
-
- rec_exp_fn :: Name -> ExportFlag
- rec_exp_fn = mk_export_fn (availsToNameSet rec_exported_avails)
- in
- setModuleRn this_mod $
-
- -- PROCESS LOCAL DECLS
- -- Do these *first* so that the correct provenance gets
- -- into the global name cache.
- importsFromLocalDecls this_mod rec_exp_fn decls `thenRn` \ (local_gbl_env, local_mod_avails) ->
-
- -- PROCESS IMPORT DECLS
- -- Do the non {- SOURCE -} ones first, so that we get a helpful
- -- warning for {- SOURCE -} ones that are unnecessary
- let
- (source, ordinary) = partition is_source_import all_imports
- is_source_import (ImportDecl _ ImportByUserSource _ _ _ _) = True
- is_source_import other = False
- in
- mapAndUnzipRn (importsFromImportDecl rec_unqual_fn) ordinary `thenRn` \ (imp_gbl_envs1, imp_avails_s1) ->
- mapAndUnzipRn (importsFromImportDecl rec_unqual_fn) source `thenRn` \ (imp_gbl_envs2, imp_avails_s2) ->
-
- -- COMBINE RESULTS
- -- We put the local env second, so that a local provenance
- -- "wins", even if a module imports itself.
- let
- gbl_env :: GlobalRdrEnv
- imp_gbl_env = foldr plusGlobalRdrEnv emptyRdrEnv (imp_gbl_envs2 ++ imp_gbl_envs1)
- gbl_env = imp_gbl_env `plusGlobalRdrEnv` local_gbl_env
-
- all_avails :: ExportAvails
- all_avails = foldr plusExportAvails local_mod_avails (imp_avails_s2 ++ imp_avails_s1)
- in
-
- -- TRY FOR EARLY EXIT
- -- We can't go for an early exit before this because we have to check
- -- for name clashes. Consider:
- --
- -- module A where module B where
- -- import B h = True
- -- f = h
- --
- -- Suppose I've compiled everything up, and then I add a
- -- new definition to module B, that defines "f".
- --
- -- Then I must detect the name clash in A before going for an early
- -- exit. The early-exit code checks what's actually needed from B
- -- to compile A, and of course that doesn't include B.f. That's
- -- why we wait till after the plusEnv stuff to do the early-exit.
- checkEarlyExit this_mod `thenRn` \ up_to_date ->
- if up_to_date then
- returnRn (gbl_env, junk_exp_fn, Nothing)
- else
-
- -- RECORD BETTER PROVENANCES IN THE CACHE
- -- The names in the envirnoment have better provenances (e.g. imported on line x)
- -- than the names in the name cache. We update the latter now, so that we
- -- we start renaming declarations we'll get the good names
- -- The isQual is because the qualified name is always in scope
- updateProvenances (concat [names | (rdr_name, names) <- rdrEnvToList imp_gbl_env,
- isQual rdr_name]) `thenRn_`
-
- -- PROCESS EXPORT LISTS
- exportsFromAvail this_mod exports all_avails gbl_env `thenRn` \ exported_avails ->
-
- -- DONE
- returnRn (gbl_env, exported_avails, Just all_avails)
- ) `thenRn` \ (gbl_env, exported_avails, maybe_stuff) ->
-
- case maybe_stuff of {
- Nothing -> returnRn Nothing ;
- Just all_avails ->
-
- traceRn (text "updateProv" <+> fsep (map ppr (rdrEnvElts gbl_env))) `thenRn_`
-
- -- DEAL WITH FIXITIES
- fixitiesFromLocalDecls gbl_env decls `thenRn` \ local_fixity_env ->
- let
- -- Export only those fixities that are for names that are
- -- (a) defined in this module
- -- (b) exported
- exported_fixities :: [(Name,Fixity)]
- exported_fixities = [(name,fixity) | FixitySig name fixity _ <- nameEnvElts local_fixity_env,
- isLocallyDefined name
- ]
- in
- traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts local_fixity_env))) `thenRn_`
-
- --- TIDY UP
- let
- export_env = ExportEnv exported_avails exported_fixities
- (_, global_avail_env) = all_avails
- in
- returnRn (Just (export_env, gbl_env, local_fixity_env, global_avail_env))
- }
- where
- junk_exp_fn = error "RnNames:export_fn"
-
- all_imports = prel_imports ++ imports
-
- -- NB: opt_NoImplicitPrelude is slightly different to import Prelude ();
- -- because the former doesn't even look at Prelude.hi for instance declarations,
- -- whereas the latter does.
- prel_imports | this_mod == pRELUDE_Name ||
- explicit_prelude_import ||
- opt_NoImplicitPrelude
- = []
-
- | otherwise = [ImportDecl pRELUDE_Name
- ImportByUser
- False {- Not qualified -}
- Nothing {- No "as" -}
- Nothing {- No import list -}
- mod_loc]
-
- explicit_prelude_import
- = not (null [ () | (ImportDecl mod _ _ _ _ _) <- imports, mod == pRELUDE_Name ])
-\end{code}
-
-\begin{code}
-checkEarlyExit mod
- = checkErrsRn `thenRn` \ no_errs_so_far ->
- if not no_errs_so_far then
- -- Found errors already, so exit now
- returnRn True
- else
-
- traceRn (text "Considering whether compilation is required...") `thenRn_`
- if not opt_SourceUnchanged then
- -- Source code changed and no errors yet... carry on
- traceRn (nest 4 (text "source file changed or recompilation check turned off")) `thenRn_`
- returnRn False
- else
-
- -- Unchanged source, and no errors yet; see if usage info
- -- up to date, and exit if so
- checkUpToDate mod `thenRn` \ up_to_date ->
- putDocRn (text "Compilation" <+>
- text (if up_to_date then "IS NOT" else "IS") <+>
- text "required") `thenRn_`
- returnRn up_to_date
-\end{code}
-
-\begin{code}
-importsFromImportDecl :: (Name -> Bool) -- OK to omit qualifier
- -> RdrNameImportDecl
- -> RnMG (GlobalRdrEnv,
- ExportAvails)
-
-importsFromImportDecl is_unqual (ImportDecl imp_mod_name from qual_only as_mod import_spec iloc)
- = pushSrcLocRn iloc $
- getInterfaceExports imp_mod_name from `thenRn` \ (imp_mod, avails) ->
-
- if null avails then
- -- If there's an error in getInterfaceExports, (e.g. interface
- -- file not found) we get lots of spurious errors from 'filterImports'
- returnRn (emptyRdrEnv, mkEmptyExportAvails imp_mod_name)
- else
-
- filterImports imp_mod_name import_spec avails `thenRn` \ (filtered_avails, hides, explicits) ->
-
- -- We 'improve' the provenance by setting
- -- (a) the import-reason field, so that the Name says how it came into scope
- -- including whether it's explicitly imported
- -- (b) the print-unqualified field
- -- But don't fiddle with wired-in things or we get in a twist
- let
- improve_prov name = setNameProvenance name (NonLocalDef (UserImport imp_mod iloc (is_explicit name))
- (is_unqual name))
- is_explicit name = name `elemNameSet` explicits
- in
- qualifyImports imp_mod_name
- (not qual_only) -- Maybe want unqualified names
- as_mod hides
- filtered_avails improve_prov `thenRn` \ (rdr_name_env, mod_avails) ->
-
- returnRn (rdr_name_env, mod_avails)
-\end{code}
-
-
-\begin{code}
-importsFromLocalDecls mod_name rec_exp_fn decls
- = mapRn (getLocalDeclBinders newLocalName) decls `thenRn` \ avails_s ->
-
- let
- avails = concat avails_s
-
- all_names :: [Name] -- All the defns; no dups eliminated
- all_names = [name | avail <- avails, name <- availNames avail]
-
- dups :: [[Name]]
- dups = filter non_singleton (equivClassesByUniq getUnique all_names)
- where
- non_singleton (x1:x2:xs) = True
- non_singleton other = False
- in
- -- Check for duplicate definitions
- mapRn_ (addErrRn . dupDeclErr) dups `thenRn_`
-
- -- Record that locally-defined things are available
- mapRn_ (recordSlurp Nothing) avails `thenRn_`
-
- -- Build the environment
- qualifyImports mod_name
- True -- Want unqualified names
- Nothing -- no 'as M'
- [] -- Hide nothing
- avails
- (\n -> n)
-
- where
- newLocalName rdr_name loc = newLocalTopBinder mod (rdrNameOcc rdr_name)
- rec_exp_fn loc
- mod = mkThisModule mod_name
-
-getLocalDeclBinders :: (RdrName -> SrcLoc -> RnMG Name) -- New-name function
- -> RdrNameHsDecl
- -> RnMG Avails
-getLocalDeclBinders new_name (ValD binds)
- = mapRn do_one (bagToList (collectTopBinders binds))
- where
- do_one (rdr_name, loc) = new_name rdr_name loc `thenRn` \ name ->
- returnRn (Avail name)
-
- -- foreign declarations
-getLocalDeclBinders new_name (ForD (ForeignDecl nm kind _ dyn _ loc))
- | binds_haskell_name kind dyn
- = new_name nm loc `thenRn` \ name ->
- returnRn [Avail name]
-
- | otherwise
- = returnRn []
-
-getLocalDeclBinders new_name decl
- = getDeclBinders new_name decl `thenRn` \ maybe_avail ->
- case maybe_avail of
- Nothing -> returnRn [] -- Instance decls and suchlike
- Just avail -> returnRn [avail]
-
-binds_haskell_name (FoImport _) _ = True
-binds_haskell_name FoLabel _ = True
-binds_haskell_name FoExport ext_nm = isDynamic ext_nm
-
-fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG FixityEnv
-fixitiesFromLocalDecls gbl_env decls
- = foldlRn getFixities emptyNameEnv decls
- where
- getFixities :: FixityEnv -> RdrNameHsDecl -> RnMG FixityEnv
- getFixities acc (FixD fix)
- = fix_decl acc fix
-
- getFixities acc (TyClD (ClassDecl _ _ _ sigs _ _ _ _ _ _))
- = foldlRn fix_decl acc [sig | FixSig sig <- sigs]
- -- Get fixities from class decl sigs too.
- getFixities acc other_decl
- = returnRn acc
-
- fix_decl acc sig@(FixitySig rdr_name fixity loc)
- = -- Check for fixity decl for something not declared
- case lookupRdrEnv gbl_env rdr_name of {
- Nothing | opt_WarnUnusedBinds
- -> pushSrcLocRn loc (addWarnRn (unusedFixityDecl rdr_name fixity)) `thenRn_`
- returnRn acc
- | otherwise -> returnRn acc ;
-
- Just (name:_) ->
-
- -- Check for duplicate fixity decl
- case lookupNameEnv acc name of {
- Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc') `thenRn_`
- returnRn acc ;
-
- Nothing -> returnRn (addToNameEnv acc name (FixitySig name fixity loc))
- }}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Filtering imports}
-%* *
-%************************************************************************
-
-@filterImports@ takes the @ExportEnv@ telling what the imported module makes
-available, and filters it through the import spec (if any).
-
-\begin{code}
-filterImports :: ModuleName -- The module being imported
- -> Maybe (Bool, [RdrNameIE]) -- Import spec; True => hiding
- -> [AvailInfo] -- What's available
- -> RnMG ([AvailInfo], -- What's actually imported
- [AvailInfo], -- What's to be hidden (the unqualified version, that is)
- NameSet) -- What was imported explicitly
-
- -- Complains if import spec mentions things that the module doesn't export
- -- Warns/informs if import spec contains duplicates.
-filterImports mod Nothing imports
- = returnRn (imports, [], emptyNameSet)
-
-filterImports mod (Just (want_hiding, import_items)) avails
- = mapMaybeRn check_item import_items `thenRn` \ avails_w_explicits ->
- let
- (item_avails, explicits_s) = unzip avails_w_explicits
- explicits = foldl addListToNameSet emptyNameSet explicits_s
- in
- if want_hiding
- then
- -- All imported; item_avails to be hidden
- returnRn (avails, item_avails, emptyNameSet)
- else
- -- Just item_avails imported; nothing to be hidden
- returnRn (item_avails, [], explicits)
- where
- import_fm :: FiniteMap OccName AvailInfo
- import_fm = listToFM [ (nameOccName name, avail)
- | avail <- avails,
- name <- availNames avail]
- -- Even though availNames returns data constructors too,
- -- they won't make any difference because naked entities like T
- -- in an import list map to TcOccs, not VarOccs.
-
- check_item item@(IEModuleContents _)
- = addErrRn (badImportItemErr mod item) `thenRn_`
- returnRn Nothing
-
- check_item item
- | not (maybeToBool maybe_in_import_avails) ||
- not (maybeToBool maybe_filtered_avail)
- = addErrRn (badImportItemErr mod item) `thenRn_`
- returnRn Nothing
-
- | dodgy_import = addWarnRn (dodgyImportWarn mod item) `thenRn_`
- returnRn (Just (filtered_avail, explicits))
-
- | otherwise = returnRn (Just (filtered_avail, explicits))
-
- where
- wanted_occ = rdrNameOcc (ieName item)
- maybe_in_import_avails = lookupFM import_fm wanted_occ
-
- Just avail = maybe_in_import_avails
- maybe_filtered_avail = filterAvail item avail
- Just filtered_avail = maybe_filtered_avail
- explicits | dot_dot = [availName filtered_avail]
- | otherwise = availNames filtered_avail
-
- dot_dot = case item of
- IEThingAll _ -> True
- other -> False
-
- dodgy_import = case (item, avail) of
- (IEThingAll _, AvailTC _ [n]) -> True
- -- This occurs when you import T(..), but
- -- only export T abstractly. The single [n]
- -- in the AvailTC is the type or class itself
-
- other -> False
-\end{code}
-
-
-
-%************************************************************************
-%* *
-\subsection{Qualifiying imports}
-%* *
-%************************************************************************
-
-@qualifyImports@ takes the @ExportEnv@ after filtering through the import spec
-of an import decl, and deals with producing an @RnEnv@ with the
-right qualified names. It also turns the @Names@ in the @ExportEnv@ into
-fully fledged @Names@.
-
-\begin{code}
-qualifyImports :: ModuleName -- Imported module
- -> Bool -- True <=> want unqualified import
- -> Maybe ModuleName -- Optional "as M" part
- -> [AvailInfo] -- What's to be hidden
- -> Avails -- Whats imported and how
- -> (Name -> Name) -- Improves the provenance on imported things
- -> RnMG (GlobalRdrEnv, ExportAvails)
- -- NB: the Names in ExportAvails don't have the improve-provenance
- -- function applied to them
- -- We could fix that, but I don't think it matters
-
-qualifyImports this_mod unqual_imp as_mod hides
- avails improve_prov
- =
- -- Make the name environment. We're talking about a
- -- single module here, so there must be no name clashes.
- -- In practice there only ever will be if it's the module
- -- being compiled.
- let
- -- Add the things that are available
- name_env1 = foldl add_avail emptyRdrEnv avails
-
- -- Delete things that are hidden
- name_env2 = foldl del_avail name_env1 hides
-
- -- Create the export-availability info
- export_avails = mkExportAvails qual_mod unqual_imp name_env2 avails
- in
- returnRn (name_env2, export_avails)
-
- where
- qual_mod = case as_mod of
- Nothing -> this_mod
- Just another_name -> another_name
-
- add_avail :: GlobalRdrEnv -> AvailInfo -> GlobalRdrEnv
- add_avail env avail = foldl add_name env (availNames avail)
-
- add_name env name
- | unqual_imp = env2
- | otherwise = env1
- where
- env1 = addOneToGlobalRdrEnv env (mkRdrQual qual_mod occ) better_name
- env2 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ) better_name
- occ = nameOccName name
- better_name = improve_prov name
-
- del_avail env avail = foldl delOneFromGlobalRdrEnv env rdr_names
- where
- rdr_names = map (mkRdrUnqual . nameOccName) (availNames avail)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Export list processing
-%* *
-%************************************************************************
-
-Processing the export list.
-
-You might think that we should record things that appear in the export list as
-``occurrences'' (using addOccurrenceName), but you'd be wrong. We do check (here)
-that they are in scope, but there is no need to slurp in their actual declaration
-(which is what addOccurrenceName forces). Indeed, doing so would big trouble when
-compiling PrelBase, because it re-exports GHC, which includes takeMVar#, whose type
-includes ConcBase.StateAndSynchVar#, and so on...
-
-\begin{code}
-type ExportAccum -- The type of the accumulating parameter of
- -- the main worker function in exportsFromAvail
- = ([ModuleName], -- 'module M's seen so far
- ExportOccMap, -- Tracks exported occurrence names
- NameEnv AvailInfo) -- The accumulated exported stuff, kept in an env
- -- so we can common-up related AvailInfos
-
-type ExportOccMap = FiniteMap OccName (Name, RdrNameIE)
- -- Tracks what a particular exported OccName
- -- in an export list refers to, and which item
- -- it came from. It's illegal to export two distinct things
- -- that have the same occurrence name
-
-
-exportsFromAvail :: ModuleName
- -> Maybe [RdrNameIE] -- Export spec
- -> ExportAvails
- -> GlobalRdrEnv
- -> RnMG Avails
- -- Complains if two distinct exports have same OccName
- -- Warns about identical exports.
- -- Complains about exports items not in scope
-exportsFromAvail this_mod Nothing export_avails global_name_env
- = exportsFromAvail this_mod true_exports export_avails global_name_env
- where
- true_exports = Just $ if this_mod == mAIN_Name
- then [IEVar main_RDR]
- -- export Main.main *only* unless otherwise specified,
- else [IEModuleContents this_mod]
- -- but for all other modules export everything.
-
-exportsFromAvail this_mod (Just export_items)
- (mod_avail_env, entity_avail_env)
- global_name_env
- = foldlRn exports_from_item
- ([], emptyFM, emptyNameEnv) export_items `thenRn` \ (_, _, export_avail_map) ->
- let
- export_avails :: [AvailInfo]
- export_avails = nameEnvElts export_avail_map
- in
- returnRn export_avails
-
- where
- exports_from_item :: ExportAccum -> RdrNameIE -> RnMG ExportAccum
-
- exports_from_item acc@(mods, occs, avails) ie@(IEModuleContents mod)
- | mod `elem` mods -- Duplicate export of M
- = warnCheckRn opt_WarnDuplicateExports
- (dupModuleExport mod) `thenRn_`
- returnRn acc
-
- | otherwise
- = case lookupFM mod_avail_env mod of
- Nothing -> failWithRn acc (modExportErr mod)
- Just mod_avails -> foldlRn (check_occs ie) occs mod_avails `thenRn` \ occs' ->
- let
- avails' = foldl add_avail avails mod_avails
- in
- returnRn (mod:mods, occs', avails')
-
- exports_from_item acc@(mods, occs, avails) ie
- | not (maybeToBool maybe_in_scope)
- = failWithRn acc (unknownNameErr (ieName ie))
-
- | not (null dup_names)
- = addNameClashErrRn rdr_name (name:dup_names) `thenRn_`
- returnRn acc
-
-#ifdef DEBUG
- -- I can't see why this should ever happen; if the thing is in scope
- -- at all it ought to have some availability
- | not (maybeToBool maybe_avail)
- = pprTrace "exportsFromAvail: curious Nothing:" (ppr name)
- returnRn acc
-#endif
-
- | not enough_avail
- = failWithRn acc (exportItemErr ie)
-
- | otherwise -- Phew! It's OK! Now to check the occurrence stuff!
- = check_occs ie occs export_avail `thenRn` \ occs' ->
- returnRn (mods, occs', add_avail avails export_avail)
-
- where
- rdr_name = ieName ie
- maybe_in_scope = lookupFM global_name_env rdr_name
- Just (name:dup_names) = maybe_in_scope
- maybe_avail = lookupUFM entity_avail_env name
- Just avail = maybe_avail
- maybe_export_avail = filterAvail ie avail
- enough_avail = maybeToBool maybe_export_avail
- Just export_avail = maybe_export_avail
-
-add_avail avails avail = addToNameEnv_C plusAvail avails (availName avail) avail
-
-check_occs :: RdrNameIE -> ExportOccMap -> AvailInfo -> RnMG ExportOccMap
-check_occs ie occs avail
- = foldlRn check occs (availNames avail)
- where
- check occs name
- = case lookupFM occs name_occ of
- Nothing -> returnRn (addToFM occs name_occ (name, ie))
- Just (name', ie')
- | name == name' -> -- Duplicate export
- warnCheckRn opt_WarnDuplicateExports
- (dupExportWarn name_occ ie ie') `thenRn_`
- returnRn occs
-
- | otherwise -> -- Same occ name but different names: an error
- failWithRn occs (exportClashErr name_occ ie ie')
- where
- name_occ = nameOccName name
-
-mk_export_fn :: NameSet -> (Name -> ExportFlag)
-mk_export_fn exported_names
- = \name -> if name `elemNameSet` exported_names
- then Exported
- else NotExported
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Errors}
-%* *
-%************************************************************************
-
-\begin{code}
-badImportItemErr mod ie
- = sep [ptext SLIT("Module"), quotes (pprModuleName mod),
- ptext SLIT("does not export"), quotes (ppr ie)]
-
-dodgyImportWarn mod (IEThingAll tc)
- = sep [ptext SLIT("Module") <+> quotes (pprModuleName mod) <+> ptext SLIT("exports") <+> quotes (ppr tc),
- ptext SLIT("with no constructors/class operations;"),
- ptext SLIT("yet it is imported with a (..)")]
-
-modExportErr mod
- = hsep [ ptext SLIT("Unknown module in export list: module"), quotes (pprModuleName mod)]
-
-exportItemErr export_item
- = sep [ ptext SLIT("Bad export item"), quotes (ppr export_item)]
-
-exportClashErr occ_name ie1 ie2
- = hsep [ptext SLIT("The export items"), quotes (ppr ie1), ptext SLIT("and"), quotes (ppr ie2),
- ptext SLIT("create conflicting exports for"), quotes (ppr occ_name)]
-
-dupDeclErr (n:ns)
- = vcat [ptext SLIT("Multiple declarations of") <+> quotes (ppr n),
- nest 4 (vcat (map pp sorted_ns))]
- where
- sorted_ns = sortLt occ'ed_before (n:ns)
-
- occ'ed_before a b = LT == compare (getSrcLoc a) (getSrcLoc b)
-
- pp n = pprProvenance (getNameProvenance n)
-
-dupExportWarn occ_name ie1 ie2
- = hsep [quotes (ppr occ_name),
- ptext SLIT("is exported by"), quotes (ppr ie1),
- ptext SLIT("and"), quotes (ppr ie2)]
-
-dupModuleExport mod
- = hsep [ptext SLIT("Duplicate"),
- quotes (ptext SLIT("Module") <+> pprModuleName mod),
- ptext SLIT("in export list")]
-
-unusedFixityDecl rdr_name fixity
- = hsep [ptext SLIT("Unused fixity declaration for"), quotes (ppr rdr_name)]
-
-dupFixityDecl rdr_name loc1 loc2
- = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
- ptext SLIT("at ") <+> ppr loc1,
- ptext SLIT("and") <+> ppr loc2]
-
-\end{code}
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+\section[RnNames]{Extracting imported and top-level names in scope}
+
+\begin{code}
+module RnNames (
+ getGlobalNames
+ ) where
+
+#include "HsVersions.h"
+
+import CmdLineOpts ( opt_NoImplicitPrelude, opt_WarnDuplicateExports,
+ opt_SourceUnchanged, opt_WarnUnusedBinds
+ )
+
+import HsSyn ( HsModule(..), HsDecl(..), TyClDecl(..),
+ IE(..), ieName,
+ ForeignDecl(..), ForKind(..), isDynamic,
+ FixitySig(..), Sig(..), ImportDecl(..),
+ collectTopBinders
+ )
+import RdrHsSyn ( RdrNameIE, RdrNameImportDecl,
+ RdrNameHsModule, RdrNameHsDecl
+ )
+import RnIfaces ( getInterfaceExports, getDeclBinders, getDeclSysBinders,
+ recordSlurp, checkUpToDate
+ )
+import RnEnv
+import RnMonad
+
+import FiniteMap
+import PrelMods
+import PrelInfo ( main_RDR )
+import UniqFM ( lookupUFM )
+import Bag ( bagToList )
+import Maybes ( maybeToBool )
+import Module ( ModuleName, mkThisModule, pprModuleName, WhereFrom(..) )
+import NameSet
+import Name ( Name, ExportFlag(..), ImportReason(..), Provenance(..),
+ isLocallyDefined, setNameProvenance,
+ nameOccName, getSrcLoc, pprProvenance, getNameProvenance
+ )
+import RdrName ( RdrName, rdrNameOcc, mkRdrQual, mkRdrUnqual, isQual )
+import SrcLoc ( SrcLoc )
+import NameSet ( elemNameSet, emptyNameSet )
+import Outputable
+import Unique ( getUnique )
+import Util ( removeDups, equivClassesByUniq, sortLt )
+import List ( partition )
+\end{code}
+
+
+
+%************************************************************************
+%* *
+\subsection{Get global names}
+%* *
+%************************************************************************
+
+\begin{code}
+getGlobalNames :: RdrNameHsModule
+ -> RnMG (Maybe (ExportEnv,
+ GlobalRdrEnv,
+ FixityEnv, -- Fixities for local decls only
+ NameEnv AvailInfo -- Maps a name to its parent AvailInfo
+ -- Just for in-scope things only
+ ))
+ -- Nothing => no need to recompile
+
+getGlobalNames (HsModule this_mod _ exports imports decls mod_loc)
+ = -- These two fix-loops are to get the right
+ -- provenance information into a Name
+ fixRn (\ ~(rec_gbl_env, rec_exported_avails, _) ->
+
+ let
+ rec_unqual_fn :: Name -> Bool -- Is this chap in scope unqualified?
+ rec_unqual_fn = unQualInScope rec_gbl_env
+
+ rec_exp_fn :: Name -> ExportFlag
+ rec_exp_fn = mk_export_fn (availsToNameSet rec_exported_avails)
+ in
+ setModuleRn this_mod $
+
+ -- PROCESS LOCAL DECLS
+ -- Do these *first* so that the correct provenance gets
+ -- into the global name cache.
+ importsFromLocalDecls this_mod rec_exp_fn decls `thenRn` \ (local_gbl_env, local_mod_avails) ->
+
+ -- PROCESS IMPORT DECLS
+ -- Do the non {- SOURCE -} ones first, so that we get a helpful
+ -- warning for {- SOURCE -} ones that are unnecessary
+ let
+ (source, ordinary) = partition is_source_import all_imports
+ is_source_import (ImportDecl _ ImportByUserSource _ _ _ _) = True
+ is_source_import other = False
+ in
+ mapAndUnzipRn (importsFromImportDecl rec_unqual_fn) ordinary `thenRn` \ (imp_gbl_envs1, imp_avails_s1) ->
+ mapAndUnzipRn (importsFromImportDecl rec_unqual_fn) source `thenRn` \ (imp_gbl_envs2, imp_avails_s2) ->
+
+ -- COMBINE RESULTS
+ -- We put the local env second, so that a local provenance
+ -- "wins", even if a module imports itself.
+ let
+ gbl_env :: GlobalRdrEnv
+ imp_gbl_env = foldr plusGlobalRdrEnv emptyRdrEnv (imp_gbl_envs2 ++ imp_gbl_envs1)
+ gbl_env = imp_gbl_env `plusGlobalRdrEnv` local_gbl_env
+
+ all_avails :: ExportAvails
+ all_avails = foldr plusExportAvails local_mod_avails (imp_avails_s2 ++ imp_avails_s1)
+ in
+
+ -- TRY FOR EARLY EXIT
+ -- We can't go for an early exit before this because we have to check
+ -- for name clashes. Consider:
+ --
+ -- module A where module B where
+ -- import B h = True
+ -- f = h
+ --
+ -- Suppose I've compiled everything up, and then I add a
+ -- new definition to module B, that defines "f".
+ --
+ -- Then I must detect the name clash in A before going for an early
+ -- exit. The early-exit code checks what's actually needed from B
+ -- to compile A, and of course that doesn't include B.f. That's
+ -- why we wait till after the plusEnv stuff to do the early-exit.
+ checkEarlyExit this_mod `thenRn` \ up_to_date ->
+ if up_to_date then
+ returnRn (gbl_env, junk_exp_fn, Nothing)
+ else
+
+ -- RECORD BETTER PROVENANCES IN THE CACHE
+ -- The names in the envirnoment have better provenances (e.g. imported on line x)
+ -- than the names in the name cache. We update the latter now, so that we
+ -- we start renaming declarations we'll get the good names
+ -- The isQual is because the qualified name is always in scope
+ updateProvenances (concat [names | (rdr_name, names) <- rdrEnvToList imp_gbl_env,
+ isQual rdr_name]) `thenRn_`
+
+ -- PROCESS EXPORT LISTS
+ exportsFromAvail this_mod exports all_avails gbl_env `thenRn` \ exported_avails ->
+
+ -- DONE
+ returnRn (gbl_env, exported_avails, Just all_avails)
+ ) `thenRn` \ (gbl_env, exported_avails, maybe_stuff) ->
+
+ case maybe_stuff of {
+ Nothing -> returnRn Nothing ;
+ Just all_avails ->
+
+ traceRn (text "updateProv" <+> fsep (map ppr (rdrEnvElts gbl_env))) `thenRn_`
+
+ -- DEAL WITH FIXITIES
+ fixitiesFromLocalDecls gbl_env decls `thenRn` \ local_fixity_env ->
+ let
+ -- Export only those fixities that are for names that are
+ -- (a) defined in this module
+ -- (b) exported
+ exported_fixities :: [(Name,Fixity)]
+ exported_fixities = [(name,fixity) | FixitySig name fixity _ <- nameEnvElts local_fixity_env,
+ isLocallyDefined name
+ ]
+ in
+ traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts local_fixity_env))) `thenRn_`
+
+ --- TIDY UP
+ let
+ export_env = ExportEnv exported_avails exported_fixities
+ (_, global_avail_env) = all_avails
+ in
+ returnRn (Just (export_env, gbl_env, local_fixity_env, global_avail_env))
+ }
+ where
+ junk_exp_fn = error "RnNames:export_fn"
+
+ all_imports = prel_imports ++ imports
+
+ -- NB: opt_NoImplicitPrelude is slightly different to import Prelude ();
+ -- because the former doesn't even look at Prelude.hi for instance declarations,
+ -- whereas the latter does.
+ prel_imports | this_mod == pRELUDE_Name ||
+ explicit_prelude_import ||
+ opt_NoImplicitPrelude
+ = []
+
+ | otherwise = [ImportDecl pRELUDE_Name
+ ImportByUser
+ False {- Not qualified -}
+ Nothing {- No "as" -}
+ Nothing {- No import list -}
+ mod_loc]
+
+ explicit_prelude_import
+ = not (null [ () | (ImportDecl mod _ _ _ _ _) <- imports, mod == pRELUDE_Name ])
+\end{code}
+
+\begin{code}
+checkEarlyExit mod
+ = checkErrsRn `thenRn` \ no_errs_so_far ->
+ if not no_errs_so_far then
+ -- Found errors already, so exit now
+ returnRn True
+ else
+
+ traceRn (text "Considering whether compilation is required...") `thenRn_`
+ if not opt_SourceUnchanged then
+ -- Source code changed and no errors yet... carry on
+ traceRn (nest 4 (text "source file changed or recompilation check turned off")) `thenRn_`
+ returnRn False
+ else
+
+ -- Unchanged source, and no errors yet; see if usage info
+ -- up to date, and exit if so
+ checkUpToDate mod `thenRn` \ up_to_date ->
+ putDocRn (text "Compilation" <+>
+ text (if up_to_date then "IS NOT" else "IS") <+>
+ text "required") `thenRn_`
+ returnRn up_to_date
+\end{code}
+
+\begin{code}
+importsFromImportDecl :: (Name -> Bool) -- OK to omit qualifier
+ -> RdrNameImportDecl
+ -> RnMG (GlobalRdrEnv,
+ ExportAvails)
+
+importsFromImportDecl is_unqual (ImportDecl imp_mod_name from qual_only as_mod import_spec iloc)
+ = pushSrcLocRn iloc $
+ getInterfaceExports imp_mod_name from `thenRn` \ (imp_mod, avails) ->
+
+ if null avails then
+ -- If there's an error in getInterfaceExports, (e.g. interface
+ -- file not found) we get lots of spurious errors from 'filterImports'
+ returnRn (emptyRdrEnv, mkEmptyExportAvails imp_mod_name)
+ else
+
+ filterImports imp_mod_name import_spec avails `thenRn` \ (filtered_avails, hides, explicits) ->
+
+ -- We 'improve' the provenance by setting
+ -- (a) the import-reason field, so that the Name says how it came into scope
+ -- including whether it's explicitly imported
+ -- (b) the print-unqualified field
+ -- But don't fiddle with wired-in things or we get in a twist
+ let
+ improve_prov name = setNameProvenance name (NonLocalDef (UserImport imp_mod iloc (is_explicit name))
+ (is_unqual name))
+ is_explicit name = name `elemNameSet` explicits
+ in
+ qualifyImports imp_mod_name
+ (not qual_only) -- Maybe want unqualified names
+ as_mod hides
+ filtered_avails improve_prov `thenRn` \ (rdr_name_env, mod_avails) ->
+
+ returnRn (rdr_name_env, mod_avails)
+\end{code}
+
+
+\begin{code}
+importsFromLocalDecls mod_name rec_exp_fn decls
+ = mapRn (getLocalDeclBinders newLocalName) decls `thenRn` \ avails_s ->
+
+ let
+ avails = concat avails_s
+
+ all_names :: [Name] -- All the defns; no dups eliminated
+ all_names = [name | avail <- avails, name <- availNames avail]
+
+ dups :: [[Name]]
+ dups = filter non_singleton (equivClassesByUniq getUnique all_names)
+ where
+ non_singleton (x1:x2:xs) = True
+ non_singleton other = False
+ in
+ -- Check for duplicate definitions
+ mapRn_ (addErrRn . dupDeclErr) dups `thenRn_`
+
+ -- Record that locally-defined things are available
+ mapRn_ (recordSlurp Nothing) avails `thenRn_`
+
+ -- Build the environment
+ qualifyImports mod_name
+ True -- Want unqualified names
+ Nothing -- no 'as M'
+ [] -- Hide nothing
+ avails
+ (\n -> n)
+
+ where
+ newLocalName rdr_name loc = newLocalTopBinder mod (rdrNameOcc rdr_name)
+ rec_exp_fn loc
+ mod = mkThisModule mod_name
+
+getLocalDeclBinders :: (RdrName -> SrcLoc -> RnMG Name) -- New-name function
+ -> RdrNameHsDecl
+ -> RnMG Avails
+getLocalDeclBinders new_name (ValD binds)
+ = mapRn do_one (bagToList (collectTopBinders binds))
+ where
+ do_one (rdr_name, loc) = new_name rdr_name loc `thenRn` \ name ->
+ returnRn (Avail name)
+
+ -- foreign declarations
+getLocalDeclBinders new_name (ForD (ForeignDecl nm kind _ dyn _ loc))
+ | binds_haskell_name kind dyn
+ = new_name nm loc `thenRn` \ name ->
+ returnRn [Avail name]
+
+ | otherwise
+ = returnRn []
+
+getLocalDeclBinders new_name decl
+ = getDeclBinders new_name decl `thenRn` \ maybe_avail ->
+ case maybe_avail of
+ Nothing -> returnRn [] -- Instance decls and suchlike
+ Just avail -> getDeclSysBinders new_sys_name decl `thenRn_`
+ returnRn [avail]
+ where
+ -- The getDeclSysBinders is just to get the names of superclass selectors
+ -- etc, into the cache
+ new_sys_name rdr_name loc = newImplicitBinder (rdrNameOcc rdr_name) loc
+
+binds_haskell_name (FoImport _) _ = True
+binds_haskell_name FoLabel _ = True
+binds_haskell_name FoExport ext_nm = isDynamic ext_nm
+
+fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG FixityEnv
+fixitiesFromLocalDecls gbl_env decls
+ = foldlRn getFixities emptyNameEnv decls
+ where
+ getFixities :: FixityEnv -> RdrNameHsDecl -> RnMG FixityEnv
+ getFixities acc (FixD fix)
+ = fix_decl acc fix
+
+ getFixities acc (TyClD (ClassDecl _ _ _ sigs _ _ _ _ _ _))
+ = foldlRn fix_decl acc [sig | FixSig sig <- sigs]
+ -- Get fixities from class decl sigs too.
+ getFixities acc other_decl
+ = returnRn acc
+
+ fix_decl acc sig@(FixitySig rdr_name fixity loc)
+ = -- Check for fixity decl for something not declared
+ case lookupRdrEnv gbl_env rdr_name of {
+ Nothing | opt_WarnUnusedBinds
+ -> pushSrcLocRn loc (addWarnRn (unusedFixityDecl rdr_name fixity)) `thenRn_`
+ returnRn acc
+ | otherwise -> returnRn acc ;
+
+ Just (name:_) ->
+
+ -- Check for duplicate fixity decl
+ case lookupNameEnv acc name of {
+ Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc') `thenRn_`
+ returnRn acc ;
+
+ Nothing -> returnRn (addToNameEnv acc name (FixitySig name fixity loc))
+ }}
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Filtering imports}
+%* *
+%************************************************************************
+
+@filterImports@ takes the @ExportEnv@ telling what the imported module makes
+available, and filters it through the import spec (if any).
+
+\begin{code}
+filterImports :: ModuleName -- The module being imported
+ -> Maybe (Bool, [RdrNameIE]) -- Import spec; True => hiding
+ -> [AvailInfo] -- What's available
+ -> RnMG ([AvailInfo], -- What's actually imported
+ [AvailInfo], -- What's to be hidden (the unqualified version, that is)
+ NameSet) -- What was imported explicitly
+
+ -- Complains if import spec mentions things that the module doesn't export
+ -- Warns/informs if import spec contains duplicates.
+filterImports mod Nothing imports
+ = returnRn (imports, [], emptyNameSet)
+
+filterImports mod (Just (want_hiding, import_items)) avails
+ = mapMaybeRn check_item import_items `thenRn` \ avails_w_explicits ->
+ let
+ (item_avails, explicits_s) = unzip avails_w_explicits
+ explicits = foldl addListToNameSet emptyNameSet explicits_s
+ in
+ if want_hiding
+ then
+ -- All imported; item_avails to be hidden
+ returnRn (avails, item_avails, emptyNameSet)
+ else
+ -- Just item_avails imported; nothing to be hidden
+ returnRn (item_avails, [], explicits)
+ where
+ import_fm :: FiniteMap OccName AvailInfo
+ import_fm = listToFM [ (nameOccName name, avail)
+ | avail <- avails,
+ name <- availNames avail]
+ -- Even though availNames returns data constructors too,
+ -- they won't make any difference because naked entities like T
+ -- in an import list map to TcOccs, not VarOccs.
+
+ check_item item@(IEModuleContents _)
+ = addErrRn (badImportItemErr mod item) `thenRn_`
+ returnRn Nothing
+
+ check_item item
+ | not (maybeToBool maybe_in_import_avails) ||
+ not (maybeToBool maybe_filtered_avail)
+ = addErrRn (badImportItemErr mod item) `thenRn_`
+ returnRn Nothing
+
+ | dodgy_import = addWarnRn (dodgyImportWarn mod item) `thenRn_`
+ returnRn (Just (filtered_avail, explicits))
+
+ | otherwise = returnRn (Just (filtered_avail, explicits))
+
+ where
+ wanted_occ = rdrNameOcc (ieName item)
+ maybe_in_import_avails = lookupFM import_fm wanted_occ
+
+ Just avail = maybe_in_import_avails
+ maybe_filtered_avail = filterAvail item avail
+ Just filtered_avail = maybe_filtered_avail
+ explicits | dot_dot = [availName filtered_avail]
+ | otherwise = availNames filtered_avail
+
+ dot_dot = case item of
+ IEThingAll _ -> True
+ other -> False
+
+ dodgy_import = case (item, avail) of
+ (IEThingAll _, AvailTC _ [n]) -> True
+ -- This occurs when you import T(..), but
+ -- only export T abstractly. The single [n]
+ -- in the AvailTC is the type or class itself
+
+ other -> False
+\end{code}
+
+
+
+%************************************************************************
+%* *
+\subsection{Qualifiying imports}
+%* *
+%************************************************************************
+
+@qualifyImports@ takes the @ExportEnv@ after filtering through the import spec
+of an import decl, and deals with producing an @RnEnv@ with the
+right qualified names. It also turns the @Names@ in the @ExportEnv@ into
+fully fledged @Names@.
+
+\begin{code}
+qualifyImports :: ModuleName -- Imported module
+ -> Bool -- True <=> want unqualified import
+ -> Maybe ModuleName -- Optional "as M" part
+ -> [AvailInfo] -- What's to be hidden
+ -> Avails -- Whats imported and how
+ -> (Name -> Name) -- Improves the provenance on imported things
+ -> RnMG (GlobalRdrEnv, ExportAvails)
+ -- NB: the Names in ExportAvails don't have the improve-provenance
+ -- function applied to them
+ -- We could fix that, but I don't think it matters
+
+qualifyImports this_mod unqual_imp as_mod hides
+ avails improve_prov
+ =
+ -- Make the name environment. We're talking about a
+ -- single module here, so there must be no name clashes.
+ -- In practice there only ever will be if it's the module
+ -- being compiled.
+ let
+ -- Add the things that are available
+ name_env1 = foldl add_avail emptyRdrEnv avails
+
+ -- Delete things that are hidden
+ name_env2 = foldl del_avail name_env1 hides
+
+ -- Create the export-availability info
+ export_avails = mkExportAvails qual_mod unqual_imp name_env2 avails
+ in
+ returnRn (name_env2, export_avails)
+
+ where
+ qual_mod = case as_mod of
+ Nothing -> this_mod
+ Just another_name -> another_name
+
+ add_avail :: GlobalRdrEnv -> AvailInfo -> GlobalRdrEnv
+ add_avail env avail = foldl add_name env (availNames avail)
+
+ add_name env name
+ | unqual_imp = env2
+ | otherwise = env1
+ where
+ env1 = addOneToGlobalRdrEnv env (mkRdrQual qual_mod occ) better_name
+ env2 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ) better_name
+ occ = nameOccName name
+ better_name = improve_prov name
+
+ del_avail env avail = foldl delOneFromGlobalRdrEnv env rdr_names
+ where
+ rdr_names = map (mkRdrUnqual . nameOccName) (availNames avail)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Export list processing
+%* *
+%************************************************************************
+
+Processing the export list.
+
+You might think that we should record things that appear in the export list as
+``occurrences'' (using addOccurrenceName), but you'd be wrong. We do check (here)
+that they are in scope, but there is no need to slurp in their actual declaration
+(which is what addOccurrenceName forces). Indeed, doing so would big trouble when
+compiling PrelBase, because it re-exports GHC, which includes takeMVar#, whose type
+includes ConcBase.StateAndSynchVar#, and so on...
+
+\begin{code}
+type ExportAccum -- The type of the accumulating parameter of
+ -- the main worker function in exportsFromAvail
+ = ([ModuleName], -- 'module M's seen so far
+ ExportOccMap, -- Tracks exported occurrence names
+ NameEnv AvailInfo) -- The accumulated exported stuff, kept in an env
+ -- so we can common-up related AvailInfos
+
+type ExportOccMap = FiniteMap OccName (Name, RdrNameIE)
+ -- Tracks what a particular exported OccName
+ -- in an export list refers to, and which item
+ -- it came from. It's illegal to export two distinct things
+ -- that have the same occurrence name
+
+
+exportsFromAvail :: ModuleName
+ -> Maybe [RdrNameIE] -- Export spec
+ -> ExportAvails
+ -> GlobalRdrEnv
+ -> RnMG Avails
+ -- Complains if two distinct exports have same OccName
+ -- Warns about identical exports.
+ -- Complains about exports items not in scope
+exportsFromAvail this_mod Nothing export_avails global_name_env
+ = exportsFromAvail this_mod true_exports export_avails global_name_env
+ where
+ true_exports = Just $ if this_mod == mAIN_Name
+ then [IEVar main_RDR]
+ -- export Main.main *only* unless otherwise specified,
+ else [IEModuleContents this_mod]
+ -- but for all other modules export everything.
+
+exportsFromAvail this_mod (Just export_items)
+ (mod_avail_env, entity_avail_env)
+ global_name_env
+ = foldlRn exports_from_item
+ ([], emptyFM, emptyNameEnv) export_items `thenRn` \ (_, _, export_avail_map) ->
+ let
+ export_avails :: [AvailInfo]
+ export_avails = nameEnvElts export_avail_map
+ in
+ returnRn export_avails
+
+ where
+ exports_from_item :: ExportAccum -> RdrNameIE -> RnMG ExportAccum
+
+ exports_from_item acc@(mods, occs, avails) ie@(IEModuleContents mod)
+ | mod `elem` mods -- Duplicate export of M
+ = warnCheckRn opt_WarnDuplicateExports
+ (dupModuleExport mod) `thenRn_`
+ returnRn acc
+
+ | otherwise
+ = case lookupFM mod_avail_env mod of
+ Nothing -> failWithRn acc (modExportErr mod)
+ Just mod_avails -> foldlRn (check_occs ie) occs mod_avails `thenRn` \ occs' ->
+ let
+ avails' = foldl add_avail avails mod_avails
+ in
+ returnRn (mod:mods, occs', avails')
+
+ exports_from_item acc@(mods, occs, avails) ie
+ | not (maybeToBool maybe_in_scope)
+ = failWithRn acc (unknownNameErr (ieName ie))
+
+ | not (null dup_names)
+ = addNameClashErrRn rdr_name (name:dup_names) `thenRn_`
+ returnRn acc
+
+#ifdef DEBUG
+ -- I can't see why this should ever happen; if the thing is in scope
+ -- at all it ought to have some availability
+ | not (maybeToBool maybe_avail)
+ = pprTrace "exportsFromAvail: curious Nothing:" (ppr name)
+ returnRn acc
+#endif
+
+ | not enough_avail
+ = failWithRn acc (exportItemErr ie)
+
+ | otherwise -- Phew! It's OK! Now to check the occurrence stuff!
+ = check_occs ie occs export_avail `thenRn` \ occs' ->
+ returnRn (mods, occs', add_avail avails export_avail)
+
+ where
+ rdr_name = ieName ie
+ maybe_in_scope = lookupFM global_name_env rdr_name
+ Just (name:dup_names) = maybe_in_scope
+ maybe_avail = lookupUFM entity_avail_env name
+ Just avail = maybe_avail
+ maybe_export_avail = filterAvail ie avail
+ enough_avail = maybeToBool maybe_export_avail
+ Just export_avail = maybe_export_avail
+
+add_avail avails avail = addToNameEnv_C plusAvail avails (availName avail) avail
+
+check_occs :: RdrNameIE -> ExportOccMap -> AvailInfo -> RnMG ExportOccMap
+check_occs ie occs avail
+ = foldlRn check occs (availNames avail)
+ where
+ check occs name
+ = case lookupFM occs name_occ of
+ Nothing -> returnRn (addToFM occs name_occ (name, ie))
+ Just (name', ie')
+ | name == name' -> -- Duplicate export
+ warnCheckRn opt_WarnDuplicateExports
+ (dupExportWarn name_occ ie ie') `thenRn_`
+ returnRn occs
+
+ | otherwise -> -- Same occ name but different names: an error
+ failWithRn occs (exportClashErr name_occ ie ie')
+ where
+ name_occ = nameOccName name
+
+mk_export_fn :: NameSet -> (Name -> ExportFlag)
+mk_export_fn exported_names
+ = \name -> if name `elemNameSet` exported_names
+ then Exported
+ else NotExported
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Errors}
+%* *
+%************************************************************************
+
+\begin{code}
+badImportItemErr mod ie
+ = sep [ptext SLIT("Module"), quotes (pprModuleName mod),
+ ptext SLIT("does not export"), quotes (ppr ie)]
+
+dodgyImportWarn mod (IEThingAll tc)
+ = sep [ptext SLIT("Module") <+> quotes (pprModuleName mod) <+> ptext SLIT("exports") <+> quotes (ppr tc),
+ ptext SLIT("with no constructors/class operations;"),
+ ptext SLIT("yet it is imported with a (..)")]
+
+modExportErr mod
+ = hsep [ ptext SLIT("Unknown module in export list: module"), quotes (pprModuleName mod)]
+
+exportItemErr export_item
+ = sep [ ptext SLIT("Bad export item"), quotes (ppr export_item)]
+
+exportClashErr occ_name ie1 ie2
+ = hsep [ptext SLIT("The export items"), quotes (ppr ie1), ptext SLIT("and"), quotes (ppr ie2),
+ ptext SLIT("create conflicting exports for"), quotes (ppr occ_name)]
+
+dupDeclErr (n:ns)
+ = vcat [ptext SLIT("Multiple declarations of") <+> quotes (ppr n),
+ nest 4 (vcat (map pp sorted_ns))]
+ where
+ sorted_ns = sortLt occ'ed_before (n:ns)
+
+ occ'ed_before a b = LT == compare (getSrcLoc a) (getSrcLoc b)
+
+ pp n = pprProvenance (getNameProvenance n)
+
+dupExportWarn occ_name ie1 ie2
+ = hsep [quotes (ppr occ_name),
+ ptext SLIT("is exported by"), quotes (ppr ie1),
+ ptext SLIT("and"), quotes (ppr ie2)]
+
+dupModuleExport mod
+ = hsep [ptext SLIT("Duplicate"),
+ quotes (ptext SLIT("Module") <+> pprModuleName mod),
+ ptext SLIT("in export list")]
+
+unusedFixityDecl rdr_name fixity
+ = hsep [ptext SLIT("Unused fixity declaration for"), quotes (ppr rdr_name)]
+
+dupFixityDecl rdr_name loc1 loc2
+ = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
+ ptext SLIT("at ") <+> ppr loc1,
+ ptext SLIT("and") <+> ppr loc2]
+
+\end{code}
diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs
index 53188bac73..6fc36c8de2 100644
--- a/ghc/compiler/simplCore/FloatIn.lhs
+++ b/ghc/compiler/simplCore/FloatIn.lhs
@@ -142,6 +142,11 @@ fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop )
Type ty
fiExpr to_drop (_, AnnCon c args)
+ | isDataCon c -- Don't float into the args of a data construtor;
+ -- the simplifier will float straight back out
+ = mkCoLets' to_drop (Con c (map (fiExpr []) args))
+
+ | otherwise
= mkCoLets' drop_here (Con c args')
where
(drop_here : arg_drops) = sepBindsByDropPoint (map freeVarsOf args) to_drop
diff --git a/ghc/compiler/simplCore/FoldrBuildWW.lhs b/ghc/compiler/simplCore/FoldrBuildWW.lhs
deleted file mode 100644
index c0ffc3c7be..0000000000
--- a/ghc/compiler/simplCore/FoldrBuildWW.lhs
+++ /dev/null
@@ -1,182 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section[FoldrBuildWW]{Spliting suitable functions into Workers and Wrappers}
-
-\begin{code}
-module FoldrBuildWW ( mkFoldrBuildWW ) where
-
-#include "HsVersions.h"
-
--- Just a stub for now
-import CoreSyn ( CoreBind )
-import UniqSupply ( UniqSupply )
-import Panic ( panic )
-
---import Type ( cloneTyVarFromTemplate, mkTyVarTy,
--- splitFunTyExpandingDicts, eqTyCon, mkForallTy )
---import TysPrim ( alphaTy )
---import TyVar ( alphaTyVar )
---
---import Type ( Type ) -- **** CAN SEE THE CONSTRUCTORS ****
---import UniqSupply ( runBuiltinUs )
---import WwLib -- share the same monad (is this eticit ?)
---import PrelInfo ( listTyCon, mkListTy, nilDataCon, consDataCon,
--- foldrId, buildId
--- )
---import Id ( getIdFBTypeInfo, mkWorkerId, getIdInfo,
--- mkSysLocal, idType
--- )
---import IdInfo
---import Maybes
---import SrcLoc ( noSrcLoc, SrcLoc )
---import Util
-\end{code}
-
-\begin{code}
-mkFoldrBuildWW
- :: UniqSupply
- -> [CoreBind]
- -> [CoreBind]
-
-mkFoldrBuildWW = panic "mkFoldrBuildWW (ToDo)"
-
-{- LATER:
-mkFoldrBuildWW us top_binds =
- (mapWw wwBind top_binds `thenWw` \ top_binds2 ->
- returnWw (concat top_binds2)) us
-\end{code}
-
-\begin{code}
-wwBind :: CoreBinding -> WwM [CoreBinding]
-wwBind (NonRec bndr expr)
- = try_split_bind bndr expr `thenWw` \ re ->
- returnWw [NonRec bnds expr | (bnds,expr) <- re]
-wwBind (Rec binds)
- = mapWw (\ (bndr,expr) -> try_split_bind bndr expr) binds `thenWw` \ res ->
- returnWw [Rec (concat res)]
-
-wwExpr :: CoreExpr -> WwM CoreExpr
-wwExpr e@(Var _) = returnWw e
-wwExpr e@(Lit _) = returnWw e
-wwExpr e@(Con _ _ _) = returnWw e
-wwExpr e@(Prim _ _ _) = returnWw e
-wwExpr (Lam ids e) =
- wwExpr e `thenWw` \ e' ->
- returnWw (Lam ids e')
-wwExpr (CoTyLam tyvar e) =
- wwExpr e `thenWw` \ e' ->
- returnWw (CoTyLam tyvar e')
-wwExpr (App f atom) =
- wwExpr f `thenWw` \ f' ->
- returnWw (App f atom)
-wwExpr (CoTyApp f ty) =
- wwExpr f `thenWw` \ f' ->
- returnWw (CoTyApp f' ty)
-wwExpr (Note note e) =
- wwExpr e `thenWw` \ e' ->
- returnWw (Note note e')
-wwExpr (Let bnds e) =
- wwExpr e `thenWw` \ e' ->
- wwBind bnds `thenWw` \ bnds' ->
- returnWw (foldr Let e' bnds')
-wwExpr (Case e alts) =
- wwExpr e `thenWw` \ e' ->
- wwAlts alts `thenWw` \ alts' ->
- returnWw (Case e' alts')
-
-wwAlts (AlgAlts alts deflt) =
- mapWw (\(con,binders,e) ->
- wwExpr e `thenWw` \ e' ->
- returnWw (con,binders,e')) alts `thenWw` \ alts' ->
- wwDef deflt `thenWw` \ deflt' ->
- returnWw (AlgAlts alts' deflt)
-wwAlts (PrimAlts alts deflt) =
- mapWw (\(lit,e) ->
- wwExpr e `thenWw` \ e' ->
- returnWw (lit,e')) alts `thenWw` \ alts' ->
- wwDef deflt `thenWw` \ deflt' ->
- returnWw (PrimAlts alts' deflt)
-
-wwDef e@NoDefault = returnWw e
-wwDef (BindDefault v e) =
- wwExpr e `thenWw` \ e' ->
- returnWw (BindDefault v e')
-\end{code}
-
-\begin{code}
-try_split_bind :: Id -> CoreExpr -> WwM [(Id,CoreExpr)]
-try_split_bind id expr =
- wwExpr expr `thenWw` \ expr' ->
- case getFBType (getIdFBTypeInfo id) of
- Just (FBType consum prod)
- | FBGoodProd == prod ->
-{- || any (== FBGoodConsum) consum -}
- let
- (big_args,args,body) = collectBinders expr'
- in
- if length args /= length consum -- funny number of arguments
- then returnWw [(id,expr')]
- else
- -- f /\ t1 .. tn \ v1 .. vn -> e
- -- ===>
- -- f_wrk /\ t1 .. tn t_new \ v1 .. vn c n -> foldr <exprTy> <nTy> c n e
- -- f /\ t1 .. tn \ v1 .. vn
- -- -> build exprTy (\ c n -> f_wrk t1 .. tn t_new v1 .. vn c n)
- pprTrace "WW:" (ppr id) (returnWw ())
- `thenWw` \ () ->
- getUniqueWw `thenWw` \ ty_new_uq ->
- getUniqueWw `thenWw` \ worker_new_uq ->
- getUniqueWw `thenWw` \ c_new_uq ->
- getUniqueWw `thenWw` \ n_new_uq ->
- let
- -- The *new* type
- n_ty = alphaTy
- n_ty_templ = alphaTy
-
- (templ,arg_tys,res) = splitFunTyExpandingDicts (idType id)
- expr_ty = getListTy res
- getListTy res = panic "FoldrBuildWW:getListTy:ToDo" {-LATER:case res of
- UniData lty [ty] | lty `eqTyCon` listTyCon -> ty
- _ -> panic "Trying to split a non List datatype into Worker/Wrapper"-}
-
- c_ty = expr_ty `mkFunTy` (n_ty `mkFunTy` n_ty)
- c_ty_templ = expr_ty `mkFunTy` (n_ty_templ `mkFunTy` n_ty_templ)
-
- worker_ty = mkForallTy (templ ++ [alphaTyVar])
- (foldr mkFunTy n_ty_templ (arg_tys++[c_ty_templ,n_ty_templ]))
- wrapper_id = setInlinePragma id IWantToBeINLINEd
- worker_id = mkWorkerId worker_new_uq id worker_ty
- -- TODO : CHECK if mkWorkerId is thr
- -- right function to use ..
- -- Now the bodies
-
- c_id = mkSysLocal SLIT("fbww") c_new_uq c_ty
- n_id = mkSysLocal SLIT("fbww") n_new_uq n_ty
- worker_rhs
- = mkTyLam [] (big_args ++ [alphaTyVar]) (args++[c_id,n_id]) worker_body
-
- worker_body = runBuiltinUs (
- mkCoApps
- (Var foldrId `CoTyApp` expr_ty `CoTyApp` n_ty `App`
- VarArg c_id `App` VarArg n_id)
- [body])
- wrapper_rhs = mkLam big_args args wrapper_body
-
- wrapper_body = runBuiltinUs (
- mkCoApps (CoTyApp (Var buildId) expr_ty)
- [mkLam [alphaTyVar] [c_id,n_id]
- (foldl App
- (mkCoTyApps (Var worker_id)
- [mkTyVarTy t | t <- big_args ++ [alphaTyVar]])
- (map VarArg (args++[c_id,n_id])))])
-
- in
- if length args /= length arg_tys ||
- length big_args /= length templ
- then panic "LEN PROBLEM"
- else
- returnWw [(worker_id,worker_rhs),(wrapper_id,wrapper_rhs)]
- _ -> returnWw [(id,expr')]
--}
-\end{code}
diff --git a/ghc/compiler/simplCore/MagicUFs.hi-boot b/ghc/compiler/simplCore/MagicUFs.hi-boot
deleted file mode 100644
index 06d854db14..0000000000
--- a/ghc/compiler/simplCore/MagicUFs.hi-boot
+++ /dev/null
@@ -1,6 +0,0 @@
-_interface_ MagicUFs 1
-_exports_
-MagicUFs MagicUnfoldingFun mkMagicUnfoldingFun;
-_declarations_
-1 data MagicUnfoldingFun;
-1 mkMagicUnfoldingFun _:_ Unique.Unique -> MagicUnfoldingFun ;;
diff --git a/ghc/compiler/simplCore/MagicUFs.hi-boot-5 b/ghc/compiler/simplCore/MagicUFs.hi-boot-5
deleted file mode 100644
index b8d66d6d12..0000000000
--- a/ghc/compiler/simplCore/MagicUFs.hi-boot-5
+++ /dev/null
@@ -1,4 +0,0 @@
-__interface MagicUFs 1 0 where
-__export MagicUFs MagicUnfoldingFun mkMagicUnfoldingFun;
-1 data MagicUnfoldingFun;
-1 mkMagicUnfoldingFun :: Unique.Unique -> MagicUnfoldingFun ;
diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs
index 60f846d24d..87927ece48 100644
--- a/ghc/compiler/simplCore/OccurAnal.lhs
+++ b/ghc/compiler/simplCore/OccurAnal.lhs
@@ -285,12 +285,12 @@ occAnalBind env (Rec pairs) body_usage
pp_item (_, bndr, _) = ppr bndr
binders = map fst pairs
- new_env = env `addNewCands` binders
+ rhs_env = env `addNewCands` binders
analysed_pairs :: [Details1]
analysed_pairs = [ (bndr, rhs_usage, rhs')
| (bndr, rhs) <- pairs,
- let (rhs_usage, rhs') = occAnalRhs new_env bndr rhs
+ let (rhs_usage, rhs') = occAnalRhs rhs_env bndr rhs
]
sccs :: [SCC (Node Details1)]
@@ -497,7 +497,7 @@ occAnalRhs :: OccEnv
occAnalRhs env id rhs
= (final_usage, rhs')
where
- (rhs_usage, rhs') = occAnal env rhs
+ (rhs_usage, rhs') = occAnal (zapCtxt env) rhs
-- [March 98] A new wrinkle is that if the binder has specialisations inside
-- it then we count the specialised Ids as "extra rhs's". That way
@@ -639,7 +639,7 @@ occAnal env expr@(Lam _ _)
occAnal env (Case scrut bndr alts)
= case mapAndUnzip (occAnalAlt alt_env) alts of { (alts_usage_s, alts') ->
- case occAnal env scrut of { (scrut_usage, scrut') ->
+ case occAnal (zapCtxt env) scrut of { (scrut_usage, scrut') ->
let
alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
(alts_usage1, tagged_bndr) = tagBinder alts_usage bndr
@@ -657,8 +657,10 @@ occAnal env (Let bind body)
new_env = env `addNewCands` (bindersOf bind)
occAnalArgs env args
- = case mapAndUnzip (occAnal env) args of { (arg_uds_s, args') ->
+ = case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') ->
(foldr combineUsageDetails emptyDetails arg_uds_s, args')}
+ where
+ arg_env = zapCtxt env
\end{code}
Applications are dealt with specially because we want
@@ -685,8 +687,8 @@ occAnalApp env (Var fun, args)
| otherwise = occAnalArgs env args
occAnalApp env (fun, args)
- = case occAnal env fun of { (fun_uds, fun') ->
- case occAnalArgs env args of { (args_uds, args') ->
+ = case occAnal (zapCtxt env) fun of { (fun_uds, fun') ->
+ case occAnalArgs env args of { (args_uds, args') ->
let
final_uds = fun_uds `combineUsageDetails` args_uds
in
@@ -768,6 +770,9 @@ getCtxt env@(OccEnv ifun cands []) n = (False, env)
getCtxt (OccEnv ifun cands ctxt) n = (and (take n ctxt), OccEnv ifun cands (drop n ctxt))
-- Only return True if *all* the lambdas are linear
+zapCtxt env@(OccEnv ifun cands []) = env
+zapCtxt (OccEnv ifun cands _ ) = OccEnv ifun cands []
+
type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage
combineUsageDetails, combineAltsUsageDetails
diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index db0534e7dd..189f0f6cfc 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -688,7 +688,7 @@ simplVar var cont
#ifdef DEBUG
if isLocallyDefined var && not (idMustBeINLINEd var)
-- The idMustBeINLINEd test accouunts for the fact
- -- that class method selectors don't have top level
+ -- that class dictionary constructors don't have top level
-- bindings and hence aren't in scope.
then
-- Not in scope
diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs
index 7c2bf863c1..c0e05c5085 100644
--- a/ghc/compiler/specialise/Rules.lhs
+++ b/ghc/compiler/specialise/Rules.lhs
@@ -21,7 +21,7 @@ import CoreUnfold ( Unfolding(..) )
import CoreUtils ( whnfOrBottom, eqExpr )
import PprCore ( pprCoreRule )
import Subst ( Subst, InScopeSet, substBndr, lookupSubst, extendSubst,
- mkSubst, substEnv, setSubstEnv,
+ mkSubst, substEnv, setSubstEnv, emptySubst, isInScope,
unBindSubst, bindSubstList, unBindSubstList,
)
import Id ( Id, getIdUnfolding,
@@ -122,10 +122,30 @@ matchRule :: InScopeSet -> CoreRule -> [CoreExpr] -> Maybe (FAST_STRING, CoreExp
-- of the output.
--
-- ASSUMPTION (A):
--- No variable free in the template is bound in the target
+-- A1. No top-level variable is bound in the target
+-- A2. No template variable is bound in the target
+-- A3. No lambda bound template variable is free in any subexpression of the target
+--
+-- To see why A1 is necessary, consider matching
+-- \x->f against \f->f
+-- When we meet the lambdas we substitute [f/x] in the template (a no-op),
+-- and then erroneously succeed in matching f against f.
+--
+-- To see why A2 is needed consider matching
+-- forall a. \b->b against \a->3
+-- When we meet the lambdas we substitute [a/b] in the template, and then
+-- erroneously succeed in matching what looks like the template variable 'a' against 3.
+--
+-- A3 is needed to validate the rule that says
+-- (\x->E) matches F
+-- if
+-- (\x->E) matches (\x->F x)
+
matchRule in_scope (Rule rn tpl_vars tpl_args rhs) args
- = go tpl_args args (mkSubst in_scope emptySubstEnv)
+ = go tpl_args args emptySubst
+ -- We used to use the in_scope set, but I don't think that's necessary
+ -- After all, the result is going to be simplified again with that in_scope set
where
tpl_var_set = mkVarSet tpl_vars
@@ -188,11 +208,10 @@ type Matcher result = IdOrTyVarSet -- Template variables
-> Subst -> Maybe result -- Substitution so far -> result
-- The *SubstEnv* in these Substs apply to the TEMPLATE only
--- The *InScopeSet* in these Substs gives a superset of the free vars
--- in the term being matched. This set can get augmented, for example
--- when matching against a lambda:
--- (\x.M) ~ N iff M ~ N x
--- but we must clone x if it's already free in N
+-- The *InScopeSet* in these Substs gives variables bound so far in the
+-- target term. So when matching forall a. (\x. a x) against (\y. y y)
+-- while processing the body of the lambdas, the in-scope set will be {y}.
+-- That lets us do the occurs-check when matching 'a' against 'y'
match :: CoreExpr -- Template
-> CoreExpr -- Target
@@ -202,8 +221,13 @@ match_fail = Nothing
match (Var v1) e2 tpl_vars kont subst
= case lookupSubst subst v1 of
- Nothing | v1 `elemVarSet` tpl_vars -> kont (extendSubst subst v1 (DoneEx e2))
- -- v1 is a template variables
+ Nothing | v1 `elemVarSet` tpl_vars -- v1 is a template variable
+ -> if (any (`isInScope` subst) (varSetElems (exprFreeVars e2))) then
+ match_fail -- Occurs check failure
+ -- e.g. match forall a. (\x-> a x) against (\y. y y)
+ else
+ kont (extendSubst subst v1 (DoneEx e2))
+
| eqExpr (Var v1) e2 -> kont subst
-- v1 is not a template variable, so it must be a global constant
@@ -222,23 +246,18 @@ match (App f1 a1) (App f2 a2) tpl_vars kont subst
match (Lam x1 e1) (Lam x2 e2) tpl_vars kont subst
= bind [x1] [x2] (match e1 e2) tpl_vars kont subst
-{- THESE EQUATIONS ARE BOGUS. SLPJ 19 May 99
-- This rule does eta expansion
-- (\x.M) ~ N iff M ~ N x
--- We must clone the binder in case it's already in scope in N
+-- See assumption A3
match (Lam x1 e1) e2 tpl_vars kont subst
- = match e1 (App e2 (mkVarArg x1')) tpl_vars kont' subst'
- where
- (subst', x1') = substBndr subst x1
- kont' subst = kont (unBindSubst subst x1 x1')
+ = bind [x1] [x1] (match e1 (App e2 (mkVarArg x1))) tpl_vars kont subst
-- Eta expansion the other way
-- M ~ (\y.N) iff \y.M y ~ \y.N
-- iff M y ~ N
-- Remembering that by (A), y can't be free in M, we get this
match e1 (Lam x2 e2) tpl_vars kont subst
- = match (App e1 (mkVarArg x2)) e2 tpl_vars kont subst
--}
+ = bind [x2] [x2] (match (App e1 (mkVarArg x2)) e2) tpl_vars kont subst
match (Case e1 x1 alts1) (Case e2 x2 alts2) tpl_vars kont subst
= match e1 e2 tpl_vars case_kont subst
diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs
index 94c4b0f397..37e9248d87 100644
--- a/ghc/compiler/stranal/SaAbsInt.lhs
+++ b/ghc/compiler/stranal/SaAbsInt.lhs
@@ -632,9 +632,7 @@ findStrictness tys str_val abs_val
where
tys_w_index = tys `zip` [(1::Int) ..]
- find_str (ty,n) = -- let res =
- -- in pprTrace "findStr" (ppr ty <+> int n <+> ppr res) res
- findRecDemand str_fn abs_fn ty
+ find_str (ty,n) = 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 bc2174e3ee..f3a2ad0eb7 100644
--- a/ghc/compiler/stranal/StrictAnal.lhs
+++ b/ghc/compiler/stranal/StrictAnal.lhs
@@ -328,8 +328,7 @@ 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) -> -- pprTrace "addStr" (ppr binder $$ ppr strictness) $
- binder `setIdStrictness`
+ (binders, rhs) -> binder `setIdStrictness`
mkStrictnessInfo strictness
where
tys = [idType id | id <- binders, isId id]
diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index 721ea2a28d..3049bbe579 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -24,7 +24,7 @@ import RnHsSyn ( RenamedTyClDecl, RenamedClassPragmas,
)
import TcHsSyn ( TcMonoBinds )
-import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, newDicts, newMethod )
+import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs, newDicts, newMethod )
import TcEnv ( TcId, ValueEnv, TcTyThing(..), tcAddImportedIdInfo,
tcLookupClass, tcLookupTy, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars,
tcExtendLocalValEnv
@@ -44,9 +44,7 @@ import Class ( mkClass, classBigSig, Class )
import CmdLineOpts ( opt_GlasgowExts, opt_WarnMissingMethods )
import MkId ( mkDictSelId, mkDataConId, mkDefaultMethodId )
import DataCon ( mkDataCon, notMarkedStrict )
-import Id ( Id,
- getIdUnfolding, idType, idName
- )
+import Id ( Id, setInlinePragma, getIdUnfolding, idType, idName )
import CoreUnfold ( getUnfoldingTemplate )
import IdInfo
import Name ( Name, nameOccName, isLocallyDefined, NamedThing(..) )
@@ -180,7 +178,11 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs
[{-No existential tyvars-}] [{-Or context-}]
dict_component_tys
tycon dict_con_id
+
+ -- In general, constructors don't have to be inlined, but this one
+ -- does, because we don't make a top level binding for it.
dict_con_id = mkDataConId dict_con
+ `setInlinePragma` IMustBeINLINEd
argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcClassDecl1: argvrcs:" $
ppr tycon_name)
@@ -378,23 +380,11 @@ we get the default methods:
defm.Foo.op1 :: forall a. Foo a => a -> Bool
defm.Foo.op1 = /\a -> \dfoo -> \x -> True
-====================== OLD ==================
-\begin{verbatim}
-defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b
-defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z ->
- if (op1 a dfoo x) && (< b dord y z) then y else z
-\end{verbatim}
-Notice that, like all ids, the foralls of defm.Foo.op2 are at the top.
-====================== END OF OLD ===================
-
-NEW:
-\begin{verbatim}
defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
if (op1 a dfoo x) && (< b dord y z) then y else z
\end{verbatim}
-
When we come across an instance decl, we may need to use the default
methods:
\begin{verbatim}
@@ -436,55 +426,15 @@ tcDefaultMethodBinds
-> TcM s (LIE, TcMonoBinds)
tcDefaultMethodBinds clas default_binds
- = -- Construct suitable signatures
- tcInstTyVars tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, _) ->
-
- -- Check that the default bindings come from this class
+ = -- Check that the default bindings come from this class
checkFromThisClass clas op_sel_ids default_binds `thenNF_Tc_`
- -- Typecheck the default bindings
- let
- theta = [(clas,inst_tys)]
- tc_dm sel_id_w_dm@(_, Just dm_id)
- = tcMethodBind clas origin clas_tyvars inst_tys theta
- default_binds [{-no prags-}] False
- sel_id_w_dm `thenTc` \ (bind, insts, (_, local_dm_id)) ->
- returnTc (bind, insts, (clas_tyvars, dm_id, local_dm_id))
- in
- tcExtendTyVarEnvForMeths tyvars clas_tyvars (
- mapAndUnzip3Tc tc_dm sel_ids_w_dms
- ) `thenTc` \ (defm_binds, insts_needed, abs_bind_stuff) ->
-
-
- -- Check the context
- newDicts origin theta `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
- let
- avail_insts = this_dict
- in
- tcAddErrCtxt (defltMethCtxt clas) $
-
- -- tcMethodBind has checked that the class_tyvars havn't
- -- been unified with each other or another type, but we must
- -- still zonk them before passing them to tcSimplifyAndCheck
- mapNF_Tc zonkTcTyVarBndr clas_tyvars `thenNF_Tc` \ clas_tyvars' ->
-
- tcSimplifyAndCheck
- (ptext SLIT("class") <+> ppr clas)
- (mkVarSet clas_tyvars')
- avail_insts
- (unionManyBags insts_needed) `thenTc` \ (const_lie, dict_binds) ->
-
- let
- full_binds = AbsBinds
- clas_tyvars'
- [this_dict_id]
- abs_bind_stuff
- emptyNameSet -- No inlines (yet)
- (dict_binds `andMonoBinds` andMonoBindList defm_binds)
- in
- returnTc (const_lie, full_binds)
+ -- Do each default method separately
+ mapAndUnzipTc tc_dm sel_ids_w_dms `thenTc` \ (defm_binds, const_lies) ->
+ returnTc (plusLIEs const_lies, andMonoBindList defm_binds)
where
+
(tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
sel_ids_w_dms = [pair | pair@(_, Just _) <- op_sel_ids `zip` defm_ids]
@@ -492,6 +442,54 @@ tcDefaultMethodBinds clas default_binds
-- user default declaration
origin = ClassDeclOrigin
+
+ -- We make a separate binding for each default method.
+ -- At one time I used a single AbsBinds for all of them, thus
+ -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
+ -- But that desugars into
+ -- ds = \d -> (..., ..., ...)
+ -- dm1 = \d -> case ds d of (a,b,c) -> a
+ -- And since ds is big, it doesn't get inlined, so we don't get good
+ -- default methods. Better to make separate AbsBinds for each
+
+ tc_dm sel_id_w_dm@(_, Just dm_id)
+ = tcInstTyVars tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, _) ->
+ let
+ theta = [(clas,inst_tys)]
+ in
+ newDicts origin theta `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
+ let
+ avail_insts = this_dict
+ in
+ tcExtendTyVarEnvForMeths tyvars clas_tyvars (
+ tcMethodBind clas origin clas_tyvars inst_tys theta
+ default_binds [{-no prags-}] False
+ sel_id_w_dm
+ ) `thenTc` \ (defm_bind, insts_needed, (_, local_dm_id)) ->
+
+ tcAddErrCtxt (defltMethCtxt clas) $
+
+ -- tcMethodBind has checked that the class_tyvars havn't
+ -- been unified with each other or another type, but we must
+ -- still zonk them before passing them to tcSimplifyAndCheck
+ mapNF_Tc zonkTcTyVarBndr clas_tyvars `thenNF_Tc` \ clas_tyvars' ->
+
+ -- Check the context
+ tcSimplifyAndCheck
+ (ptext SLIT("class") <+> ppr clas)
+ (mkVarSet clas_tyvars')
+ avail_insts
+ insts_needed `thenTc` \ (const_lie, dict_binds) ->
+
+ let
+ full_bind = AbsBinds
+ clas_tyvars'
+ [this_dict_id]
+ [(clas_tyvars', dm_id, local_dm_id)]
+ emptyNameSet -- No inlines (yet)
+ (dict_binds `andMonoBinds` defm_bind)
+ in
+ returnTc (full_bind, const_lie)
\end{code}
\begin{code}
diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index 282b30ecdb..45984b74aa 100644
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -303,18 +303,7 @@ 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
- = (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)
+ = checkTc (all (== field_ty) other_tys)
(fieldTypeMisMatch field_name) `thenTc_`
returnTc selector_id
where
View Lorry Controller Status