Commit 97ce7b59 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Merge remote branch 'origin/master' into ghc-generics

parents 5188e4e5 80f5e700
......@@ -64,6 +64,8 @@ import Pair
import FastTypes
import FastString
import Outputable
import ForeignCall
import Data.Maybe
\end{code}
......@@ -273,6 +275,9 @@ Notice that 'x' counts 0, while (f x) counts 2. That's deliberate: there's
a function call to account for. Notice also that constructor applications
are very cheap, because exposing them to a caller is so valuable.
[25/5/11] All sizes are now multiplied by 10, except for primops.
This makes primops look cheap, and seems to be almost unversally
beneficial. Done partly as a result of #4978.
Note [Do not inline top-level bottoming functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -330,7 +335,7 @@ uncondInline :: Arity -> Int -> Bool
-- See Note [INLINE for small functions]
uncondInline arity size
| arity == 0 = size == 0
| otherwise = size <= arity + 1
| otherwise = size <= 10 * (arity + 1)
\end{code}
......@@ -359,19 +364,19 @@ sizeExpr bOMB_OUT_SIZE top_args expr
size_up (App fun arg) = size_up arg `addSizeNSD`
size_up_app fun [arg]
size_up (Lam b e) | isId b = lamScrutDiscount (size_up e `addSizeN` 1)
size_up (Lam b e) | isId b = lamScrutDiscount (size_up e `addSizeN` 10)
| otherwise = size_up e
size_up (Let (NonRec binder rhs) body)
= size_up rhs `addSizeNSD`
size_up body `addSizeN`
(if isUnLiftedType (idType binder) then 0 else 1)
(if isUnLiftedType (idType binder) then 0 else 10)
-- For the allocation
-- If the binder has an unlifted type there is no allocation
size_up (Let (Rec pairs) body)
= foldr (addSizeNSD . size_up . snd)
(size_up body `addSizeN` length pairs) -- (length pairs) for the allocation
(size_up body `addSizeN` (10 * length pairs)) -- (length pairs) for the allocation
pairs
size_up (Case (Var v) _ _ alts)
......@@ -388,7 +393,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr
-- the case when we are scrutinising an argument variable
alts_size (SizeIs tot tot_disc tot_scrut) -- Size of all alternatives
(SizeIs max _ _) -- Size of biggest alternative
= SizeIs tot (unitBag (v, iBox (_ILIT(2) +# tot -# max)) `unionBags` tot_disc) tot_scrut
= SizeIs tot (unitBag (v, iBox (_ILIT(20) +# tot -# max)) `unionBags` tot_disc) tot_scrut
-- If the variable is known, we produce a discount that
-- will take us back to 'max', the size of the largest alternative
-- The 1+ is a little discount for reduced allocation in the caller
......@@ -398,15 +403,41 @@ sizeExpr bOMB_OUT_SIZE top_args expr
alts_size tot_size _ = tot_size
size_up (Case e _ _ alts) = size_up e `addSizeNSD`
foldr (addAltSize . size_up_alt) sizeZero alts
-- We don't charge for the case itself
-- It's a strict thing, and the price of the call
-- is paid by scrut. Also consider
-- case f x of DEFAULT -> e
-- This is just ';'! Don't charge for it.
--
-- Moreover, we charge one per alternative.
size_up (Case e _ _ alts) = size_up e `addSizeNSD`
foldr (addAltSize . size_up_alt) case_size alts
where
case_size
| is_inline_scrut e, not (lengthExceeds alts 1) = sizeN (-10)
| otherwise = sizeZero
-- Normally we don't charge for the case itself, but
-- we charge one per alternative (see size_up_alt,
-- below) to account for the cost of the info table
-- and comparisons.
--
-- However, in certain cases (see is_inline_scrut
-- below), no code is generated for the case unless
-- there are multiple alts. In these cases we
-- subtract one, making the first alt free.
-- e.g. case x# +# y# of _ -> ... should cost 1
-- case touch# x# of _ -> ... should cost 0
-- (see #4978)
--
-- I would like to not have the "not (lengthExceeds alts 1)"
-- condition above, but without that some programs got worse
-- (spectral/hartel/event and spectral/para). I don't fully
-- understand why. (SDM 24/5/11)
-- unboxed variables, inline primops and unsafe foreign calls
-- are all "inline" things:
is_inline_scrut (Var v) = isUnLiftedType (idType v)
is_inline_scrut scrut
| (Var f, _) <- collectArgs scrut
= case idDetails f of
FCallId fc -> not (isSafeForeignCall fc)
PrimOpId op -> not (primOpOutOfLine op)
_other -> False
| otherwise
= False
------------
-- size_up_app is used when there's ONE OR MORE value args
......@@ -421,14 +452,14 @@ sizeExpr bOMB_OUT_SIZE top_args expr
size_up_call :: Id -> [CoreExpr] -> ExprSize
size_up_call fun val_args
= case idDetails fun of
FCallId _ -> sizeN opt_UF_DearOp
FCallId _ -> sizeN (10 * (1 + length val_args))
DataConWorkId dc -> conSize dc (length val_args)
PrimOpId op -> primOpSize op (length val_args)
ClassOpId _ -> classOpSize top_args val_args
_ -> funSize top_args fun (length val_args)
------------
size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 1
size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 10
-- Don't charge for args, so that wrappers look cheap
-- (See comments about wrappers with Case)
--
......@@ -464,7 +495,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr
-- | Finds a nominal size of a string literal.
litSize :: Literal -> Int
-- Used by CoreUnfold.sizeExpr
litSize (MachStr str) = 1 + ((lengthFS str + 3) `div` 4)
litSize (MachStr str) = 10 + 10 * ((lengthFS str + 3) `div` 4)
-- If size could be 0 then @f "x"@ might be too small
-- [Sept03: make literal strings a bit bigger to avoid fruitless
-- duplication of little strings]
......@@ -479,7 +510,7 @@ classOpSize _ []
classOpSize top_args (arg1 : other_args)
= SizeIs (iUnbox size) arg_discount (_ILIT(0))
where
size = 2 + length other_args
size = 20 + (10 * length other_args)
-- If the class op is scrutinising a lambda bound dictionary then
-- give it a discount, to encourage the inlining of this function
-- The actual discount is rather arbitrarily chosen
......@@ -507,8 +538,7 @@ funSize top_args fun n_val_args
res_discount | idArity fun > n_val_args = opt_UF_FunAppDiscount
| otherwise = 0
-- If the function is partially applied, show a result discount
size | some_val_args = 1 + n_val_args
size | some_val_args = 10 * (1 + n_val_args)
| otherwise = 0
-- The 1+ is for the function itself
-- Add 1 for each non-trivial arg;
......@@ -517,16 +547,17 @@ funSize top_args fun n_val_args
conSize :: DataCon -> Int -> ExprSize
conSize dc n_val_args
| n_val_args == 0 = SizeIs (_ILIT(0)) emptyBag (_ILIT(1)) -- Like variables
-- See Note [Constructor size]
| isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (iUnbox n_val_args +# _ILIT(1))
| n_val_args == 0 = SizeIs (_ILIT(0)) emptyBag (_ILIT(10)) -- Like variables
-- See Note [Unboxed tuple result discount]
-- | isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (_ILIT(0))
| isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (iUnbox (10 * (1 + n_val_args)))
-- See Note [Constructor size]
| otherwise = SizeIs (_ILIT(1)) emptyBag (iUnbox n_val_args +# _ILIT(1))
| otherwise = SizeIs (_ILIT(10)) emptyBag (iUnbox (10 * (10 + n_val_args)))
-- discont was (10 * (1 + n_val_args)), but it turns out that
-- adding a bigger constant here is an unambiguous win. We
-- REALLY like unfolding constructors that get scrutinised.
-- [SDM, 25/5/11]
\end{code}
Note [Constructor size]
......@@ -557,23 +588,15 @@ didn't adopt the idea.
\begin{code}
primOpSize :: PrimOp -> Int -> ExprSize
primOpSize op n_val_args
| not (primOpIsDupable op) = sizeN opt_UF_DearOp
| not (primOpOutOfLine op) = sizeN 1
-- Be very keen to inline simple primops.
-- We give a discount of 1 for each arg so that (op# x y z) costs 2.
-- We can't make it cost 1, else we'll inline let v = (op# x y z)
-- at every use of v, which is excessive.
--
-- A good example is:
-- let x = +# p q in C {x}
-- Even though x get's an occurrence of 'many', its RHS looks cheap,
-- and there's a good chance it'll get inlined back into C's RHS. Urgh!
| otherwise = sizeN n_val_args
= if primOpOutOfLine op
then sizeN (op_size + n_val_args)
else sizeN op_size
where
op_size = primOpCodeSize op
buildSize :: ExprSize
buildSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(4))
buildSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(40))
-- 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
......@@ -582,7 +605,7 @@ buildSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(4))
-- The "4" is rather arbitrary.
augmentSize :: ExprSize
augmentSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(4))
augmentSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(40))
-- Ditto (augment t (\cn -> e) ys) should cost only the cost of
-- e plus ys. The -2 accounts for the \cn
......@@ -714,7 +737,7 @@ certainlyWillInline (CoreUnfolding { uf_is_cheap = is_cheap, uf_arity = n_vals,
UnfNever -> False
UnfWhen {} -> True
UnfIfGoodArgs { ug_size = size}
-> is_cheap && size - (n_vals +1) <= opt_UF_UseThreshold
-> is_cheap && size - (10 * (n_vals +1)) <= opt_UF_UseThreshold
certainlyWillInline _
= False
......@@ -1062,10 +1085,10 @@ computeDiscount n_vals_wanted arg_discounts res_discount arg_infos cont_info
-- *efficiency* to be gained (e.g. beta reductions, case reductions)
-- by inlining.
= 1 -- Discount of 1 because the result replaces the call
= 10 -- Discount of 1 because the result replaces the call
-- so we count 1 for the function itself
+ length (take n_vals_wanted arg_infos)
+ 10 * length (take n_vals_wanted arg_infos)
-- Discount of (un-scaled) 1 for each arg supplied,
-- because the result replaces the call
......@@ -1075,13 +1098,13 @@ computeDiscount n_vals_wanted arg_discounts res_discount arg_infos cont_info
arg_discount = sum (zipWith mk_arg_discount arg_discounts arg_infos)
mk_arg_discount _ TrivArg = 0
mk_arg_discount _ NonTrivArg = 1
mk_arg_discount _ NonTrivArg = 10
mk_arg_discount discount ValueArg = discount
res_discount' = case cont_info of
BoringCtxt -> 0
CaseCtxt -> res_discount
_other -> 4 `min` res_discount
_other -> 40 `min` res_discount
-- res_discount can be very large when a function returns
-- constructors; but we only want to invoke that large discount
-- when there's a case continuation.
......
......@@ -589,12 +589,10 @@ exprIsCheap' good_app other_expr -- Applications and variables
go _ _ = False
--------------
go_pap args = all exprIsTrivial args
-- For constructor applications and primops, check that all
-- the args are trivial. We don't want to treat as cheap, say,
-- (1:2:3:4:5:[])
-- We'll put up with one constructor application, but not dozens
go_pap args = all (exprIsCheap' good_app) args
-- Used to be "all exprIsTrivial args" due to concerns about
-- duplicating nested constructor applications, but see #4978.
--------------
go_primop op args = primOpIsCheap op && all (exprIsCheap' good_app) args
-- In principle we should worry about primops
......
......@@ -552,7 +552,6 @@ Library
TcSplice
Convert
ByteCodeAsm
ByteCodeFFI
ByteCodeGen
ByteCodeInstr
ByteCodeItbls
......
......@@ -252,7 +252,7 @@ PRIMOP_BITS = compiler/primop-data-decl.hs-incl \
compiler/primop-has-side-effects.hs-incl \
compiler/primop-out-of-line.hs-incl \
compiler/primop-commutable.hs-incl \
compiler/primop-needs-wrapper.hs-incl \
compiler/primop-code-size.hs-incl \
compiler/primop-can-fail.hs-incl \
compiler/primop-strictness.hs-incl \
compiler/primop-primop-info.hs-incl
......@@ -278,8 +278,8 @@ compiler/primop-out-of-line.hs-incl: $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE)
"$(GENPRIMOP_INPLACE)" --out-of-line < $< > $@
compiler/primop-commutable.hs-incl: $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE)
"$(GENPRIMOP_INPLACE)" --commutable < $< > $@
compiler/primop-needs-wrapper.hs-incl: $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE)
"$(GENPRIMOP_INPLACE)" --needs-wrapper < $< > $@
compiler/primop-code-size.hs-incl: $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE)
"$(GENPRIMOP_INPLACE)" --code-size < $< > $@
compiler/primop-can-fail.hs-incl: $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE)
"$(GENPRIMOP_INPLACE)" --can-fail < $< > $@
compiler/primop-strictness.hs-incl: $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE)
......
%
% (c) The University of Glasgow 2001-2008
%
ByteCodeGen: Generate machine-code sequences for foreign import
\begin{code}
module ByteCodeFFI ( moan64 ) where
import Outputable
import System.IO
import System.IO.Unsafe
moan64 :: String -> SDoc -> a
moan64 msg pp_rep
= unsafePerformIO (
hPutStrLn stderr (
"\nGHCi's bytecode generation machinery can't handle 64-bit\n" ++
"code properly yet. You can work around this for the time being\n" ++
"by compiling this module and all those it imports to object code,\n" ++
"and re-starting your GHCi session. The panic below contains information,\n" ++
"intended for the GHC implementors, about the exact place where GHC gave up.\n"
)
)
`seq`
pprPanic msg pp_rep
\end{code}
......@@ -124,7 +124,7 @@ data BCInstr
| CASEFAIL
| JMP LocalLabel
-- For doing calls to C (via glue code generated by ByteCodeFFI, or libffi)
-- For doing calls to C (via glue code generated by libffi)
| CCALL Word16 -- stack frame size
(Ptr ()) -- addr of the glue code
Word16 -- whether or not the call is interruptible
......
......@@ -274,7 +274,6 @@ data DynFlag
-- misc opts
| Opt_Pp
| Opt_ForceRecomp
| Opt_DryRun
| Opt_ExcessPrecision
| Opt_EagerBlackHoling
| Opt_ReadUserPackageConf
......@@ -765,9 +764,9 @@ defaultDynFlags mySettings =
maxSimplIterations = 4,
shouldDumpSimplPhase = Nothing,
ruleCheck = Nothing,
specConstrThreshold = Just 200,
specConstrThreshold = Just 2000,
specConstrCount = Just 3,
liberateCaseThreshold = Just 200,
liberateCaseThreshold = Just 2000,
floatLamArgs = Just 0, -- Default: float only if no fvs
strictnessBefore = [],
......@@ -876,7 +875,11 @@ languageExtensions Nothing
-- But NB it's implied by GADTs etc
-- SLPJ September 2010
: Opt_NondecreasingIndentation -- This has been on by default for some time
: languageExtensions (Just Haskell2010)
: delete Opt_DatatypeContexts -- The Haskell' committee decided to
-- remove datatype contexts from the
-- language:
-- http://www.haskell.org/pipermail/haskell-prime/2011-January/003335.html
(languageExtensions (Just Haskell2010))
languageExtensions (Just Haskell98)
= [Opt_ImplicitPrelude,
......@@ -1152,7 +1155,7 @@ allFlags = map ('-':) $
--------------- The main flags themselves ------------------
dynamic_flags :: [Flag (CmdLineP DynFlags)]
dynamic_flags = [
Flag "n" (NoArg (setDynFlag Opt_DryRun))
Flag "n" (NoArg (addWarn "The -n flag is deprecated and no longer has any effect"))
, Flag "cpp" (NoArg (setExtensionFlag Opt_Cpp))
, Flag "F" (NoArg (setDynFlag Opt_Pp))
, Flag "#include"
......
......@@ -56,7 +56,8 @@ import ErrUtils ( debugTraceMsg, putMsg, Message )
import Exception
import System.Directory
import System.FilePath
import System.FilePath as FilePath
import qualified System.FilePath.Posix as FilePath.Posix
import Control.Monad
import Data.List as List
import Data.Map (Map)
......@@ -246,7 +247,8 @@ readPackageConfig dflags conf_file = do
let
top_dir = topDir dflags
pkg_configs1 = mungePackagePaths top_dir proto_pkg_configs
pkgroot = takeDirectory conf_file
pkg_configs1 = map (mungePackagePaths top_dir pkgroot) proto_pkg_configs
pkg_configs2 = maybeHidePackages dflags pkg_configs1
--
return pkg_configs2
......@@ -258,27 +260,52 @@ maybeHidePackages dflags pkgs
where
hide pkg = pkg{ exposed = False }
mungePackagePaths :: String -> [PackageConfig] -> [PackageConfig]
-- Replace the string "$topdir" at the beginning of a path
-- with the current topdir (obtained from the -B option).
mungePackagePaths top_dir ps = map munge_pkg ps
where
munge_pkg p = p{ importDirs = munge_paths (importDirs p),
includeDirs = munge_paths (includeDirs p),
libraryDirs = munge_paths (libraryDirs p),
frameworkDirs = munge_paths (frameworkDirs p),
haddockInterfaces = munge_paths (haddockInterfaces p),
haddockHTMLs = munge_paths (haddockHTMLs p)
}
munge_paths = map munge_path
munge_path p
| Just p' <- stripPrefix "$topdir" p = top_dir ++ p'
| Just p' <- stripPrefix "$httptopdir" p = toHttpPath top_dir ++ p'
| otherwise = p
toHttpPath p = "file:///" ++ p
mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig
-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
-- The "pkgroot" is the directory containing the package database.
--
-- Also perform a similar substitution for the older GHC-specific
-- "$topdir" variable. The "topdir" is the location of the ghc
-- installation (obtained from the -B option).
mungePackagePaths top_dir pkgroot pkg =
pkg {
importDirs = munge_paths (importDirs pkg),
includeDirs = munge_paths (includeDirs pkg),
libraryDirs = munge_paths (libraryDirs pkg),
frameworkDirs = munge_paths (frameworkDirs pkg),
haddockInterfaces = munge_paths (haddockInterfaces pkg),
haddockHTMLs = munge_urls (haddockHTMLs pkg)
}
where
munge_paths = map munge_path
munge_urls = map munge_url
munge_path p
| Just p' <- stripVarPrefix "${pkgroot}" sp = pkgroot </> p'
| Just p' <- stripVarPrefix "$topdir" sp = top_dir </> p'
| otherwise = p
where
sp = splitPath p
munge_url p
| Just p' <- stripVarPrefix "${pkgrooturl}" sp = toUrlPath pkgroot p'
| Just p' <- stripVarPrefix "$httptopdir" sp = toUrlPath top_dir p'
| otherwise = p
where
sp = splitPath p
toUrlPath r p = "file:///"
-- URLs always use posix style '/' separators:
++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p)
stripVarPrefix var (root:path')
| Just [sep] <- stripPrefix var root
, isPathSeparator sep
= Just (joinPath path')
stripVarPrefix _ _ = Nothing
-- -----------------------------------------------------------------------------
......
......@@ -332,16 +332,16 @@ opt_UF_CreationThreshold, opt_UF_UseThreshold :: Int
opt_UF_DearOp, opt_UF_FunAppDiscount, opt_UF_DictDiscount :: Int
opt_UF_KeenessFactor :: Float
opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (45::Int)
opt_UF_UseThreshold = lookup_def_int "-funfolding-use-threshold" (6::Int)
opt_UF_FunAppDiscount = lookup_def_int "-funfolding-fun-discount" (6::Int)
opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (450::Int)
opt_UF_UseThreshold = lookup_def_int "-funfolding-use-threshold" (60::Int)
opt_UF_FunAppDiscount = lookup_def_int "-funfolding-fun-discount" (60::Int)
opt_UF_DictDiscount = lookup_def_int "-funfolding-dict-discount" (3::Int)
opt_UF_DictDiscount = lookup_def_int "-funfolding-dict-discount" (30::Int)
-- Be fairly keen to inline a fuction if that means
-- we'll be able to pick the right method from a dictionary
opt_UF_KeenessFactor = lookup_def_float "-funfolding-keeness-factor" (1.5::Float)
opt_UF_DearOp = ( 4 :: Int)
opt_UF_DearOp = ( 40 :: Int)
-- Related to linking
......
......@@ -788,20 +788,16 @@ data BuildMessage
| EOF
traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
-- a) trace the command (at two levels of verbosity)
-- trace the command (at two levels of verbosity)
traceCmd dflags phase_name cmd_line action
= do { let verb = verbosity dflags
; showPass dflags phase_name
; debugTraceMsg dflags 3 (text cmd_line)
; hFlush stderr
-- Test for -n flag
; unless (dopt Opt_DryRun dflags) $ do {
-- And run it!
; action `catchIO` handle_exn verb
; action `catchIO` handle_exn verb
}
where
handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn))
......
......@@ -13,7 +13,7 @@
{-# LANGUAGE DeriveDataTypeable #-}
module ForeignCall (
ForeignCall(..),
ForeignCall(..), isSafeForeignCall,
Safety(..), playSafe, playInterruptible,
CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
......@@ -43,6 +43,9 @@ newtype ForeignCall = CCall CCallSpec
deriving Eq
{-! derive: Binary !-}
isSafeForeignCall :: ForeignCall -> Bool
isSafeForeignCall (CCall (CCallSpec _ _ safe)) = playSafe safe
-- We may need more clues to distinguish foreign calls
-- but this simple printer will do for now
instance Outputable ForeignCall where
......
......@@ -18,8 +18,8 @@ module PrimOp (
tagToEnumKey,
primOpOutOfLine, primOpNeedsWrapper,
primOpOkForSpeculation, primOpIsCheap, primOpIsDupable,
primOpOutOfLine, primOpCodeSize,
primOpOkForSpeculation, primOpIsCheap,
getPrimOpResultInfo, PrimOpResultInfo(..),
......@@ -363,18 +363,23 @@ primOpIsCheap op = primOpOkForSpeculation op
-- even if primOpIsCheap sometimes says 'True'.
\end{code}
primOpIsDupable
~~~~~~~~~~~~~~~
primOpIsDupable means that the use of the primop is small enough to
duplicate into different case branches. See CoreUtils.exprIsDupable.
primOpCodeSize
~~~~~~~~~~~~~~
Gives an indication of the code size of a primop, for the purposes of
calculating unfolding sizes; see CoreUnfold.sizeExpr.
\begin{code}
primOpIsDupable :: PrimOp -> Bool
-- See comments with CoreUtils.exprIsDupable
-- We say it's dupable it isn't implemented by a C call with a wrapper
primOpIsDupable op = not (primOpNeedsWrapper op)
\end{code}
primOpCodeSize :: PrimOp -> Int
#include "primop-code-size.hs-incl"
primOpCodeSizeDefault :: Int
primOpCodeSizeDefault = 1
-- CoreUnfold.primOpSize already takes into account primOpOutOfLine
-- and adds some further costs for the args in that case.
primOpCodeSizeForeignCall :: Int
primOpCodeSizeForeignCall = 4
\end{code}
\begin{code}
primOpCanFail :: PrimOp -> Bool
......@@ -421,14 +426,6 @@ primOpHasSideEffects :: PrimOp -> Bool
#include "primop-has-side-effects.hs-incl"
\end{code}
Inline primitive operations that perform calls need wrappers to save
any live variables that are stored in caller-saves registers.
\begin{code}
primOpNeedsWrapper :: PrimOp -> Bool
#include "primop-needs-wrapper.hs-incl"
\end{code}
\begin{code}
primOpType :: PrimOp -> Type -- you may want to use primOpSig instead
primOpType op
......
......@@ -43,7 +43,7 @@ defaults
has_side_effects = False
out_of_line = False
commutable = False
needs_wrapper = False
code_size = { primOpCodeSizeDefault }
can_fail = False
strictness = { \ arity -> mkStrictSig (mkTopDmdType (replicate arity lazyDmd) TopRes) }
......@@ -155,6 +155,7 @@ primop CharLtOp "ltChar#" Compare Char# -> Char# -> Bool
primop CharLeOp "leChar#" Compare Char# -> Char# -> Bool
primop OrdOp "ord#" GenPrimOp Char# -> Int#
with code_size = 0
------------------------------------------------------------------------
section "Int#"
......@@ -212,9 +213,12 @@ primop IntNegOp "negateInt#" Monadic Int# -> Int#
primop IntAddCOp "addIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #)
{Add with carry. First member of result is (wrapped) sum;
second member is 0 iff no overflow occured.}
with code_size = 2
primop IntSubCOp "subIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #)
{Subtract with carry. First member of result is (wrapped) difference;
second member is 0 iff no overflow occured.}
with code_size = 2
primop IntGtOp ">#" Compare Int# -> Int# -> Bool
primop IntGeOp ">=#" Compare Int# -> Int# -> Bool
......@@ -231,8 +235,11 @@ primop IntLtOp "<#" Compare Int# -> Int# -> Bool
primop IntLeOp "<=#" Compare Int# -> Int# -> Bool
primop ChrOp "chr#" GenPrimOp Int# -> Char#
with code_size = 0
primop Int2WordOp "int2Word#" GenPrimOp Int# -> Word#
with code_size = 0
primop Int2FloatOp "int2Float#" GenPrimOp Int# -> Float#
primop Int2DoubleOp "int2Double#" GenPrimOp Int# -> Double#
......@@ -286,6 +293,7 @@ primop SrlOp "uncheckedShiftRL#" GenPrimOp Word# -> Int# -> Word#
in the range 0 to word size - 1 inclusive.}