From cfcebde74cf826af12143a92bcffa8c995eee135 Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 8 Jun 1999 16:47:07 +0000 Subject: [PATCH] [project @ 1999-06-08 16:46:44 by simonpj] Small fixes, including a significant full-laziness bug in OccurAnal --- ghc/compiler/NOTES | 144 +- ghc/compiler/coreSyn/CoreUnfold.lhs | 1309 ++++---- ghc/compiler/coreSyn/CoreUtils.lhs | 11 +- ghc/compiler/hsSyn/HsBinds.lhs | 2 +- ghc/compiler/prelude/PrimOp.lhs | 4766 +++++++++++++++-------------- ghc/compiler/rename/RnIfaces.lhs | 2 +- ghc/compiler/rename/RnNames.lhs | 1393 ++++----- ghc/compiler/simplCore/FloatIn.lhs | 5 + ghc/compiler/simplCore/FoldrBuildWW.lhs | 182 -- ghc/compiler/simplCore/MagicUFs.hi-boot | 6 - ghc/compiler/simplCore/MagicUFs.hi-boot-5 | 4 - ghc/compiler/simplCore/OccurAnal.lhs | 19 +- ghc/compiler/simplCore/Simplify.lhs | 2 +- ghc/compiler/specialise/Rules.lhs | 55 +- ghc/compiler/stranal/SaAbsInt.lhs | 4 +- ghc/compiler/stranal/StrictAnal.lhs | 3 +- ghc/compiler/typecheck/TcClassDcl.lhs | 120 +- ghc/compiler/typecheck/TcTyDecls.lhs | 13 +- 18 files changed, 3880 insertions(+), 4160 deletions(-) delete mode 100644 ghc/compiler/simplCore/FoldrBuildWW.lhs delete mode 100644 ghc/compiler/simplCore/MagicUFs.hi-boot delete mode 100644 ghc/compiler/simplCore/MagicUFs.hi-boot-5 diff --git a/ghc/compiler/NOTES b/ghc/compiler/NOTES index 72b3be0..d0332b1 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 a42e659..39740c7 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 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 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 4e3b22e..49bbf15 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 8a559f3..375fe31 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 24bead2..41793af 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 deff6b7..ff32230 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 633735b..4df3ffb 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 53188ba..6fc36c8 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 c0ffc3c..0000000 --- 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 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 06d854d..0000000 --- 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 b8d66d6..0000000 --- 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 60f846d..87927ec 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 db0534e..189f0f6 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 7c2bf86..c0e05c5 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 94c4b0f..37e9248 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 bc2174e..f3a2ad0 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 721ea2a..3049bbe 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 282b30e..45984b7 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 -- 1.7.10.4