import FastTypes
import FastString
import Outputable
+import ForeignCall
+
import Data.Maybe
\end{code}
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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- See Note [INLINE for small functions]
uncondInline arity size
| arity == 0 = size == 0
- | otherwise = size <= arity + 1
+ | otherwise = size <= 10 * (arity + 1)
\end{code}
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)
-- 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
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
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)
--
-- | 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]
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
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;
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]
\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
-- 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
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
-- *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
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.
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
TcSplice
Convert
ByteCodeAsm
- ByteCodeFFI
ByteCodeGen
ByteCodeInstr
ByteCodeItbls
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
"$(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)
+++ /dev/null
-%
-% (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}
-
| 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
-- misc opts
| Opt_Pp
| Opt_ForceRecomp
- | Opt_DryRun
| Opt_ExcessPrecision
| Opt_EagerBlackHoling
| Opt_ReadUserPackageConf
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 = [],
-- 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,
--------------- 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"
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)
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
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
-- -----------------------------------------------------------------------------
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
| EOF
traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
--- a) trace the command (at two levels of verbosity)
--- b) don't do it at all if dry-run is set
+-- 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
- }}
+ }
where
handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn))
{-# LANGUAGE DeriveDataTypeable #-}
module ForeignCall (
- ForeignCall(..),
+ ForeignCall(..), isSafeForeignCall,
Safety(..), playSafe, playInterruptible,
CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
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
tagToEnumKey,
- primOpOutOfLine, primOpNeedsWrapper,
- primOpOkForSpeculation, primOpIsCheap, primOpIsDupable,
+ primOpOutOfLine, primOpCodeSize,
+ primOpOkForSpeculation, primOpIsCheap,
getPrimOpResultInfo, PrimOpResultInfo(..),
-- 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
#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
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) }
primop CharLeOp "leChar#" Compare Char# -> Char# -> Bool
primop OrdOp "ord#" GenPrimOp Char# -> Int#
+ with code_size = 0
------------------------------------------------------------------------
section "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
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#
in the range 0 to word size - 1 inclusive.}
primop Word2IntOp "word2Int#" GenPrimOp Word# -> Int#
+ with code_size = 0
primop WordGtOp "gtWord#" Compare Word# -> Word# -> Bool
primop WordGeOp "geWord#" Compare Word# -> Word# -> Bool
primop DoubleExpOp "expDouble#" Monadic
Double# -> Double#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop DoubleLogOp "logDouble#" Monadic
Double# -> Double#
with
- needs_wrapper = True
+ code_size = { primOpCodeSizeForeignCall }
can_fail = True
primop DoubleSqrtOp "sqrtDouble#" Monadic
Double# -> Double#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop DoubleSinOp "sinDouble#" Monadic
Double# -> Double#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop DoubleCosOp "cosDouble#" Monadic
Double# -> Double#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop DoubleTanOp "tanDouble#" Monadic
Double# -> Double#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop DoubleAsinOp "asinDouble#" Monadic
Double# -> Double#
with
- needs_wrapper = True
+ code_size = { primOpCodeSizeForeignCall }
can_fail = True
primop DoubleAcosOp "acosDouble#" Monadic
Double# -> Double#
with
- needs_wrapper = True
+ code_size = { primOpCodeSizeForeignCall }
can_fail = True
primop DoubleAtanOp "atanDouble#" Monadic
Double# -> Double#
with
- needs_wrapper = True
+ code_size = { primOpCodeSizeForeignCall }
primop DoubleSinhOp "sinhDouble#" Monadic
Double# -> Double#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop DoubleCoshOp "coshDouble#" Monadic
Double# -> Double#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop DoubleTanhOp "tanhDouble#" Monadic
Double# -> Double#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop DoublePowerOp "**##" Dyadic
Double# -> Double# -> Double#
{Exponentiation.}
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop DoubleDecode_2IntOp "decodeDouble_2Int#" GenPrimOp
Double# -> (# Int#, Word#, Word#, Int# #)
primop FloatExpOp "expFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop FloatLogOp "logFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
- can_fail = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
+ can_fail = True
primop FloatSqrtOp "sqrtFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop FloatSinOp "sinFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop FloatCosOp "cosFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop FloatTanOp "tanFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop FloatAsinOp "asinFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
- can_fail = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
+ can_fail = True
primop FloatAcosOp "acosFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
- can_fail = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
+ can_fail = True
primop FloatAtanOp "atanFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop FloatSinhOp "sinhFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop FloatCoshOp "coshFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop FloatTanhOp "tanhFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop FloatPowerOp "powerFloat#" Dyadic
Float# -> Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop Float2DoubleOp "float2Double#" GenPrimOp Float# -> Double#
{Write to specified index of mutable array.}
with
has_side_effects = True
+ code_size = 2 -- card update too
primop SizeofArrayOp "sizeofArray#" GenPrimOp
Array# a -> Int#
The two arrays must not be the same array in different states, but this is not checked either.}
with
has_side_effects = True
+ code_size = { primOpCodeSizeForeignCall + 4 }
primop CopyMutableArrayOp "copyMutableArray#" GenPrimOp
MutableArray# s a -> Int# -> MutableArray# s a -> Int# -> Int# -> State# s -> State# s
Both arrays must fully contain the specified ranges, but this is not checked.}
with
has_side_effects = True
+ code_size = { primOpCodeSizeForeignCall + 4 }
primop CloneArrayOp "cloneArray#" GenPrimOp
Array# a -> Int# -> Int# -> Array# a
The provided Array# should contain the full subrange specified by the two Int#s, but this is not checked.}
with
has_side_effects = True
+ code_size = { primOpCodeSizeForeignCall + 4 }
primop CloneMutableArrayOp "cloneMutableArray#" GenPrimOp
MutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a #)
The provided MutableArray# should contain the full subrange specified by the two Int#s, but this is not checked.}
with
has_side_effects = True
+ code_size = { primOpCodeSizeForeignCall + 4 }
primop FreezeArrayOp "freezeArray#" GenPrimOp
MutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, Array# a #)
The provided MutableArray# should contain the full subrange specified by the two Int#s, but this is not checked.}
with
has_side_effects = True
+ code_size = { primOpCodeSizeForeignCall + 4 }
primop ThawArrayOp "thawArray#" GenPrimOp
Array# a -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a #)
The provided Array# should contain the full subrange specified by the two Int#s, but this is not checked.}
with
has_side_effects = True
+ code_size = { primOpCodeSizeForeignCall + 4 }
------------------------------------------------------------------------
section "Byte Arrays"
#if (WORD_SIZE_IN_BITS == 32 || WORD_SIZE_IN_BITS == 64)
primop Addr2IntOp "addr2Int#" GenPrimOp Addr# -> Int#
{Coerce directly from address to int. Strongly deprecated.}
+ with code_size = 0
primop Int2AddrOp "int2Addr#" GenPrimOp Int# -> Addr#
{Coerce directly from int to address. Strongly deprecated.}
+ with code_size = 0
#endif
primop AddrGtOp "gtAddr#" Compare Addr# -> Addr# -> Bool
{Write contents of {\tt MutVar\#}.}
with
has_side_effects = True
+ code_size = { primOpCodeSizeForeignCall } -- for the write barrier
primop SameMutVarOp "sameMutVar#" GenPrimOp
MutVar# s a -> MutVar# s a -> Bool
Int# -> State# s -> State# s
{Sleep specified number of microseconds.}
with
- needs_wrapper = True
has_side_effects = True
out_of_line = True
Int# -> State# s -> State# s
{Block until input is available on specified file descriptor.}
with
- needs_wrapper = True
has_side_effects = True
out_of_line = True
Int# -> State# s -> State# s
{Block until output is possible on specified file descriptor.}
with
- needs_wrapper = True
has_side_effects = True
out_of_line = True
Int# -> Int# -> Int# -> Addr# -> State# RealWorld-> (# State# RealWorld, Int#, Int# #)
{Asynchronously read bytes from specified file descriptor.}
with
- needs_wrapper = True
has_side_effects = True
out_of_line = True
Int# -> Int# -> Int# -> Addr# -> State# RealWorld-> (# State# RealWorld, Int#, Int# #)
{Asynchronously write bytes from specified file descriptor.}
with
- needs_wrapper = True
has_side_effects = True
out_of_line = True
Addr# -> Addr# -> State# RealWorld-> (# State# RealWorld, Int#, Int# #)
{Asynchronously perform procedure (first arg), passing it 2nd arg.}
with
- needs_wrapper = True
has_side_effects = True
out_of_line = True
primop TouchOp "touch#" GenPrimOp
o -> State# RealWorld -> State# RealWorld
with
+ code_size = { 0 }
has_side_effects = True
------------------------------------------------------------------------
primop DeRefStablePtrOp "deRefStablePtr#" GenPrimOp
StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #)
with
- needs_wrapper = True
has_side_effects = True
out_of_line = True
primop MakeStableNameOp "makeStableName#" GenPrimOp
a -> State# RealWorld -> (# State# RealWorld, StableName# a #)
with
- needs_wrapper = True
has_side_effects = True
out_of_line = True
-- Note that Par is lazy to avoid that the sparked thing
-- gets evaluted strictly, which it should *not* be
has_side_effects = True
+ code_size = { primOpCodeSizeForeignCall }
primop GetSparkOp "getSpark#" GenPrimOp
State# s -> (# State# s, Int#, a #)
primop AddrToHValueOp "addrToHValue#" GenPrimOp
Addr# -> (# a #)
{Convert an {\tt Addr\#} to a followable type.}
+ with
+ code_size = 0
primop MkApUpd0_Op "mkApUpd0#" GenPrimOp
BCO# -> (# a #)
<entry>mode</entry>
<entry>-</entry>
</row>
- <row>
- <entry><option>-n</option></entry>
- <entry>do a dry run</entry>
- <entry>dynamic</entry>
- <entry>-</entry>
- </row>
- <row>
+ <row>
<entry><option>-v</option></entry>
<entry>verbose mode (equivalent to <option>-v3</option>)</entry>
<entry>dynamic</entry>
restrains the strictness analyser.
</para></listitem>
<listitem><para>
-<ulink url="&libraryGhcPrimLocation;/GHC-Prim.html#v%3AunsafeCoerce%23"><literal>lazy</literal></ulink>
+<ulink url="&libraryGhcPrimLocation;/GHC-Prim.html#v%3AunsafeCoerce%23"><literal>unsafeCoerce#</literal></ulink>
allows you to fool the type checker.
</para></listitem>
</itemizedlist>
<variablelist>
<varlistentry>
<term>
- <option>-n</option>
- <indexterm><primary><option>-n</option></primary></indexterm>
- </term>
- <listitem>
- <para>Does a dry-run, i.e. GHC goes through all the motions
- of compiling as normal, but does not actually run any
- external commands.</para>
- </listitem>
- </varlistentry>
-
- <varlistentry>
- <term>
<option>-v</option>
<indexterm><primary><option>-v</option></primary></indexterm>
</term>
Miscellaneous garbage
-------------------------------------------------------------------------- */
-/* declarations for runtime flags/values */
-#define MAX_RTS_ARGS 32
-
#ifdef DEBUG
#define TICK_VAR(arity) \
extern StgInt SLOW_CALLS_##arity; \
#define EVENT_GC_END 10 /* () */
#define EVENT_REQUEST_SEQ_GC 11 /* () */
#define EVENT_REQUEST_PAR_GC 12 /* () */
-/* 13, 14 deprecated */
#define EVENT_CREATE_SPARK_THREAD 15 /* (spark_thread) */
#define EVENT_LOG_MSG 16 /* (message ...) */
#define EVENT_STARTUP 17 /* (num_capabilities) */
#define EVENT_GC_IDLE 20 /* () */
#define EVENT_GC_WORK 21 /* () */
#define EVENT_GC_DONE 22 /* () */
-/* 23, 24 used by eden */
-#define EVENT_CAPSET_CREATE 25 /* (capset, capset_type) */
-#define EVENT_CAPSET_DELETE 26 /* (capset) */
-#define EVENT_CAPSET_ASSIGN_CAP 27 /* (capset, cap) */
-#define EVENT_CAPSET_REMOVE_CAP 28 /* (capset, cap) */
-/* the RTS identifier is in the form of "GHC-version rts_way" */
-#define EVENT_RTS_IDENTIFIER 29 /* (capset, name_version_string) */
-/* the vectors in these events are null separated strings */
-#define EVENT_PROGRAM_ARGS 30 /* (capset, commandline_vector) */
-#define EVENT_PROGRAM_ENV 31 /* (capset, environment_vector) */
-#define EVENT_OSPROCESS_PID 32 /* (capset, pid, parent_pid) */
-
-/* Range 33 - 59 is available for new events */
-
-/* Range 60 - 80 is used by eden for parallel tracing
- * see http://www.mathematik.uni-marburg.de/~eden/
- */
-
-/*
- * The highest event code +1 that ghc itself emits. Note that some event
- * ranges higher than this are reserved but not currently emitted by ghc.
- * This must match the size of the EventDesc[] array in EventLog.c
- */
-#define NUM_EVENT_TAGS 33
+#define NUM_EVENT_TAGS 23
#if 0 /* DEPRECATED EVENTS: */
-/* ghc changed how it handles sparks so these are no longer applicable */
#define EVENT_CREATE_SPARK 13 /* (cap, thread) */
#define EVENT_SPARK_TO_THREAD 14 /* (cap, thread, spark_thread) */
-/* these are used by eden but are replaced by new alternatives for ghc */
-#define EVENT_VERSION 23 /* (version_string) */
-#define EVENT_PROGRAM_INVOCATION 24 /* (commandline_string) */
#endif
/*
*/
#define THREAD_SUSPENDED_FOREIGN_CALL 6
-/*
- * Capset type values for EVENT_CAPSET_CREATE
- */
-#define CAPSET_TYPE_CUSTOM 1 /* reserved for end-user applications */
-#define CAPSET_TYPE_OSPROCESS 2 /* caps belong to the same OS process */
-#define CAPSET_TYPE_CLOCKDOMAIN 3 /* caps share a local clock/time */
-
#ifndef EVENTLOG_CONSTANTS_ONLY
typedef StgWord16 EventTypeNum;
typedef StgWord16 EventCapNo;
typedef StgWord16 EventPayloadSize; /* variable-size events */
typedef StgWord16 EventThreadStatus; /* status for EVENT_STOP_THREAD */
-typedef StgWord32 EventCapsetID;
-typedef StgWord16 EventCapsetType; /* types for EVENT_CAPSET_CREATE */
#endif
extern int prog_argc;
extern char **prog_argv;
*/
-extern int rts_argc; /* ditto */
-extern char *rts_argv[];
+extern int rts_argc; /* ditto */
+extern char **rts_argv;
#endif /* RTS_FLAGS_H */
*
* ------------------------------------------------------------------------- */
+// A count of blocks needs to store anything up to the size of memory
+// divided by the block size. The safest thing is therefore to use a
+// type that can store the full range of memory addresses,
+// ie. StgWord. Note that we have had some tricky int overflows in a
+// couple of cases caused by using ints rather than longs (e.g. #5086)
+
+typedef StgWord memcount;
+
typedef struct nursery_ {
bdescr * blocks;
- unsigned int n_blocks;
+ memcount n_blocks;
} nursery;
typedef struct generation_ {
unsigned int no; // generation number
bdescr * blocks; // blocks in this gen
- unsigned int n_blocks; // number of blocks
- unsigned int n_words; // number of used words
+ memcount n_blocks; // number of blocks
+ memcount n_words; // number of used words
bdescr * large_objects; // large objects (doubly linked)
- unsigned int n_large_blocks; // no. of blocks used by large objs
- unsigned long n_new_large_words; // words of new large objects
+ memcount n_large_blocks; // no. of blocks used by large objs
+ memcount n_new_large_words; // words of new large objects
// (for allocation stats)
- unsigned int max_blocks; // max blocks
+ memcount max_blocks; // max blocks
StgTSO * threads; // threads in this gen
// linked via global_link
// are copied into the following two fields. After GC, these blocks
// are freed.
bdescr * old_blocks; // bdescr of first from-space block
- unsigned int n_old_blocks; // number of blocks in from-space
- unsigned int live_estimate; // for sweeping: estimate of live data
+ memcount n_old_blocks; // number of blocks in from-space
+ memcount live_estimate; // for sweeping: estimate of live data
bdescr * scavenged_large_objects; // live large objs after GC (d-link)
- unsigned int n_scavenged_large_blocks; // size (not count) of above
+ memcount n_scavenged_large_blocks; // size (not count) of above
bdescr * bitmap; // bitmap for compacting collection
cap->transaction_tokens = 0;
cap->context_switch = 0;
cap->pinned_object_block = NULL;
-
- traceCapsetAssignCap(CAPSET_OSPROCESS_DEFAULT, i);
}
/* ---------------------------------------------------------------------------
void
initCapabilities( void )
{
-
#if defined(THREADED_RTS)
nat i;
#else
freeCapability(&MainCapability);
#endif
- traceCapsetDelete(CAPSET_OSPROCESS_DEFAULT);
}
/* ---------------------------------------------------------------------------
char **full_prog_argv = NULL;
char *prog_name = NULL; /* 'basename' of prog_argv[0] */
int rts_argc = 0; /* ditto */
-char *rts_argv[MAX_RTS_ARGS];
+char **rts_argv = NULL;
#if defined(mingw32_HOST_OS)
// On Windows, we want to use GetCommandLineW rather than argc/argv,
// but we need to mutate the command line arguments for withProgName and
static void errorUsage (void) GNU_ATTRIBUTE(__noreturn__);
+static char * copyArg (char *arg);
+static char ** copyArgv (int argc, char *argv[]);
+static void freeArgv (int argc, char *argv[]);
+
/* -----------------------------------------------------------------------------
* Command-line option parsing routines.
* ---------------------------------------------------------------------------*/
if (c1 == c2) { break; }
- if (rts_argc < MAX_RTS_ARGS-1) {
- s = stgMallocBytes(c2-c1+1, "RtsFlags.c:splitRtsFlags()");
- strncpy(s, c1, c2-c1);
- s[c2-c1] = '\0';
- rts_argv[rts_argc++] = s;
- } else {
- barf("too many RTS arguments (max %d)", MAX_RTS_ARGS-1);
- }
-
+ s = stgMallocBytes(c2-c1+1, "RtsFlags.c:splitRtsFlags()");
+ strncpy(s, c1, c2-c1);
+ s[c2-c1] = '\0';
+ rts_argv[rts_argc++] = s;
+
c1 = c2;
} while (*c1 != '\0');
}
- argv[] is *modified*, any RTS options have been stripped out
- *argc contains the new count of arguments in argv[]
- - rts_argv[] (global) contains the collected RTS args
+ - rts_argv[] (global) contains a copy of the collected RTS args
- rts_argc (global) contains the count of args in rts_argv
- - prog_argv[] (global) contains the non-RTS args (== argv)
+ - prog_argv[] (global) contains a copy of the non-RTS args (== argv)
- prog_argc (global) contains the count of args in prog_argv
- - prog_name (global) contains the basename of argv[0]
+ - prog_name (global) contains the basename of prog_argv[0]
-------------------------------------------------------------------------- */
*argc = 1;
rts_argc = 0;
+ rts_argv = stgCallocBytes(total_arg + 1, sizeof (char *), "setupRtsFlags");
+
rts_argc0 = rts_argc;
// process arguments from the ghc_rts_opts global variable first.
else if (strequal("-RTS", argv[arg])) {
mode = PGM;
}
- else if (mode == RTS && rts_argc < MAX_RTS_ARGS-1) {
- rts_argv[rts_argc++] = argv[arg];
+ else if (mode == RTS) {
+ rts_argv[rts_argc++] = copyArg(argv[arg]);
}
- else if (mode == PGM) {
- argv[(*argc)++] = argv[arg];
- }
- else {
- barf("too many RTS arguments (max %d)", MAX_RTS_ARGS-1);
+ else {
+ argv[(*argc)++] = argv[arg];
}
}
// process remaining program arguments
stg_exit(EXIT_FAILURE);
}
+/* ----------------------------------------------------------------------------
+ Copying and freeing argc/argv
+ ------------------------------------------------------------------------- */
+
+static char * copyArg(char *arg)
+{
+ char *new_arg = stgMallocBytes(strlen(arg) + 1, "copyArg");
+ strcpy(new_arg, arg);
+ return new_arg;
+}
+
+static char ** copyArgv(int argc, char *argv[])
+{
+ int i;
+ char **new_argv;
+
+ new_argv = stgCallocBytes(argc + 1, sizeof (char *), "copyArgv 1");
+ for (i = 0; i < argc; i++) {
+ new_argv[i] = copyArg(argv[i]);
+ }
+ new_argv[argc] = NULL;
+ return new_argv;
+}
+
+static void freeArgv(int argc, char *argv[])
+{
+ int i;
+ if (argv != NULL) {
+ for (i = 0; i < argc; i++) {
+ stgFree(argv[i]);
+ }
+ stgFree(argv);
+ }
+}
+
/* -----------------------------------------------------------------------------
Getting/Setting the program's arguments.
setProgArgv(int argc, char *argv[])
{
prog_argc = argc;
- prog_argv = argv;
+ prog_argv = copyArgv(argc,argv);
setProgName(prog_argv);
}
+static void
+freeProgArgv(void)
+{
+ freeArgv(prog_argc,prog_argv);
+ prog_argc = 0;
+ prog_argv = NULL;
+}
+
+/* ----------------------------------------------------------------------------
+ The full argv - a copy of the original program's argc/argv
+ ------------------------------------------------------------------------- */
+
+void
+setFullProgArgv(int argc, char *argv[])
+{
+ full_prog_argc = argc;
+ full_prog_argv = copyArgv(argc,argv);
+}
+
/* These functions record and recall the full arguments, including the
+RTS ... -RTS options. The reason for adding them was so that the
ghc-inplace program can pass /all/ the arguments on to the real ghc. */
}
void
-setFullProgArgv(int argc, char *argv[])
-{
- int i;
- full_prog_argc = argc;
- full_prog_argv = stgCallocBytes(argc + 1, sizeof (char *),
- "setFullProgArgv 1");
- for (i = 0; i < argc; i++) {
- full_prog_argv[i] = stgMallocBytes(strlen(argv[i]) + 1,
- "setFullProgArgv 2");
- strcpy(full_prog_argv[i], argv[i]);
- }
- full_prog_argv[argc] = NULL;
-}
-
-void
freeFullProgArgv (void)
{
- int i;
-
- if (full_prog_argv != NULL) {
- for (i = 0; i < full_prog_argc; i++) {
- stgFree(full_prog_argv[i]);
- }
- stgFree(full_prog_argv);
- }
-
+ freeArgv(full_prog_argc, full_prog_argv);
full_prog_argc = 0;
full_prog_argv = NULL;
}
+/* ----------------------------------------------------------------------------
+ The Win32 argv
+ ------------------------------------------------------------------------- */
+
#if defined(mingw32_HOST_OS)
void freeWin32ProgArgv (void);
void
freeWin32ProgArgv (void)
{
+ freeArgv(win32_prog_argc, win32_prog_argv);
+
int i;
if (win32_prog_argv != NULL) {
win32_prog_argv[argc] = NULL;
}
#endif
+
+/* ----------------------------------------------------------------------------
+ The RTS argv
+ ------------------------------------------------------------------------- */
+
+static void
+freeRtsArgv(void)
+{
+ freeArgv(rts_argc,rts_argv);
+ rts_argc = 0;
+ rts_argv = NULL;
+}
+
+/* ----------------------------------------------------------------------------
+ All argvs
+ ------------------------------------------------------------------------- */
+
+void freeRtsArgs(void)
+{
+#if defined(mingw32_HOST_OS)
+ freeWin32ProgArgv();
+#endif
+ freeFullProgArgv();
+ freeProgArgv();
+ freeRtsArgv();
+}
void initRtsFlagsDefaults (void);
void setupRtsFlags (int *argc, char *argv[]);
void setProgName (char *argv[]);
+void freeRtsArgs (void);
#include "EndPrivate.h"
* typedef uint16_t EventCapNo;
* typedef uint16_t EventPayloadSize; // variable-size events
* typedef uint16_t EventThreadStatus;
- * typedef uint32_t EventCapsetID;
- * typedef uint16_t EventCapsetType; // types for EVENT_CAPSET_CREATE
*/
/* -----------------------------------------------------------------------------
probe gc__idle (EventCapNo);
probe gc__work (EventCapNo);
probe gc__done (EventCapNo);
- probe capset__create(EventCapsetID, EventCapsetType);
- probe capset__delete(EventCapsetID);
- probe capset__assign__cap(EventCapsetID, EventCapNo);
- probe capset__remove__cap(EventCapsetID, EventCapNo);
};
*/
dtraceEventStartup();
- /* Trace some basic information about the process
- */
- traceCapsetDetails(argc, argv);
-
/* initialise scheduler data structures (needs to be done before
* initStorage()).
*/
checkFPUStack();
#endif
- // Free the full argv storage
- freeFullProgArgv();
-
#if defined(THREADED_RTS)
ioManagerDie();
#endif
// heap memory (e.g. by being passed a ByteArray#).
freeStorage(wait_foreign);
+ // Free the various argvs
+ freeRtsArgs();
}
// The real hs_exit():
}
sched_state = SCHED_SHUTTING_DOWN;
- nat i;
-
- for (i = 0; i < n_capabilities; i++) {
#if defined(THREADED_RTS)
- ASSERT(task->incall->tso == NULL);
- shutdownCapability(&capabilities[i], task, wait_foreign);
-#endif
- traceCapsetRemoveCap(CAPSET_OSPROCESS_DEFAULT, i);
+ {
+ nat i;
+
+ for (i = 0; i < n_capabilities; i++) {
+ ASSERT(task->incall->tso == NULL);
+ shutdownCapability(&capabilities[i], task, wait_foreign);
+ }
}
- traceCapsetDelete(CAPSET_OSPROCESS_DEFAULT);
+#endif
boundTaskExiting(task);
}
gen_blocks += gcThreadLiveBlocks(i,g);
}
- debugBelch("%5d %7d %9d", g, gen->max_blocks, mut);
+ debugBelch("%5d %7ld %9d", g, (lnat)gen->max_blocks, mut);
gen_slop = gen_blocks * BLOCK_SIZE_W - gen_live;
#include "Threads.h"
#include "Printer.h"
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
#ifdef DEBUG
// debugging flags, set with +RTS -D<something>
int DEBUG_sched;
}
}
-void traceCapsetModify_ (EventTypeNum tag,
- CapsetID capset,
- StgWord32 other,
- StgWord32 other2)
-{
-#ifdef DEBUG
- if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) {
- ACQUIRE_LOCK(&trace_utx);
-
- tracePreface();
- switch (tag) {
- case EVENT_CAPSET_CREATE: // (capset, capset_type)
- debugBelch("created capset %d of type %d\n", capset, other);
- break;
- case EVENT_CAPSET_DELETE: // (capset)
- debugBelch("deleted capset %d\n", capset);
- break;
- case EVENT_CAPSET_ASSIGN_CAP: // (capset, capno)
- debugBelch("assigned cap %d to capset %d\n", other, capset);
- break;
- case EVENT_CAPSET_REMOVE_CAP: // (capset, capno)
- debugBelch("removed cap %d from capset %d\n", other, capset);
- break;
- }
- RELEASE_LOCK(&trace_utx);
- } else
-#endif
- {
- if(eventlog_enabled) postCapsetModifyEvent(tag, capset, other, other2);
- }
-}
-
-extern char **environ;
-
-void traceCapsetDetails_(int *argc, char **argv[]){
- if(eventlog_enabled){
- postCapsetModifyEvent(EVENT_OSPROCESS_PID,
- CAPSET_OSPROCESS_DEFAULT,
- getpid(),
- getppid());
-
- char buf[256];
- snprintf(buf, sizeof(buf), "GHC-%s %s", ProjectVersion, RtsWay);
- postCapsetStrEvent(EVENT_RTS_IDENTIFIER,
- CAPSET_OSPROCESS_DEFAULT,
- buf);
-
- if(argc != NULL && argv != NULL){
- postCapsetVecEvent(EVENT_PROGRAM_ARGS,
- CAPSET_OSPROCESS_DEFAULT,
- *argc,
- *argv);
- }
-
- int env_len;
- for( env_len = 0; environ[env_len] != NULL; env_len++);
- postCapsetVecEvent(EVENT_PROGRAM_ENV,
- CAPSET_OSPROCESS_DEFAULT,
- env_len,
- environ);
- }
-}
-
void traceEvent_ (Capability *cap, EventTypeNum tag)
{
#ifdef DEBUG
#endif /* TRACING */
-typedef StgWord32 CapsetID;
-typedef StgWord16 CapsetType;
-enum CapsetType { CapsetTypeCustom = CAPSET_TYPE_CUSTOM,
- CapsetTypeOsProcess = CAPSET_TYPE_OSPROCESS,
- CapsetTypeClockdomain = CAPSET_TYPE_CLOCKDOMAIN };
-#define CAPSET_OSPROCESS_DEFAULT 0
-
// -----------------------------------------------------------------------------
// Message classes
// -----------------------------------------------------------------------------
void traceThreadStatus_ (StgTSO *tso);
-/*
- * Events for describing capability sets in the eventlog
- *
- * Note: unlike other events, these are not conditional on TRACE_sched or
- * similar because they are not "real" events themselves but provide
- * information and context for other "real" events. Other events depend on
- * the capset info events so for simplicity, rather than working out if
- * they're necessary we always emit them. They should be very low volume.
- */
-void traceCapsetModify_ (EventTypeNum tag,
- CapsetID capset,
- StgWord32 other,
- StgWord32 other2);
-
-void traceCapsetDetails_ (int *argc, char **argv[]);
#else /* !TRACING */
#define traceSchedEvent(cap, tag, tso, other) /* nothing */
#define debugTrace(class, str, ...) /* nothing */
#define debugTraceCap(class, cap, str, ...) /* nothing */
#define traceThreadStatus(class, tso) /* nothing */
-#define traceCapsetModify_(tag, capset, other, other2) /* nothing */
-#define traceCapsetDetails_(argc, argv) /* nothing */
#endif /* TRACING */
HASKELLEVENT_GC_WORK(cap)
#define dtraceGcDone(cap) \
HASKELLEVENT_GC_DONE(cap)
-#define dtraceCapsetCreate(capset, capset_type) \
- HASKELLEVENT_CAPSET_CREATE(capset, capset_type)
-#define dtraceCapsetDelete(capset) \
- HASKELLEVENT_CAPSET_DELETE(capset)
-#define dtraceCapsetAssignCap(capset, capno) \
- HASKELLEVENT_CAPSET_ASSIGN_CAP(capset, capno)
-#define dtraceCapsetRemoveCap(capset, capno) \
- HASKELLEVENT_CAPSET_REMOVE_CAP(capset, capno)
#else /* !defined(DTRACE) */
#define dtraceGcIdle(cap) /* nothing */
#define dtraceGcWork(cap) /* nothing */
#define dtraceGcDone(cap) /* nothing */
-#define dtraceCapsetCreate(capset, capset_type) /* nothing */
-#define dtraceCapsetDelete(capset) /* nothing */
-#define dtraceCapsetAssignCap(capset, capno) /* nothing */
-#define dtraceCapsetRemoveCap(capset, capno) /* nothing */
#endif
dtraceGcDone((EventCapNo)cap->no);
}
-INLINE_HEADER void traceCapsetCreate(CapsetID capset STG_UNUSED,
- CapsetType capset_type STG_UNUSED)
-{
- traceCapsetModify_(EVENT_CAPSET_CREATE, capset, capset_type, 0);
- dtraceCapsetCreate(capset, capset_type);
-}
-
-INLINE_HEADER void traceCapsetDelete(CapsetID capset STG_UNUSED)
-{
- traceCapsetModify_(EVENT_CAPSET_DELETE, capset, 0, 0);
- dtraceCapsetDelete(capset);
-}
-
-INLINE_HEADER void traceCapsetAssignCap(CapsetID capset STG_UNUSED,
- nat capno STG_UNUSED)
-{
- traceCapsetModify_(EVENT_CAPSET_ASSIGN_CAP, capset, capno, 0);
- dtraceCapsetAssignCap(capset, capno);
-}
-
-INLINE_HEADER void traceCapsetRemoveCap(CapsetID capset STG_UNUSED,
- nat capno STG_UNUSED)
-{
- traceCapsetModify_(EVENT_CAPSET_REMOVE_CAP, capset, capno, 0);
- dtraceCapsetRemoveCap(capset, capno);
-}
-
-INLINE_HEADER void traceCapsetDetails(int *argc STG_UNUSED, char **argv[] STG_UNUSED)
-{
- traceCapsetCreate(CAPSET_OSPROCESS_DEFAULT, CapsetTypeOsProcess);
- traceCapsetDetails_(argc, argv);
-}
-
#include "EndPrivate.h"
#endif /* TRACE_H */
[EVENT_GC_IDLE] = "GC idle",
[EVENT_GC_WORK] = "GC working",
[EVENT_GC_DONE] = "GC done",
- [EVENT_BLOCK_MARKER] = "Block marker",
- [EVENT_CAPSET_CREATE] = "Create capability set",
- [EVENT_CAPSET_DELETE] = "Delete capability set",
- [EVENT_CAPSET_ASSIGN_CAP] = "Add capability to capability set",
- [EVENT_CAPSET_REMOVE_CAP] = "Remove capability from capability set",
- [EVENT_RTS_IDENTIFIER] = "Identify the RTS version",
- [EVENT_PROGRAM_ARGS] = "Identify the program arguments",
- [EVENT_PROGRAM_ENV] = "Identify the environment variables",
- [EVENT_OSPROCESS_PID] = "Identify the process ID of a capability set"
+ [EVENT_BLOCK_MARKER] = "Block marker"
};
// Event type.
static inline void postCapNo(EventsBuf *eb, EventCapNo no)
{ postWord16(eb,no); }
-static inline void postCapsetID(EventsBuf *eb, EventCapsetID id)
-{ postWord32(eb,id); }
-
-static inline void postCapsetType(EventsBuf *eb, EventCapsetType type)
-{ postWord16(eb,type); }
-
static inline void postPayloadSize(EventsBuf *eb, EventPayloadSize size)
{ postWord16(eb,size); }
eventTypes[t].size = sizeof(EventCapNo);
break;
- case EVENT_CAPSET_CREATE: // (capset, capset_type)
- eventTypes[t].size =
- sizeof(EventCapsetID) + sizeof(EventCapsetType);
- break;
-
- case EVENT_CAPSET_DELETE: // (capset)
- eventTypes[t].size = sizeof(EventCapsetID);
- break;
-
- case EVENT_CAPSET_ASSIGN_CAP: // (capset, cap)
- case EVENT_CAPSET_REMOVE_CAP:
- eventTypes[t].size =
- sizeof(EventCapsetID) + sizeof(EventCapNo);
- break;
-
- case EVENT_OSPROCESS_PID: // (cap, pid, parent pid)
- eventTypes[t].size =
- sizeof(EventCapsetID) + 2*sizeof(StgWord32);
- break;
-
case EVENT_SHUTDOWN: // (cap)
case EVENT_REQUEST_SEQ_GC: // (cap)
case EVENT_REQUEST_PAR_GC: // (cap)
case EVENT_LOG_MSG: // (msg)
case EVENT_USER_MSG: // (msg)
- case EVENT_RTS_IDENTIFIER: // (capset, str)
- case EVENT_PROGRAM_ARGS: // (capset, strvec)
- case EVENT_PROGRAM_ENV: // (capset, strvec)
eventTypes[t].size = 0xffff;
break;
}
}
-void postCapsetModifyEvent (EventTypeNum tag,
- EventCapsetID capset,
- StgWord32 other,
- StgWord32 other2)
-{
- ACQUIRE_LOCK(&eventBufMutex);
-
- if (!hasRoomForEvent(&eventBuf, tag)) {
- // Flush event buffer to make room for new event.
- printAndClearEventBuf(&eventBuf);
- }
-
- postEventHeader(&eventBuf, tag);
- postCapsetID(&eventBuf, capset);
-
- switch (tag) {
- case EVENT_CAPSET_CREATE: // (capset, capset_type)
- {
- postCapsetType(&eventBuf, other /* capset_type */);
- break;
- }
-
- case EVENT_CAPSET_DELETE: // (capset)
- {
- break;
- }
-
- case EVENT_CAPSET_ASSIGN_CAP: // (capset, capno)
- case EVENT_CAPSET_REMOVE_CAP: // (capset, capno)
- {
- postCapNo(&eventBuf, other /* capno */);
- break;
- }
- case EVENT_OSPROCESS_PID:
- {
- postWord32(&eventBuf, other);
- postWord32(&eventBuf, other2);
- break;
- }
- default:
- barf("postCapsetModifyEvent: unknown event tag %d", tag);
- }
-
- RELEASE_LOCK(&eventBufMutex);
-}
-
-void postCapsetStrEvent (EventTypeNum tag,
- EventCapsetID capset,
- char *msg)
-{
- int strsize = strlen(msg);
- int size = strsize + sizeof(EventCapsetID)
-
- ACQUIRE_LOCK(&eventBufMutex);
-
- if (!hasRoomForVariableEvent(&eventBuf, size)){
- printAndClearEventBuf(&eventBuf);
-
- if (!hasRoomForVariableEvent(&eventBuf, size)){
- // Event size exceeds buffer size, bail out:
- RELEASE_LOCK(&eventBufMutex);
- return;
- }
- }
-
- postEventHeader(&eventBuf, tag);
- postPayloadSize(&eventBuf, size);
- postCapsetID(&eventBuf, capset);
-
- postBuf(&eventBuf, (StgWord8*) msg, strsize);
-
- RELEASE_LOCK(&eventBufMutex);
-}
-
-void postCapsetVecEvent (EventTypeNum tag,
- EventCapsetID capset,
- int argc,
- char *argv[])
-{
- int i, size = sizeof(EventCapsetID);
-
- for (i = 0; i < argc; i++) {
- // 1 + strlen to account for the trailing \0, used as separator
- size += 1 + strlen(argv[i]);
- }
-
- ACQUIRE_LOCK(&eventBufMutex);
-
- if (!hasRoomForVariableEvent(&eventBuf, size)){
- printAndClearEventBuf(&eventBuf);
-
- if(!hasRoomForVariableEvent(&eventBuf, size)){
- // Event size exceeds buffer size, bail out:
- RELEASE_LOCK(&eventBufMutex);
- return;
- }
- }
-
- postEventHeader(&eventBuf, tag);
- postPayloadSize(&eventBuf, size);
- postCapsetID(&eventBuf, capset);
-
- for( i = 0; i < argc; i++ ) {
- // again, 1 + to account for \0
- postBuf(&eventBuf, (StgWord8*) argv[i], 1 + strlen(argv[i]));
- }
-
- RELEASE_LOCK(&eventBufMutex);
-}
-
void
postEvent (Capability *cap, EventTypeNum tag)
{
StgThreadID id, StgWord info1, StgWord info2);
/*
- * Post a capability set modification event
- */
-void postCapsetModifyEvent (EventTypeNum tag,
- EventCapsetID capset,
- StgWord32 other,
- StgWord32 other2);
-
-/*
- * Post a capability set event with a string payload
- */
-void postCapsetStrEvent (EventTypeNum tag,
- EventCapsetID capset,
- char *msg);
-
-/*
- * Post a capability set event with several strings payload
- */
-void postCapsetVecEvent (EventTypeNum tag,
- EventCapsetID capset,
- int argc,
- char *msg[]);
-
-/*
* Post a nullary event.
*/
void postEvent(Capability *cap, EventTypeNum tag);
StgWord info2 STG_UNUSED)
{ /* nothing */ }
-INLINE_HEADER void postCapsetModifyEvent (EventTypeNum tag STG_UNUSED,
- EventCapsetID capset STG_UNUSED,
- StgWord32 other STG_UNUSED,
- StgWord32 other2 STG_UNUSED)
-{ /* nothing */ }
-
INLINE_HEADER void postEvent (Capability *cap STG_UNUSED,
EventTypeNum tag STG_UNUSED)
{ /* nothing */ }
rts/RtsMessages_CC_OPTS += -DProjectVersion=\"$(ProjectVersion)\"
rts/RtsUtils_CC_OPTS += -DProjectVersion=\"$(ProjectVersion)\"
-rts/Trace_CC_OPTS += -DProjectVersion=\"$(ProjectVersion)\"
#
rts/RtsUtils_CC_OPTS += -DHostPlatform=\"$(HOSTPLATFORM)\"
rts/RtsUtils_CC_OPTS += -DHostArch=\"$(HostArch_CPP)\"
// NO MORE EVACUATION AFTER THIS POINT!
- // Two-space collector: free the old to-space.
- // g0->old_blocks is the old nursery
- // g0->blocks is to-space from the previous GC
- if (RtsFlags.GcFlags.generations == 1) {
- if (g0->blocks != NULL) {
- freeChain(g0->blocks);
- g0->blocks = NULL;
- }
- }
-
// Finally: compact or sweep the oldest generation.
if (major_gc && oldest_gen->mark) {
if (oldest_gen->compact)
// for a compacted generation, we need to allocate the bitmap
if (gen->mark) {
- nat bitmap_size; // in bytes
+ lnat bitmap_size; // in bytes
bdescr *bitmap_bdescr;
StgWord *bitmap;
--- /dev/null
+#! /usr/bin/env python
+# Script to create and restore a git fingerprint of the ghc repositories.
+
+from datetime import datetime
+from optparse import OptionParser
+import os
+import os.path
+import re
+import subprocess
+from subprocess import PIPE, Popen
+import sys
+
+def main():
+ opts, args = parseopts(sys.argv[1:])
+ opts.action(opts)
+
+def create_action(opts):
+ """Action called for the create commmand"""
+ if opts.fpfile:
+ fp = FingerPrint.read(opts.source)
+ else:
+ fp = fingerprint(opts.source)
+ if len(fp) == 0:
+ error("Got empty fingerprint from source: "+str(opts.source))
+ if opts.output_file:
+ print "Writing fingerprint to: ", opts.output_file
+ fp.write(opts.output)
+
+def restore_action(opts):
+ """Action called for the restore commmand"""
+ def branch_name(filename):
+ return "fingerprint_" + os.path.basename(filename).replace(".", "_")
+ if opts.fpfile:
+ try:
+ fp = FingerPrint.read(opts.source)
+ bn = branch_name(opts.fpfile)
+ except MalformedFingerPrintError:
+ error("Error parsing fingerprint file: "+opts.fpfile)
+ if len(fp) == 0:
+ error("No fingerprint found in fingerprint file: "+opts.fpfile)
+ elif opts.logfile:
+ fp = fingerprint(opts.source)
+ bn = branch_name(opts.logfile)
+ if len(fp) == 0:
+ error("No fingerprint found in build log file: "+opts.logfile)
+ else:
+ error("Must restore from fingerprint or log file")
+ restore(fp, branch_name=bn if opts.branch else None)
+
+def fingerprint(source=None):
+ """Create a new fingerprint of current repositories.
+
+ The source argument is parsed to look for the expected output
+ from a `sync-all` command. If the source is `None` then the
+ `sync-all` command will be run to get the current fingerprint.
+ """
+ if source is None:
+ sync_all = ["./sync-all", "log", "HEAD^..", "--pretty=oneline"]
+ source = Popen(sync_all, stdout=PIPE).stdout
+
+ lib = ""
+ commits = {}
+ for line in source.readlines():
+ if line.startswith("=="):
+ lib = line.split()[1].rstrip(":")
+ lib = "." if lib == "running" else lib # hack for top ghc repo
+ elif re.match("[abcdef0-9]{40}", line):
+ commit = line[:40]
+ commits[lib] = commit
+ return FingerPrint(commits)
+
+def restore(fp, branch_name=None):
+ """Restore the ghc repos to the commits in the fingerprint
+
+ This function performs a checkout of each commit specifed in
+ the fingerprint. If `branch_name` is not None then a new branch
+ will be created for the top ghc repository. We also add an entry
+ to the git config that sets the remote for the new branch as `origin`
+ so that the `sync-all` command can be used from the branch.
+ """
+ checkout = ["git", "checkout"]
+
+ # run checkout in all subdirs
+ for (subdir, commit) in fp:
+ if subdir != ".":
+ cmd = checkout + [commit]
+ print "==", subdir, " ".join(cmd)
+ if os.path.exists(subdir):
+ rc = subprocess.call(cmd, cwd=subdir)
+ if rc != 0:
+ error("Too many errors, aborting")
+ else:
+ sys.stderr.write("WARNING: "+
+ subdir+" is in fingerprint but missing in working directory\n")
+
+ # special handling for top ghc repo
+ # if we are creating a new branch then also add an entry to the
+ # git config so the sync-all command is happy
+ branch_args = ["-b", branch_name] if branch_name else []
+ rc = subprocess.call(checkout + branch_args + [fp["."]])
+ if (rc == 0) and branch_name:
+ branch_config = "branch."+branch_name+".remote"
+ subprocess.call(["git", "config", "--add", branch_config, "origin"])
+
+actions = {"create" : create_action, "restore" : restore_action}
+def parseopts(argv):
+ """Parse and check the validity of the command line arguments"""
+ usage = "fingerprint ("+"|".join(sorted(actions.keys()))+") [options]"
+ parser = OptionParser(usage=usage)
+
+ parser.add_option("-d", "--dir", dest="dir",
+ help="write output to directory DIR", metavar="DIR")
+
+ parser.add_option("-o", "--output", dest="output",
+ help="write output to file FILE", metavar="FILE")
+
+ parser.add_option("-l", "--from-log", dest="logfile",
+ help="reconstruct fingerprint from build log", metavar="FILE")
+
+ parser.add_option("-f", "--from-fp", dest="fpfile",
+ help="reconstruct fingerprint from fingerprint file", metavar="FILE")
+
+ parser.add_option("-n", "--no-branch",
+ action="store_false", dest="branch", default=True,
+ help="do not create a new branch when restoring fingerprint")
+
+ parser.add_option("-g", "--ghc-dir", dest="ghcdir",
+ help="perform actions in GHC dir", metavar="DIR")
+
+ opts,args = parser.parse_args(argv)
+ return (validate(opts, args, parser), args)
+
+def validate(opts, args, parser):
+ """ Validate and prepare the command line options.
+
+ It performs the following actions:
+ * Check that we have a valid action to perform
+ * Check that we have a valid output destination
+ * Opens the output file if needed
+ * Opens the input file if needed
+ """
+ # Determine the action
+ try:
+ opts.action = actions[args[0]]
+ except (IndexError, KeyError):
+ error("Must specify a valid action", parser)
+
+ # Inputs
+ if opts.logfile and opts.fpfile:
+ error("Must specify only one of -l and -f")
+
+ opts.source = None
+ if opts.logfile:
+ opts.source = file(opts.logfile, "r")
+ elif opts.fpfile:
+ opts.source = file(opts.fpfile, "r")
+
+ # Outputs
+ if opts.dir:
+ fname = opts.output
+ if fname is None:
+ fname = datetime.today().strftime("%Y-%m%-%d_%H-%M-%S") + ".fp"
+ path = os.path.join(opts.dir, fname)
+ opts.output_file = path
+ opts.output = file(path, "w")
+ elif opts.output:
+ opts.output_file = opts.output
+ opts.output = file(opts.output_file, "w")
+ else:
+ opts.output_file = None
+ opts.output = sys.stdout
+
+ # GHC Directory
+ # As a last step change the directory to the GHC directory specified
+ if opts.ghcdir:
+ os.chdir(opts.ghcdir)
+
+ return opts
+
+def error(msg="fatal error", parser=None, exit=1):
+ """Function that prints error message and exits"""
+ print "ERROR:", msg
+ if parser:
+ parser.print_help()
+ sys.exit(exit)
+
+class MalformedFingerPrintError(Exception):
+ """Exception raised when parsing a bad fingerprint file"""
+ pass
+
+class FingerPrint:
+ """Class representing a fingerprint of all ghc git repos.
+
+ A finger print is represented by a dictionary that maps a
+ directory to a commit. The directory "." is used for the top
+ level ghc repository.
+ """
+ def __init__(self, subcommits = {}):
+ self.commits = subcommits
+
+ def __eq__(self, other):
+ if other.__class__ != self.__class__:
+ raise TypeError
+ return self.commits == other.commits
+
+ def __neq__(self, other):
+ not(self == other)
+
+ def __hash__(self):
+ return hash(str(self))
+
+ def __len__(self):
+ return len(self.commits)
+
+ def __repr__(self):
+ return "FingerPrint(" + repr(self.commits) + ")"
+
+ def __str__(self):
+ s = ""
+ for lib in sorted(self.commits.keys()):
+ commit = self.commits[lib]
+ s += "{0}|{1}\n".format(lib, commit)
+ return s
+
+ def __getitem__(self, item):
+ return self.commits[item]
+
+ def __iter__(self):
+ return self.commits.iteritems()
+
+ def write(self, outh):
+ outh.write(str(self))
+ outh.flush()
+
+ @staticmethod
+ def read(inh):
+ """Read a fingerprint from a fingerprint file"""
+ commits = {}
+ for line in inh.readlines():
+ splits = line.strip().split("|", 1)
+ if len(splits) != 2:
+ raise MalformedFingerPrintError(line)
+ lib, commit = splits
+ commits[lib] = commit
+ return FingerPrint(commits)
+
+if __name__ == "__main__":
+ main()
<0> "thats_all_folks" { mkT TThatsAllFolks }
<0> [a-z][a-zA-Z0-9\#_]* { mkTv TLowerName }
<0> [A-Z][a-zA-Z0-9\#_]* { mkTv TUpperName }
+ <0> [0-9][0-9]* { mkTv (TInteger . read) }
<0> \" [^\"]* \" { mkTv (TString . tail . init) }
<in_braces> [^\{\}]+ { mkTv TNoBraces }
<in_braces> \n { mkTv TNoBraces }
"commutable"
"commutableOp" p_o_specs)
- "--needs-wrapper"
+ "--code-size"
-> putStr (gen_switch_from_attribs
- "needs_wrapper"
- "primOpNeedsWrapper" p_o_specs)
+ "code_size"
+ "primOpCodeSize" p_o_specs)
- "--can-fail"
- -> putStr (gen_switch_from_attribs
+ "--can-fail"
+ -> putStr (gen_switch_from_attribs
"can_fail"
"primOpCanFail" p_o_specs)
"--has-side-effects",
"--out-of-line",
"--commutable",
- "--needs-wrapper",
+ "--code-size",
"--can-fail",
"--strictness",
"--primop-primop-info",
where opt (OptionFalse n) = n ++ " = False"
opt (OptionTrue n) = n ++ " = True"
opt (OptionString n v) = n ++ " = { " ++ v ++ "}"
+ opt (OptionInteger n v) = n ++ " = " ++ show v
hdr s@(Section {}) = sec s
hdr (PrimOpSpec { name = n }) = wrapOp n ++ ","
Just (OptionTrue _) -> if_true
Just (OptionFalse _) -> if_false
Just (OptionString _ _) -> error "String value for boolean option"
- Nothing -> ""
+ Just (OptionInteger _ _) -> error "Integer value for boolean option"
+ Nothing -> ""
mk_strictness o =
case lookup_attrib "strictness" o of
getAltRhs (OptionFalse _) = "False"
getAltRhs (OptionTrue _) = "True"
+ getAltRhs (OptionInteger _ i) = show i
getAltRhs (OptionString _ s) = s
mkAlt po
lowerName { TLowerName $$ }
upperName { TUpperName $$ }
string { TString $$ }
+ integer { TInteger $$ }
noBraces { TNoBraces $$ }
%%
pOption : lowerName '=' false { OptionFalse $1 }
| lowerName '=' true { OptionTrue $1 }
| lowerName '=' pStuffBetweenBraces { OptionString $1 $3 }
+ | lowerName '=' integer { OptionInteger $1 $3 }
pEntries :: { [Entry] }
pEntries : pEntry pEntries { $1 : $2 }
| TUpperName String
| TString String
| TNoBraces String
+ | TInteger Int
deriving Show
-- Actions
= OptionFalse String -- name = False
| OptionTrue String -- name = True
| OptionString String String -- name = { ... unparsed stuff ... }
+ | OptionInteger String Int -- name = <int>
deriving Show
-- categorises primops
get_attrib_name (OptionFalse nm) = nm
get_attrib_name (OptionTrue nm) = nm
get_attrib_name (OptionString nm _) = nm
+get_attrib_name (OptionInteger nm _) = nm
lookup_attrib :: String -> [Option] -> Maybe Option
lookup_attrib _ [] = Nothing
pd lib lbi clbi
final_ipi = installedPkgInfo {
Installed.installedPackageId = ipid,
- Installed.haddockHTMLs = ["../" ++ display (packageId pd)]
+ Installed.haddockHTMLs = []
}
content = Installed.showInstalledPackageInfo final_ipi ++ "\n"
writeFileAtomic (distdir </> "inplace-pkg-config") (toUTF8 content)
import Distribution.Package hiding (depends)
import Distribution.Text
import Distribution.Version
-import System.FilePath
+import System.FilePath as FilePath
+import qualified System.FilePath.Posix as FilePath.Posix
import System.Cmd ( rawSystem )
import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing,
getModificationTime )
import Data.Char ( isSpace, toLower )
import Control.Monad
import System.Directory ( doesDirectoryExist, getDirectoryContents,
- doesFileExist, renameFile, removeFile )
+ doesFileExist, renameFile, removeFile,
+ getCurrentDirectory )
import System.Exit ( exitWith, ExitCode(..) )
import System.Environment ( getArgs, getProgName, getEnv )
import System.IO
| FlagForce
| FlagForceFiles
| FlagAutoGHCiLibs
+ | FlagExpandEnvVars
+ | FlagExpandPkgroot
+ | FlagNoExpandPkgroot
| FlagSimpleOutput
| FlagNamesOnly
| FlagIgnoreCase
"ignore missing directories and libraries only",
Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
"automatically build libs for GHCi (with register)",
+ Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars)
+ "expand environment variables (${name}-style) in input package descriptions",
+ Option [] ["expand-pkgroot"] (NoArg FlagExpandPkgroot)
+ "expand ${pkgroot}-relative paths to absolute in output package descriptions",
+ Option [] ["no-expand-pkgroot"] (NoArg FlagNoExpandPkgroot)
+ "preserve ${pkgroot}-relative paths in output package descriptions",
Option ['?'] ["help"] (NoArg FlagHelp)
"display this help and exit",
Option ['V'] ["version"] (NoArg FlagVersion)
| FlagForceFiles `elem` cli = ForceFiles
| otherwise = NoForce
auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
+ expand_env_vars= FlagExpandEnvVars `elem` cli
+ mexpand_pkgroot= foldl' accumExpandPkgroot Nothing cli
+ where accumExpandPkgroot _ FlagExpandPkgroot = Just True
+ accumExpandPkgroot _ FlagNoExpandPkgroot = Just False
+ accumExpandPkgroot x _ = x
+
splitFields fields = unfoldr splitComma (',':fields)
where splitComma "" = Nothing
splitComma fs = Just $ break (==',') (tail fs)
["init", filename] ->
initPackageDB filename verbosity cli
["register", filename] ->
- registerPackage filename verbosity cli auto_ghci_libs False force
+ registerPackage filename verbosity cli
+ auto_ghci_libs expand_env_vars False force
["update", filename] ->
- registerPackage filename verbosity cli auto_ghci_libs True force
+ registerPackage filename verbosity cli
+ auto_ghci_libs expand_env_vars True force
["unregister", pkgid_str] -> do
pkgid <- readGlobPkgId pkgid_str
unregisterPackage pkgid verbosity cli force
["latest", pkgid_str] -> do
pkgid <- readGlobPkgId pkgid_str
latestPackage verbosity cli pkgid
- ["describe", pkgid_str] ->
- case substringCheck pkgid_str of
- Nothing -> do pkgid <- readGlobPkgId pkgid_str
- describePackage verbosity cli (Id pkgid)
- Just m -> describePackage verbosity cli (Substring pkgid_str m)
- ["field", pkgid_str, fields] ->
- case substringCheck pkgid_str of
- Nothing -> do pkgid <- readGlobPkgId pkgid_str
- describeField verbosity cli (Id pkgid)
- (splitFields fields)
- Just m -> describeField verbosity cli (Substring pkgid_str m)
- (splitFields fields)
+ ["describe", pkgid_str] -> do
+ pkgarg <- case substringCheck pkgid_str of
+ Nothing -> liftM Id (readGlobPkgId pkgid_str)
+ Just m -> return (Substring pkgid_str m)
+ describePackage verbosity cli pkgarg (fromMaybe False mexpand_pkgroot)
+
+ ["field", pkgid_str, fields] -> do
+ pkgarg <- case substringCheck pkgid_str of
+ Nothing -> liftM Id (readGlobPkgId pkgid_str)
+ Just m -> return (Substring pkgid_str m)
+ describeField verbosity cli pkgarg
+ (splitFields fields) (fromMaybe True mexpand_pkgroot)
+
["check"] -> do
checkConsistency verbosity cli
["dump"] -> do
- dumpPackages verbosity cli
+ dumpPackages verbosity cli (fromMaybe False mexpand_pkgroot)
["recache"] -> do
recache verbosity cli
-- list, describe, field
data PackageDB
- = PackageDB { location :: FilePath,
- packages :: [InstalledPackageInfo] }
+ = PackageDB {
+ location, locationAbsolute :: !FilePath,
+ -- We need both possibly-relative and definately-absolute package
+ -- db locations. This is because the relative location is used as
+ -- an identifier for the db, so it is important we do not modify it.
+ -- On the other hand we need the absolute path in a few places
+ -- particularly in relation to the ${pkgroot} stuff.
+
+ packages :: [InstalledPackageInfo]
+ }
type PackageDBStack = [PackageDB]
-- A stack of package databases. Convention: head is the topmost
getPkgDatabases :: Verbosity
-> Bool -- we are modifying, not reading
-> Bool -- read caches, if available
+ -> Bool -- expand vars, like ${pkgroot} and $topdir
-> [Flag]
-> IO (PackageDBStack,
-- the real package DB stack: [global,user] ++
-- is used as the list of package DBs for
-- commands that just read the DB, such as 'list'.
-getPkgDatabases verbosity modify use_cache my_flags = do
+getPkgDatabases verbosity modify use_cache expand_vars my_flags = do
-- first we determine the location of the global package config. On Windows,
-- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
-- location is passed to the binary using the --global-config flag by the
Just path -> return path
fs -> return (last fs)
+ -- The value of the $topdir variable used in some package descriptions
+ -- Note that the way we calculate this is slightly different to how it
+ -- is done in ghc itself. We rely on the convention that the global
+ -- package db lives in ghc's libdir.
+ top_dir <- absolutePath (takeDirectory global_conf)
+
let no_user_db = FlagNoUserDb `elem` my_flags
-- get the location of the user package database, and create it if necessary
| null db_flags = Just virt_global_conf
| otherwise = Just (last db_flags)
- db_stack <- mapM (readParseDatabase verbosity mb_user_conf use_cache) final_stack
+ db_stack <- sequence
+ [ do db <- readParseDatabase verbosity mb_user_conf use_cache db_path
+ if expand_vars then return (mungePackageDBPaths top_dir db)
+ else return db
+ | db_path <- final_stack ]
let flag_db_stack = [ db | db_name <- flag_db_names,
db <- db_stack, location db == db_name ]
readParseDatabase verbosity mb_user_conf use_cache path
-- the user database (only) is allowed to be non-existent
| Just (user_conf,False) <- mb_user_conf, path == user_conf
- = return PackageDB { location = path, packages = [] }
+ = mkPackageDB []
| otherwise
= do e <- tryIO $ getDirectoryContents path
case e of
Left _ -> do
pkgs <- parseMultiPackageConf verbosity path
- return PackageDB{ location = path, packages = pkgs }
+ mkPackageDB pkgs
Right fs
| not use_cache -> ignore_cache
| otherwise -> do
putStrLn ("using cache: " ++ cache)
pkgs <- myReadBinPackageDB cache
let pkgs' = map convertPackageInfoIn pkgs
- return PackageDB { location = path, packages = pkgs' }
+ mkPackageDB pkgs'
| otherwise -> do
when (verbosity >= Normal) $ do
warn ("WARNING: cache is out of date: " ++ cache)
let confs = filter (".conf" `isSuffixOf`) fs
pkgs <- mapM (parseSingletonPackageConf verbosity) $
map (path </>) confs
- return PackageDB { location = path, packages = pkgs }
+ mkPackageDB pkgs
+ where
+ mkPackageDB pkgs = do
+ path_abs <- absolutePath path
+ return PackageDB {
+ location = path,
+ locationAbsolute = path_abs,
+ packages = pkgs
+ }
-- read the package.cache file strictly, to work around a problem with
-- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed
parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
parseSingletonPackageConf verbosity file = do
when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file)
- readUTF8File file >>= parsePackageInfo
+ readUTF8File file >>= fmap fst . parsePackageInfo
cachefilename :: FilePath
cachefilename = "package.cache"
+mungePackageDBPaths :: FilePath -> PackageDB -> PackageDB
+mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } =
+ db { packages = map (mungePackagePaths top_dir pkgroot) pkgs }
+ where
+ pkgroot = takeDirectory (locationAbsolute db)
+ -- It so happens that for both styles of package db ("package.conf"
+ -- files and "package.conf.d" dirs) the pkgroot is the parent directory
+ -- ${pkgroot}/package.conf or ${pkgroot}/package.conf.d/
+
+mungePackagePaths :: FilePath -> FilePath
+ -> InstalledPackageInfo -> InstalledPackageInfo
+-- 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
+
+
-- -----------------------------------------------------------------------------
-- Creating a new package DB
when b1 eexist
b2 <- doesDirectoryExist filename
when b2 eexist
- changeDB verbosity [] PackageDB{ location = filename, packages = [] }
+ filename_abs <- absolutePath filename
+ changeDB verbosity [] PackageDB {
+ location = filename, locationAbsolute = filename_abs,
+ packages = []
+ }
-- -----------------------------------------------------------------------------
-- Registering
-> Verbosity
-> [Flag]
-> Bool -- auto_ghci_libs
+ -> Bool -- expand_env_vars
-> Bool -- update
-> Force
-> IO ()
-registerPackage input verbosity my_flags auto_ghci_libs update force = do
+registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update force = do
(db_stack, Just to_modify, _flag_dbs) <-
- getPkgDatabases verbosity True True my_flags
+ getPkgDatabases verbosity True True False{-expand vars-} my_flags
let
db_to_operate_on = my_head "register" $
filter ((== to_modify).location) db_stack
--
+ when (auto_ghci_libs && verbosity >= Silent) $
+ warn "Warning: --auto-ghci-libs is deprecated and will be removed in GHC 7.4"
+ --
s <-
case input of
"-" -> do
putStr ("Reading package info from " ++ show f ++ " ... ")
readUTF8File f
- expanded <- expandEnvVars s force
+ expanded <- if expand_env_vars then expandEnvVars s force
+ else return s
- pkg <- parsePackageInfo expanded
+ (pkg, ws) <- parsePackageInfo expanded
when (verbosity >= Normal) $
putStrLn "done."
+ -- report any warnings from the parse phase
+ _ <- reportValidateErrors [] ws
+ (display (sourcePackageId pkg) ++ ": Warning: ") Nothing
+
+ -- validate the expanded pkg, but register the unexpanded
+ pkgroot <- absolutePath (takeDirectory to_modify)
+ let top_dir = takeDirectory (location (last db_stack))
+ pkg_expanded = mungePackagePaths top_dir pkgroot pkg
+
let truncated_stack = dropWhile ((/= to_modify).location) db_stack
-- truncate the stack for validation, because we don't allow
-- packages lower in the stack to refer to those higher up.
- validatePackageConfig pkg truncated_stack auto_ghci_libs update force
+ validatePackageConfig pkg_expanded truncated_stack auto_ghci_libs update force
let
removes = [ RemovePackage p
| p <- packages db_to_operate_on,
parsePackageInfo
:: String
- -> IO InstalledPackageInfo
+ -> IO (InstalledPackageInfo, [ValidateWarning])
parsePackageInfo str =
case parseInstalledPackageInfo str of
- ParseOk _warns ok -> return ok
+ ParseOk warnings ok -> return (ok, ws)
+ where
+ ws = [ msg | PWarning msg <- warnings
+ , not ("Unrecognized field pkgroot" `isPrefixOf` msg) ]
ParseFailed err -> case locatedErrorMsg err of
(Nothing, s) -> die s
(Just l, s) -> die (show l ++ ": " ++ s)
-> IO ()
modifyPackage fn pkgid verbosity my_flags force = do
(db_stack, Just _to_modify, _flag_dbs) <-
- getPkgDatabases verbosity True{-modify-} True{-use cache-} my_flags
+ getPkgDatabases verbosity True{-modify-} True{-use cache-} False{-expand vars-} my_flags
(db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
let
recache :: Verbosity -> [Flag] -> IO ()
recache verbosity my_flags = do
(db_stack, Just to_modify, _flag_dbs) <-
- getPkgDatabases verbosity True{-modify-} False{-no cache-} my_flags
+ getPkgDatabases verbosity True{-modify-} False{-no cache-} False{-expand vars-} my_flags
let
db_to_operate_on = my_head "recache" $
filter ((== to_modify).location) db_stack
listPackages verbosity my_flags mPackageName mModuleName = do
let simple_output = FlagSimpleOutput `elem` my_flags
(db_stack, _, flag_db_stack) <-
- getPkgDatabases verbosity False True{-use cache-} my_flags
+ getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
let db_stack_filtered -- if a package is given, filter out all other packages
| Just this <- mPackageName =
showPackageDot :: Verbosity -> [Flag] -> IO ()
showPackageDot verbosity myflags = do
(_, _, flag_db_stack) <-
- getPkgDatabases verbosity False True{-use cache-} myflags
+ getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} myflags
let all_pkgs = allPackagesInStack flag_db_stack
ipix = PackageIndex.fromList all_pkgs
latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO ()
latestPackage verbosity my_flags pkgid = do
(_, _, flag_db_stack) <-
- getPkgDatabases verbosity False True{-use cache-} my_flags
+ getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
ps <- findPackages flag_db_stack (Id pkgid)
show_pkg (sortBy compPkgIdVer (map sourcePackageId ps))
-- -----------------------------------------------------------------------------
-- Describe
-describePackage :: Verbosity -> [Flag] -> PackageArg -> IO ()
-describePackage verbosity my_flags pkgarg = do
+describePackage :: Verbosity -> [Flag] -> PackageArg -> Bool -> IO ()
+describePackage verbosity my_flags pkgarg expand_pkgroot = do
(_, _, flag_db_stack) <-
- getPkgDatabases verbosity False True{-use cache-} my_flags
- ps <- findPackages flag_db_stack pkgarg
- doDump ps
+ getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
+ dbs <- findPackagesByDB flag_db_stack pkgarg
+ doDump expand_pkgroot [ (pkg, locationAbsolute db)
+ | (db, pkgs) <- dbs, pkg <- pkgs ]
-dumpPackages :: Verbosity -> [Flag] -> IO ()
-dumpPackages verbosity my_flags = do
+dumpPackages :: Verbosity -> [Flag] -> Bool -> IO ()
+dumpPackages verbosity my_flags expand_pkgroot = do
(_, _, flag_db_stack) <-
- getPkgDatabases verbosity False True{-use cache-} my_flags
- doDump (allPackagesInStack flag_db_stack)
+ getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
+ doDump expand_pkgroot [ (pkg, locationAbsolute db)
+ | db <- flag_db_stack, pkg <- packages db ]
-doDump :: [InstalledPackageInfo] -> IO ()
-doDump pkgs = do
+doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO ()
+doDump expand_pkgroot pkgs = do
-- fix the encoding to UTF-8, since this is an interchange format
hSetEncoding stdout utf8
- mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo $ pkgs
+ putStrLn $
+ intercalate "---\n"
+ [ if expand_pkgroot
+ then showInstalledPackageInfo pkg
+ else showInstalledPackageInfo pkg ++ pkgrootField
+ | (pkg, pkgloc) <- pkgs
+ , let pkgroot = takeDirectory pkgloc
+ pkgrootField = "pkgroot: " ++ pkgroot ++ "\n" ]
-- PackageId is can have globVersion for the version
findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
-- -----------------------------------------------------------------------------
-- Field
-describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> IO ()
-describeField verbosity my_flags pkgarg fields = do
+describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> Bool -> IO ()
+describeField verbosity my_flags pkgarg fields expand_pkgroot = do
(_, _, flag_db_stack) <-
- getPkgDatabases verbosity False True{-use cache-} my_flags
+ getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
fns <- toFields fields
ps <- findPackages flag_db_stack pkgarg
- let top_dir = takeDirectory (location (last flag_db_stack))
- mapM_ (selectFields fns) (mungePackagePaths top_dir ps)
+ mapM_ (selectFields fns) ps
where toFields [] = return []
toFields (f:fs) = case toField f of
Nothing -> die ("unknown field: " ++ f)
return (fn:fns)
selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
-mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
--- Replace the strings "$topdir" and "$httptopdir" 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' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
- | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
- | otherwise = p
-
- toHttpPath p = "file:///" ++ p
-
-maybePrefixMatch :: String -> String -> Maybe String
-maybePrefixMatch [] rest = Just rest
-maybePrefixMatch (_:_) [] = Nothing
-maybePrefixMatch (p:pat) (r:rest)
- | p == r = maybePrefixMatch pat rest
- | otherwise = Nothing
-
toField :: String -> Maybe (InstalledPackageInfo -> String)
-- backwards compatibility:
toField "import_dirs" = Just $ strList . importDirs
checkConsistency :: Verbosity -> [Flag] -> IO ()
checkConsistency verbosity my_flags = do
- (db_stack, _, _) <- getPkgDatabases verbosity True True{-use cache-} my_flags
+ (db_stack, _, _) <-
+ getPkgDatabases verbosity True True{-use cache-} True{-expand vars-} my_flags
-- check behaves like modify for the purposes of deciding which
-- databases to use, because ordering is important.
mapM_ (checkDir False "import-dirs") (importDirs pkg)
mapM_ (checkDir True "library-dirs") (libraryDirs pkg)
mapM_ (checkDir True "include-dirs") (includeDirs pkg)
+ mapM_ (checkDir True "framework-dirs") (frameworkDirs pkg)
+ mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg)
+ mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg)
checkModules pkg
mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
-- ToDo: check these somehow?
"Package " ++ display pkgid ++
" overlaps with: " ++ unwords (map display dups)
+checkDir, checkFile, checkDirURL :: Bool -> String -> FilePath -> Validate ()
+checkDir = checkPath False True
+checkFile = checkPath False False
+checkDirURL = checkPath True True
+
+checkPath :: Bool -> Bool -> Bool -> String -> FilePath -> Validate ()
+checkPath url_ok is_dir warn_only thisfield d
+ | url_ok && ("http://" `isPrefixOf` d
+ || "https://" `isPrefixOf` d) = return ()
+
+ | url_ok
+ , Just d' <- stripPrefix "file://" d
+ = checkPath False is_dir warn_only thisfield d'
+
+ -- Note: we don't check for $topdir/${pkgroot} here. We rely on these
+ -- variables having been expanded already, see mungePackagePaths.
-checkDir :: Bool -> String -> String -> Validate ()
-checkDir warn_only thisfield d
- | "$topdir" `isPrefixOf` d = return ()
- | "$httptopdir" `isPrefixOf` d = return ()
- -- can't check these, because we don't know what $(http)topdir is
| isRelative d = verror ForceFiles $
- thisfield ++ ": " ++ d ++ " is a relative path"
+ thisfield ++ ": " ++ d ++ " is a relative path which "
+ ++ "makes no sense (as there is nothing for it to be "
+ ++ "relative to). You can make paths relative to the "
+ ++ "package database itself by using ${pkgroot}."
-- relative paths don't make any sense; #4134
| otherwise = do
- there <- liftIO $ doesDirectoryExist d
+ there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d
when (not there) $
- let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory"
+ let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a "
+ ++ if is_dir then "directory" else "file"
in
if warn_only
then vwarn msg
if b then return (Just p) else go ps
doesFileExistIn :: String -> String -> IO Bool
-doesFileExistIn lib d
- | "$topdir" `isPrefixOf` d = return True
- | "$httptopdir" `isPrefixOf` d = return True
- | otherwise = doesFileExist (d </> lib)
+doesFileExistIn lib d = doesFileExist (d </> lib)
checkModules :: InstalledPackageInfo -> Validate ()
checkModules pkg = do
= go str (c:acc)
lookupEnvVar :: String -> IO String
+ lookupEnvVar "pkgroot" = return "${pkgroot}" -- these two are special,
+ lookupEnvVar "pkgrooturl" = return "${pkgrooturl}" -- we don't expand them
lookupEnvVar nm =
catchIO (System.Environment.getEnv nm)
(\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
removeFileSafe fn =
removeFile fn `catchIO` \ e ->
when (not $ isDoesNotExistError e) $ ioError e
+
+absolutePath :: FilePath -> IO FilePath
+absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory
$make binary-dist-prep
$make test_bindist TEST_PREP=YES
+#
+# Install the mtl package into the bindist, because it is used by some
+# tests. It isn't essential that we do this (the failing tests will
+# be treated as expected failures), but we get a bit more test
+# coverage, and also verify that we can install a package into the
+# bindist with Cabal.
+#
+bindistdir="bindisttest/install dir"
+cd libraries/mtl
+"$thisdir/$bindistdir/bin/runhaskell" Setup.hs configure --with-ghc="$thisdir/$bindistdir/bin/ghc" --global --builddir=dist-bindist --prefix="$thisdir/$bindistdir"
+"$thisdir/$bindistdir/bin/runhaskell" Setup.hs build --builddir=dist-bindist
+"$thisdir/$bindistdir/bin/runhaskell" Setup.hs install --builddir=dist-bindist
+"$thisdir/$bindistdir/bin/runhaskell" Setup.hs clean --builddir=dist-bindist
+cd $thisdir
+
fi # testsuite-only
if [ "$hpc" = YES ]
projects / ghc-hetmet.git / commitdiff