summaryrefslogtreecommitdiff
path: root/utils
diff options
context:
space:
mode:
Diffstat (limited to 'utils')
-rw-r--r--utils/checkUniques/Makefile2
-rw-r--r--utils/checkUniques/checkUniques.hs2
-rw-r--r--utils/compare_sizes/Main.hs2
-rw-r--r--utils/compare_sizes/compareSizes.cabal4
-rw-r--r--utils/coverity/model.c112
-rw-r--r--utils/deriveConstants/DeriveConstants.hs63
-rw-r--r--utils/dll-split/Main.hs3
-rw-r--r--utils/dll-split/dll-split.cabal3
-rw-r--r--utils/genapply/GenApply.hs314
-rw-r--r--utils/genargs/genargs.pl5
-rw-r--r--utils/genprimopcode/Main.hs6
-rw-r--r--utils/ghc-cabal/ghc-cabal.cabal5
-rw-r--r--utils/ghc-pkg/Main.hs111
-rw-r--r--utils/ghc-pkg/ghc-pkg.cabal5
-rw-r--r--utils/ghc-pwd/ghc-pwd.cabal3
-rw-r--r--utils/ghctags/Main.hs2
-rw-r--r--utils/ghctags/ghctags.cabal6
m---------utils/haddock0
-rw-r--r--utils/hp2ps/HpFile.c11
-rw-r--r--utils/hpc/hpc-bin.cabal4
m---------utils/hsc2hs0
-rw-r--r--utils/mkUserGuidePart/mkUserGuidePart.cabal3
-rw-r--r--utils/runghc/runghc.cabal.in3
-rw-r--r--utils/runghc/runghc.hs2
24 files changed, 446 insertions, 225 deletions
diff --git a/utils/checkUniques/Makefile b/utils/checkUniques/Makefile
index a7b2df17e2..b017473da3 100644
--- a/utils/checkUniques/Makefile
+++ b/utils/checkUniques/Makefile
@@ -13,4 +13,4 @@ check: checkUniques
./checkUniques mkPreludeMiscIdUnique $(PREL_NAMES) $(DS_META)
checkUniques: checkUniques.hs
- $(GHC) --make $@
+ $(GHC) -O -XHaskell2010 --make $@
diff --git a/utils/checkUniques/checkUniques.hs b/utils/checkUniques/checkUniques.hs
index d8858dee26..2eda188e3c 100644
--- a/utils/checkUniques/checkUniques.hs
+++ b/utils/checkUniques/checkUniques.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE PatternGuards #-}
-
-- Some things could be improved, e.g.:
-- * Check that each file given contains at least one instance of the
-- function
diff --git a/utils/compare_sizes/Main.hs b/utils/compare_sizes/Main.hs
index bb1685ff6a..c64a55485b 100644
--- a/utils/compare_sizes/Main.hs
+++ b/utils/compare_sizes/Main.hs
@@ -1,4 +1,4 @@
--- This program compares the sizes of corresponding files in two tress
+-- This program compares the sizes of corresponding files in two trees
-- $ ./compareSizes --hi ~/ghc/darcs/ghc ~/ghc/6.12-branch/ghc
-- Size | Change | Filename
diff --git a/utils/compare_sizes/compareSizes.cabal b/utils/compare_sizes/compareSizes.cabal
index 32acb1d6e7..f8f42636a7 100644
--- a/utils/compare_sizes/compareSizes.cabal
+++ b/utils/compare_sizes/compareSizes.cabal
@@ -1,6 +1,6 @@
name: compareSizes
version: 0.1.0.0
-cabal-version: >= 1.6
+cabal-version: >=1.10
license: BSD3
build-type: Simple
license-file: LICENSE
@@ -10,6 +10,8 @@ description: Size comparison util
category: Development
executable compareSizes
+ default-language: Haskell2010
+
build-depends:
base >= 4 && < 5,
directory,
diff --git a/utils/coverity/model.c b/utils/coverity/model.c
new file mode 100644
index 0000000000..d0a3708b65
--- /dev/null
+++ b/utils/coverity/model.c
@@ -0,0 +1,112 @@
+/* Coverity Scan model
+ * This is a modeling file for Coverity Scan. Modeling helps to avoid false
+ * positives.
+ *
+ * - A model file can't import any header files. Some built-in primitives are
+ * available but not wchar_t, NULL etc.
+ * - Modeling doesn't need full structs and typedefs. Rudimentary structs
+ * and similar types are sufficient.
+ * - An uninitialized local variable signifies that the variable could be
+ * any value.
+ *
+ * The model file must be uploaded by an admin in the analysis settings of
+ * http://scan.coverity.com/projects/1919
+ */
+
+#define NULL ((void*)0)
+#define assert(x) if (!(x)) __coverity_panic__();
+
+/* type decls */
+typedef struct {} va_list;
+
+/* glibc functions */
+void *malloc (size_t);
+void *calloc (size_t, size_t);
+void *realloc (void *, size_t);
+void free (void *);
+
+/* rts allocation functions */
+
+void* stgMallocBytes(int n, char *msg)
+{
+ void *mem;
+ __coverity_negative_sink__((size_t)n);
+ mem = malloc((size_t)n);
+ assert(mem != NULL);
+ return mem;
+}
+
+void* stgReallocBytes(void *p, int n, char *msg)
+{
+ void *mem;
+ __coverity_negative_sink__((size_t)n);
+
+ /* man 3 realloc: if p == NULL, then realloc is equivalent to malloc() */
+ if (p == NULL) {
+ mem = malloc((size_t)n);
+ assert(mem != NULL);
+ return mem;
+ }
+
+ /* man 3 realloc: if n == 0, then realloc is equivalent to free() */
+ if (n == 0) {
+ free(p);
+ return NULL;
+ } else {
+ mem = realloc(p, (size_t)n);
+ assert(mem != NULL);
+ return mem;
+ }
+}
+
+void* stgCallocBytes(int n, int m, char *msg)
+{
+ void *mem;
+ __coverity_negative_sink__((size_t)n);
+ __coverity_negative_sink__((size_t)m);
+ mem = calloc(n, m);
+ assert(mem != NULL);
+ return mem;
+}
+
+void stgFree(void* p)
+{
+ free(p);
+}
+
+/* Kill paths */
+
+void stg_exit(int n)
+{
+ __coverity_panic__();
+}
+
+void shutdownThread(void)
+{
+ __coverity_panic__();
+}
+
+void shutdownHaskellAndExit(int exitCode, int fastExit)
+{
+ __coverity_panic__();
+}
+
+void shutdownHaskellAndSignal(int sig, int fastExit)
+{
+ __coverity_panic__();
+}
+
+void _assertFail(const char *filename, unsigned int linenum)
+{
+ __coverity_panic__();
+}
+
+void barf(const char *s, ...)
+{
+ __coverity_panic__();
+}
+
+void vbarf(const char *s, va_list ap)
+{
+ __coverity_panic__();
+}
diff --git a/utils/deriveConstants/DeriveConstants.hs b/utils/deriveConstants/DeriveConstants.hs
index 8c943f0584..9bf21609f1 100644
--- a/utils/deriveConstants/DeriveConstants.hs
+++ b/utils/deriveConstants/DeriveConstants.hs
@@ -10,20 +10,20 @@ into non-C source containing this information.
------------------------------------------------------------------------ -}
-import Control.Monad
-import Data.Bits
-import Data.Char
-import Data.List
+import Control.Monad (when, unless)
+import Data.Bits (shiftL)
+import Data.Char (toLower)
+import Data.List (stripPrefix)
import Data.Map (Map)
import qualified Data.Map as Map
-import Data.Maybe
-import Numeric
-import System.Environment
-import System.Exit
-import System.FilePath
-import System.IO
-import System.Info
-import System.Process
+import Data.Maybe (catMaybes)
+import Numeric (readHex)
+import System.Environment (getArgs)
+import System.Exit (ExitCode(ExitSuccess), exitFailure)
+import System.FilePath ((</>))
+import System.IO (stderr, hPutStrLn)
+import System.Info (os)
+import System.Process (showCommandForUser, readProcess, rawSystem)
main :: IO ()
main = do opts <- parseArgs
@@ -349,6 +349,8 @@ wanteds = concat
,structField C "Capability" "context_switch"
,structField C "Capability" "interrupt"
,structField C "Capability" "sparks"
+ ,structField C "Capability" "weak_ptr_list_hd"
+ ,structField C "Capability" "weak_ptr_list_tl"
,structField Both "bdescr" "start"
,structField Both "bdescr" "free"
@@ -641,7 +643,7 @@ getWanted verbose tmpdir gccProgram gccFlags nmProgram
oFile = tmpdir </> "tmp.o"
writeFile cFile cStuff
execute verbose gccProgram (gccFlags ++ ["-c", cFile, "-o", oFile])
- xs <- readProcess nmProgram [oFile] ""
+ xs <- readProcess nmProgram ["-P", oFile] ""
let ls = lines xs
ms = map parseNmLine ls
m = Map.fromList $ catMaybes ms
@@ -710,28 +712,21 @@ getWanted verbose tmpdir gccProgram gccFlags nmProgram
doWanted (ClosurePayloadMacro {}) = []
doWanted (FieldTypeGcptrMacro {}) = []
- -- parseNmLine parses nm output that looks like
- -- "0000000b C derivedConstantMAX_Vanilla_REG"
+ -- parseNmLine parses "nm -P" output that looks like
+ -- "derivedConstantMAX_Vanilla_REG C 0000000b 0000000b" (GNU nm)
+ -- "_derivedConstantMAX_Vanilla_REG C b 0" (Mac OS X)
+ -- "_derivedConstantMAX_Vanilla_REG C 000000b" (MinGW)
+ -- "derivedConstantMAX_Vanilla_REG D 1 b" (Solaris)
-- and returns ("MAX_Vanilla_REG", 11)
- parseNmLine xs0 = case break (' ' ==) xs0 of
- (x1, ' ' : xs1) ->
- case break (' ' ==) xs1 of
- (x2, ' ' : x3) ->
- case readHex x1 of
- [(size, "")] ->
- case x2 of
- "C" ->
- let x3' = case x3 of
- '_' : rest -> rest
- _ -> x3
- in case stripPrefix prefix x3' of
- Just name ->
- Just (name, size)
- _ -> Nothing
- _ -> Nothing
- _ -> Nothing
- _ -> Nothing
- _ -> Nothing
+ parseNmLine line
+ = case words line of
+ ('_' : n) : "C" : s : _ -> mkP n s
+ n : "C" : s : _ -> mkP n s
+ [n, "D", _, s] -> mkP n s
+ _ -> Nothing
+ where mkP r s = case (stripPrefix prefix r, readHex s) of
+ (Just name, [(size, "")]) -> Just (name, size)
+ _ -> Nothing
-- If an Int value is larger than 2^28 or smaller
-- than -2^28, then fail.
diff --git a/utils/dll-split/Main.hs b/utils/dll-split/Main.hs
index c0e370641c..c3f5a15a4a 100644
--- a/utils/dll-split/Main.hs
+++ b/utils/dll-split/Main.hs
@@ -1,6 +1,3 @@
-
-{-# LANGUAGE PatternGuards #-}
-
module Main (main) where
import Control.Monad
diff --git a/utils/dll-split/dll-split.cabal b/utils/dll-split/dll-split.cabal
index bece0a4770..290af06472 100644
--- a/utils/dll-split/dll-split.cabal
+++ b/utils/dll-split/dll-split.cabal
@@ -10,9 +10,10 @@ Description:
XXX
Category: Development
build-type: Simple
-cabal-version: >=1.2
+cabal-version: >=1.10
Executable dll-split
+ Default-Language: Haskell2010
Main-Is: Main.hs
Build-Depends: base >= 4 && < 5,
diff --git a/utils/genapply/GenApply.hs b/utils/genapply/GenApply.hs
index dab6e91fde..7b84a27d64 100644
--- a/utils/genapply/GenApply.hs
+++ b/utils/genapply/GenApply.hs
@@ -21,6 +21,7 @@ import Data.List ( intersperse, nub, sort )
import System.Exit
import System.Environment
import System.IO
+import Control.Arrow ((***))
-- -----------------------------------------------------------------------------
-- Argument kinds (rougly equivalent to PrimRep)
@@ -199,6 +200,45 @@ mb_tag_node arity | Just tag <- tagForArity arity = mkTagStmt tag <> semi
mkTagStmt tag = text ("R1 = R1 + "++ show tag)
+type StackUsage = (Int, Int) -- PROFILING, normal
+
+maxStack :: [StackUsage] -> StackUsage
+maxStack = (maximum *** maximum) . unzip
+
+stackCheck
+ :: RegStatus -- Registerised status
+ -> [ArgRep]
+ -> Bool -- args in regs?
+ -> Doc -- fun_info_label
+ -> StackUsage
+ -> Doc
+stackCheck regstatus args args_in_regs fun_info_label (prof_sp, norm_sp) =
+ let
+ (reg_locs, leftovers, sp_offset) = assignRegs regstatus 1 args
+
+ cmp_sp n
+ | n > 0 =
+ text "if (Sp - WDS(" <> int n <> text ") < SpLim) {" $$
+ nest 4 (vcat [
+ if args_in_regs
+ then
+ text "Sp_adj" <> parens (int (-sp_offset)) <> semi $$
+ saveRegOffs reg_locs
+ else
+ empty,
+ text "Sp(0) = " <> fun_info_label <> char ';',
+ mkJump regstatus (text "__stg_gc_enter_1") ["R1"] [] <> semi
+ ]) $$
+ char '}'
+ | otherwise = empty
+ in
+ vcat [ text "#ifdef PROFILING",
+ cmp_sp prof_sp,
+ text "#else",
+ cmp_sp norm_sp,
+ text "#endif"
+ ]
+
genMkPAP :: RegStatus -- Register status
-> String -- Macro
-> String -- Jump target
@@ -212,17 +252,19 @@ genMkPAP :: RegStatus -- Register status
-> Int -- Size of all arguments
-> Doc -- info label
-> Bool -- Is a function
- -> Doc
+ -> (Doc, StackUsage)
genMkPAP regstatus macro jump live ticker disamb
no_load_regs -- don't load argument regs before jumping
args_in_regs -- arguments are already in regs
is_pap args all_args_size fun_info_label
is_fun_case
- = smaller_arity_cases
- $$ exact_arity_case
- $$ larger_arity_case
-
+ = (doc, stack_usage)
+
where
+ doc = vcat smaller_arity_doc $$ exact_arity_case $$ larger_arity_doc
+
+ stack_usage = maxStack (larger_arity_stack : smaller_arity_stack)
+
n_args = length args
-- offset of arguments on the stack at slow apply calls.
@@ -237,10 +279,17 @@ genMkPAP regstatus macro jump live ticker disamb
-- Sp[0] = Sp[1];
-- Sp[1] = (W_)&stg_ap_1_info;
-- JMP_(GET_ENTRY(R1.cl));
- smaller_arity_cases = vcat [ smaller_arity i | i <- [1..n_args-1] ]
+ (smaller_arity_doc, smaller_arity_stack)
+ = unzip [ smaller_arity i | i <- [1..n_args-1] ]
+
+ smaller_arity arity = (doc, stack_usage)
+ where
+ (save_regs, stack_usage)
+ | overflow_regs = save_extra_regs
+ | otherwise = shuffle_extra_args
- smaller_arity arity
- = text "if (arity == " <> int arity <> text ") {" $$
+ doc =
+ text "if (arity == " <> int arity <> text ") {" $$
nest 4 (vcat [
-- text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_MANY();",
@@ -253,9 +302,7 @@ genMkPAP regstatus macro jump live ticker disamb
-- If the extra arguments are on the stack, then we must
-- instead shuffle them down to make room for the info
-- table for the follow-on call.
- if overflow_regs
- then save_extra_regs
- else shuffle_extra_args,
+ save_regs,
-- for a PAP, we have to arrange that the stack contains a
-- return address in the event that stg_PAP_entry fails its
@@ -271,81 +318,88 @@ genMkPAP regstatus macro jump live ticker disamb
]) $$
text "}"
- where
- -- offsets in case we need to save regs:
- (reg_locs, _, _)
- = assignRegs regstatus stk_args_offset args
-
- -- register assignment for *this function call*
- (reg_locs', reg_call_leftovers, reg_call_sp_stk_args)
- = assignRegs regstatus stk_args_offset (take arity args)
-
- load_regs
- | no_load_regs || args_in_regs = empty
- | otherwise = loadRegOffs reg_locs'
-
- (this_call_args, rest_args) = splitAt arity args
-
- -- the offset of the stack args from initial Sp
- sp_stk_args
- | args_in_regs = stk_args_offset
- | no_load_regs = stk_args_offset
- | otherwise = reg_call_sp_stk_args
-
- -- the stack args themselves
- this_call_stack_args
- | args_in_regs = reg_call_leftovers -- sp offsets are wrong
- | no_load_regs = this_call_args
- | otherwise = reg_call_leftovers
-
- stack_args_size = sum (map argSize this_call_stack_args)
-
- overflow_regs = args_in_regs && length reg_locs > length reg_locs'
-
- save_extra_regs
- = -- we have extra arguments in registers to save
- let
- extra_reg_locs = drop (length reg_locs') (reverse reg_locs)
- adj_reg_locs = [ (reg, off - adj + 1) |
- (reg,off) <- extra_reg_locs ]
- adj = case extra_reg_locs of
- (reg, fst_off):_ -> fst_off
- size = snd (last adj_reg_locs)
- in
- text "Sp_adj(" <> int (-size - 1) <> text ");" $$
- saveRegOffs adj_reg_locs $$
- loadSpWordOff "W_" 0 <> text " = " <>
- mkApplyInfoName rest_args <> semi
-
- shuffle_extra_args
- = vcat [text "#ifdef PROFILING",
- shuffle True,
+ -- offsets in case we need to save regs:
+ (reg_locs, _, _)
+ = assignRegs regstatus stk_args_offset args
+
+ -- register assignment for *this function call*
+ (reg_locs', reg_call_leftovers, reg_call_sp_stk_args)
+ = assignRegs regstatus stk_args_offset (take arity args)
+
+ load_regs
+ | no_load_regs || args_in_regs = empty
+ | otherwise = loadRegOffs reg_locs'
+
+ (this_call_args, rest_args) = splitAt arity args
+
+ -- the offset of the stack args from initial Sp
+ sp_stk_args
+ | args_in_regs = stk_args_offset
+ | no_load_regs = stk_args_offset
+ | otherwise = reg_call_sp_stk_args
+
+ -- the stack args themselves
+ this_call_stack_args
+ | args_in_regs = reg_call_leftovers -- sp offsets are wrong
+ | no_load_regs = this_call_args
+ | otherwise = reg_call_leftovers
+
+ stack_args_size = sum (map argSize this_call_stack_args)
+
+ overflow_regs = args_in_regs && length reg_locs > length reg_locs'
+
+ save_extra_regs = (doc, (size,size))
+ where
+ -- we have extra arguments in registers to save
+ extra_reg_locs = drop (length reg_locs') (reverse reg_locs)
+ adj_reg_locs = [ (reg, off - adj + 1) |
+ (reg,off) <- extra_reg_locs ]
+ adj = case extra_reg_locs of
+ (reg, fst_off):_ -> fst_off
+ size = snd (last adj_reg_locs) + 1
+
+ doc =
+ text "Sp_adj(" <> int (-size) <> text ");" $$
+ saveRegOffs adj_reg_locs $$
+ loadSpWordOff "W_" 0 <> text " = " <>
+ mkApplyInfoName rest_args <> semi
+
+ shuffle_extra_args = (doc, (shuffle_prof_stack, shuffle_norm_stack))
+ where
+ doc = vcat [ text "#ifdef PROFILING",
+ shuffle_prof_doc,
text "#else",
- shuffle False,
+ shuffle_norm_doc,
text "#endif"]
- where
- -- Sadly here we have to insert an stg_restore_cccs frame
- -- just underneath the stg_ap_*_info frame if we're
- -- profiling; see Note [jump_SAVE_CCCS]
- shuffle prof =
- let offset = if prof then 2 else 0 in
- vcat (map (shuffle_down (offset+1))
- [sp_stk_args .. sp_stk_args+stack_args_size-1]) $$
- (if prof
- then
- loadSpWordOff "W_" (sp_stk_args+stack_args_size-3)
- <> text " = stg_restore_cccs_info;" $$
- loadSpWordOff "W_" (sp_stk_args+stack_args_size-2)
- <> text " = CCCS;"
- else empty) $$
- loadSpWordOff "W_" (sp_stk_args+stack_args_size-1)
- <> text " = "
- <> mkApplyInfoName rest_args <> semi $$
- text "Sp_adj(" <> int (sp_stk_args - 1 - offset) <> text ");"
-
- shuffle_down j i =
- loadSpWordOff "W_" (i-j) <> text " = " <>
- loadSpWordOff "W_" i <> semi
+
+ (shuffle_prof_doc, shuffle_prof_stack) = shuffle True
+ (shuffle_norm_doc, shuffle_norm_stack) = shuffle False
+
+ -- Sadly here we have to insert an stg_restore_cccs frame
+ -- just underneath the stg_ap_*_info frame if we're
+ -- profiling; see Note [jump_SAVE_CCCS]
+ shuffle prof = (doc, -sp_adj)
+ where
+ sp_adj = sp_stk_args - 1 - offset
+ offset = if prof then 2 else 0
+ doc =
+ vcat (map (shuffle_down (offset+1))
+ [sp_stk_args .. sp_stk_args+stack_args_size-1]) $$
+ (if prof
+ then
+ loadSpWordOff "W_" (sp_stk_args+stack_args_size-3)
+ <> text " = stg_restore_cccs_info;" $$
+ loadSpWordOff "W_" (sp_stk_args+stack_args_size-2)
+ <> text " = CCCS;"
+ else empty) $$
+ loadSpWordOff "W_" (sp_stk_args+stack_args_size-1)
+ <> text " = "
+ <> mkApplyInfoName rest_args <> semi $$
+ text "Sp_adj(" <> int sp_adj <> text ");"
+
+ shuffle_down j i =
+ loadSpWordOff "W_" (i-j) <> text " = " <>
+ loadSpWordOff "W_" i <> semi
-- The EXACT ARITY case
@@ -378,7 +432,17 @@ genMkPAP regstatus macro jump live ticker disamb
-- BUILD_PAP(1,0,(W_)&stg_ap_v_info);
-- }
- larger_arity_case =
+ (larger_arity_doc, larger_arity_stack) = (doc, stack)
+ where
+ -- offsets in case we need to save regs:
+ (reg_locs, leftovers, sp_offset)
+ = assignRegs regstatus stk_args_slow_offset args
+ -- BUILD_PAP assumes args start at offset 1
+
+ stack | args_in_regs = (sp_offset, sp_offset)
+ | otherwise = (0,0)
+
+ doc =
text "} else {" $$
let
save_regs
@@ -407,11 +471,7 @@ genMkPAP regstatus macro jump live ticker disamb
text ");"
]) $$
char '}'
- where
- -- offsets in case we need to save regs:
- (reg_locs, leftovers, sp_offset)
- = assignRegs regstatus stk_args_slow_offset args
- -- BUILD_PAP assumes args start at offset 1
+
-- Note [jump_SAVE_CCCS]
@@ -453,13 +513,14 @@ enterFastPathHelper :: Int
-> [ArgRep]
-> Doc
enterFastPathHelper tag regstatus no_load_regs args_in_regs args =
- vcat [text "if (GETTAG(R1)==" <> int tag <> text ") {",
- reg_doc,
- text " Sp_adj(" <> int sp' <> text ");",
- -- enter, but adjust offset with tag
- text " " <> mkJump regstatus (text "%GET_ENTRY(R1-" <> int tag <> text ")") ["R1"] args <> semi,
- text "}"
- ]
+ text "if (GETTAG(R1)==" <> int tag <> text ") {" $$
+ nest 4 (vcat [
+ reg_doc,
+ text "Sp_adj(" <> int sp' <> text ");",
+ -- enter, but adjust offset with tag
+ mkJump regstatus (text "%GET_ENTRY(R1-" <> int tag <> text ")") ["R1"] args <> semi
+ ]) $$
+ text "}"
-- I don't totally understand this code, I copied it from
-- exact_arity_case
-- TODO: refactor
@@ -519,6 +580,23 @@ genApply regstatus args =
fun_ret_label = mkApplyRetName args
fun_info_label = mkApplyInfoName args
all_args_size = sum (map argSize args)
+
+ (bco_doc, bco_stack) =
+ genMkPAP regstatus "BUILD_PAP" "ENTRY_LBL(stg_BCO)" ["R1"] "FUN" "BCO"
+ True{-stack apply-} False{-args on stack-} False{-not a PAP-}
+ args all_args_size fun_info_label {- tag stmt -}False
+
+ (fun_doc, fun_stack) =
+ genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(UNTAG(R1))" ["R1"] "FUN" "FUN"
+ False{-reg apply-} False{-args on stack-} False{-not a PAP-}
+ args all_args_size fun_info_label {- tag stmt -}True
+
+ (pap_doc, pap_stack) =
+ genMkPAP regstatus "NEW_PAP" "stg_PAP_apply" ["R1", "R2"] "PAP" "PAP"
+ True{-stack apply-} False{-args on stack-} True{-is a PAP-}
+ args all_args_size fun_info_label {- tag stmt -}False
+
+ stack_usage = maxStack [bco_stack, fun_stack, pap_stack]
in
vcat [
text "INFO_TABLE_RET(" <> mkApplyName args <> text ", " <>
@@ -579,6 +657,9 @@ genApply regstatus args =
-- if pointer is tagged enter it fast!
enterFastPath regstatus False False args,
+ stackCheck regstatus args False{-args on stack-}
+ fun_info_label stack_usage,
+
-- Functions can be tagged, so we untag them!
text "R1 = UNTAG(R1);",
text "info = %INFO_PTR(R1);",
@@ -596,9 +677,7 @@ genApply regstatus args =
nest 4 (vcat [
text "arity = TO_W_(StgBCO_arity(R1));",
text "ASSERT(arity > 0);",
- genMkPAP regstatus "BUILD_PAP" "ENTRY_LBL(stg_BCO)" ["R1"] "FUN" "BCO"
- True{-stack apply-} False{-args on stack-} False{-not a PAP-}
- args all_args_size fun_info_label {- tag stmt -}False
+ bco_doc
]),
text "}",
@@ -615,9 +694,7 @@ genApply regstatus args =
nest 4 (vcat [
text "arity = TO_W_(StgFunInfoExtra_arity(%FUN_INFO(info)));",
text "ASSERT(arity > 0);",
- genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(UNTAG(R1))" ["R1"] "FUN" "FUN"
- False{-reg apply-} False{-args on stack-} False{-not a PAP-}
- args all_args_size fun_info_label {- tag stmt -}True
+ fun_doc
]),
text "}",
@@ -629,9 +706,7 @@ genApply regstatus args =
nest 4 (vcat [
text "arity = TO_W_(StgPAP_arity(R1));",
text "ASSERT(arity > 0);",
- genMkPAP regstatus "NEW_PAP" "stg_PAP_apply" ["R1", "R2"] "PAP" "PAP"
- True{-stack apply-} False{-args on stack-} True{-is a PAP-}
- args all_args_size fun_info_label {- tag stmt -}False
+ pap_doc
]),
text "}",
@@ -690,6 +765,7 @@ genApply regstatus args =
]),
text "}"
]),
+
text "}"
]
@@ -702,6 +778,15 @@ genApplyFast regstatus args =
fun_ret_label = text "RET_LBL" <> parens (mkApplyName args)
fun_info_label = mkApplyInfoName args
all_args_size = sum (map argSize args)
+
+ (fun_doc, fun_stack) =
+ genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(UNTAG(R1))" ["R1"] "FUN" "FUN"
+ False{-reg apply-} True{-args in regs-} False{-not a PAP-}
+ args all_args_size fun_info_label {- tag stmt -}True
+
+ (reg_locs, leftovers, sp_offset) = assignRegs regstatus 1 args
+
+ stack_usage = maxStack [fun_stack, (sp_offset,sp_offset)]
in
vcat [
fun_fast_label,
@@ -715,6 +800,9 @@ genApplyFast regstatus args =
-- if pointer is tagged enter it fast!
enterFastPath regstatus False True args,
+ stackCheck regstatus args True{-args in regs-}
+ fun_info_label stack_usage,
+
-- Functions can be tagged, so we untag them!
text "R1 = UNTAG(R1);",
text "info = %GET_STD_INFO(R1);",
@@ -730,18 +818,11 @@ genApplyFast regstatus args =
nest 4 (vcat [
text "arity = TO_W_(StgFunInfoExtra_arity(%GET_FUN_INFO(R1)));",
text "ASSERT(arity > 0);",
- genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(UNTAG(R1))" ["R1"] "FUN" "FUN"
- False{-reg apply-} True{-args in regs-} False{-not a PAP-}
- args all_args_size fun_info_label {- tag stmt -}True
+ fun_doc
]),
char '}',
text "default: {",
- let
- (reg_locs, leftovers, sp_offset) = assignRegs regstatus 1 args
- -- leave a one-word space on the top of the stack when
- -- calling the slow version
- in
nest 4 (vcat [
text "Sp_adj" <> parens (int (-sp_offset)) <> semi,
saveRegOffs reg_locs,
@@ -749,8 +830,9 @@ genApplyFast regstatus args =
]),
char '}'
]),
- char '}'
- ]),
+
+ char '}'
+ ]),
char '}'
]
diff --git a/utils/genargs/genargs.pl b/utils/genargs/genargs.pl
index 2ef2dfa3e6..33dd2a0c8c 100644
--- a/utils/genargs/genargs.pl
+++ b/utils/genargs/genargs.pl
@@ -1,4 +1,7 @@
-#!/usr/bin/perl
+#!/usr/bin/env perl
+
+use warnings;
+
my $quote_open = 0;
my $quote_char = '';
my $accum = "";
diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs
index aa64094add..7fe375a7d2 100644
--- a/utils/genprimopcode/Main.hs
+++ b/utils/genprimopcode/Main.hs
@@ -118,7 +118,7 @@ main = getArgs >>= \args ->
do s <- getContents
case parse s of
Left err -> error ("parse error at " ++ (show err))
- Right p_o_specs@(Info _ entries)
+ Right p_o_specs@(Info _ _)
-> seq (sanityTop p_o_specs) (
case head args of
@@ -187,9 +187,6 @@ main = getArgs >>= \args ->
"--make-haskell-source"
-> putStr (gen_hs_source p_o_specs)
- "--make-ext-core-source"
- -> putStr (gen_ext_core_source entries)
-
"--make-latex-doc"
-> putStr (gen_latex_doc p_o_specs)
@@ -215,7 +212,6 @@ known_args
"--primop-vector-tycons",
"--make-haskell-wrappers",
"--make-haskell-source",
- "--make-ext-core-source",
"--make-latex-doc"
]
diff --git a/utils/ghc-cabal/ghc-cabal.cabal b/utils/ghc-cabal/ghc-cabal.cabal
index 74399ce390..5437d63bb2 100644
--- a/utils/ghc-cabal/ghc-cabal.cabal
+++ b/utils/ghc-cabal/ghc-cabal.cabal
@@ -10,14 +10,15 @@ Description:
XXX
Category: Development
build-type: Simple
-cabal-version: >=1.2
+cabal-version: >=1.10
Executable ghc-cabal
+ Default-Language: Haskell2010
Main-Is: ghc-cabal.hs
Build-Depends: base >= 3 && < 5,
bytestring >= 0.10 && < 0.11,
- Cabal >= 1.20 && < 1.21,
+ Cabal >= 1.20 && < 1.22,
directory >= 1.1 && < 1.3,
filepath >= 1.2 && < 1.4
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 30acbe2eb8..e51755ce2c 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE PatternGuards, CPP, ForeignFunctionInterface #-}
+{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 2004-2009.
@@ -114,6 +114,7 @@ data Flag
| FlagForce
| FlagForceFiles
| FlagAutoGHCiLibs
+ | FlagMultiInstance
| FlagExpandEnvVars
| FlagExpandPkgroot
| FlagNoExpandPkgroot
@@ -146,6 +147,8 @@ flags = [
"ignore missing directories and libraries only",
Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
"automatically build libs for GHCi (with register)",
+ Option [] ["enable-multi-instance"] (NoArg FlagMultiInstance)
+ "allow registering multiple instances of the same package version",
Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars)
"expand environment variables (${name}-style) in input package descriptions",
Option [] ["expand-pkgroot"] (NoArg FlagExpandPkgroot)
@@ -309,6 +312,7 @@ runit verbosity cli nonopts = do
| FlagForceFiles `elem` cli = ForceFiles
| otherwise = NoForce
auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
+ multi_instance = FlagMultiInstance `elem` cli
expand_env_vars= FlagExpandEnvVars `elem` cli
mexpand_pkgroot= foldl' accumExpandPkgroot Nothing cli
where accumExpandPkgroot _ FlagExpandPkgroot = Just True
@@ -355,10 +359,12 @@ runit verbosity cli nonopts = do
initPackageDB filename verbosity cli
["register", filename] ->
registerPackage filename verbosity cli
- auto_ghci_libs expand_env_vars False force
+ auto_ghci_libs multi_instance
+ expand_env_vars False force
["update", filename] ->
registerPackage filename verbosity cli
- auto_ghci_libs expand_env_vars True force
+ auto_ghci_libs multi_instance
+ expand_env_vars True force
["unregister", pkgid_str] -> do
pkgid <- readGlobPkgId pkgid_str
unregisterPackage pkgid verbosity cli force
@@ -593,9 +599,9 @@ lookForPackageDBIn dir = do
let path_dir = dir </> "package.conf.d"
exists_dir <- doesDirectoryExist path_dir
if exists_dir then return (Just path_dir) else do
- let path_file = dir </> "package.conf"
- exists_file <- doesFileExist path_file
- if exists_file then return (Just path_file) else return Nothing
+ let path_file = dir </> "package.conf"
+ exists_file <- doesFileExist path_file
+ if exists_file then return (Just path_file) else return Nothing
readParseDatabase :: Verbosity
-> Maybe (FilePath,Bool)
@@ -782,11 +788,13 @@ registerPackage :: FilePath
-> Verbosity
-> [Flag]
-> Bool -- auto_ghci_libs
+ -> Bool -- multi_instance
-> Bool -- expand_env_vars
-> Bool -- update
-> Force
-> IO ()
-registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update force = do
+registerPackage input verbosity my_flags auto_ghci_libs multi_instance
+ expand_env_vars update force = do
(db_stack, Just to_modify, _flag_dbs) <-
getPkgDatabases verbosity True True False{-expand vars-} my_flags
@@ -829,10 +837,16 @@ registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update f
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_expanded verbosity truncated_stack auto_ghci_libs update force
+ validatePackageConfig pkg_expanded verbosity truncated_stack
+ auto_ghci_libs multi_instance update force
let
+ -- In the normal mode, we only allow one version of each package, so we
+ -- remove all instances with the same source package id as the one we're
+ -- adding. In the multi instance mode we don't do that, thus allowing
+ -- multiple instances with the same source package id.
removes = [ RemovePackage p
- | p <- packages db_to_operate_on,
+ | not multi_instance,
+ p <- packages db_to_operate_on,
sourcePackageId p == sourcePackageId pkg ]
--
changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
@@ -1035,34 +1049,34 @@ listPackages verbosity my_flags mPackageName mModuleName = do
if simple_output then show_simple stack else do
#if defined(mingw32_HOST_OS) || defined(BOOTSTRAPPING)
- mapM_ show_normal stack
+ mapM_ show_normal stack
#else
- let
- show_colour withF db =
- mconcat $ map (<#> termText "\n") $
- (termText (location db) :
- map (termText " " <#>) (map pp_pkg (packages db)))
- where
- pp_pkg p
- | sourcePackageId p `elem` broken = withF Red doc
- | exposed p = doc
- | otherwise = withF Blue doc
- where doc | verbosity >= Verbose
- = termText (printf "%s (%s)" pkg ipid)
- | otherwise
- = termText pkg
- where
- InstalledPackageId ipid = installedPackageId p
- pkg = display (sourcePackageId p)
-
- is_tty <- hIsTerminalDevice stdout
- if not is_tty
- then mapM_ show_normal stack
- else do tty <- Terminfo.setupTermFromEnv
- case Terminfo.getCapability tty withForegroundColor of
- Nothing -> mapM_ show_normal stack
- Just w -> runTermOutput tty $ mconcat $
- map (show_colour w) stack
+ let
+ show_colour withF db =
+ mconcat $ map (<#> termText "\n") $
+ (termText (location db) :
+ map (termText " " <#>) (map pp_pkg (packages db)))
+ where
+ pp_pkg p
+ | sourcePackageId p `elem` broken = withF Red doc
+ | exposed p = doc
+ | otherwise = withF Blue doc
+ where doc | verbosity >= Verbose
+ = termText (printf "%s (%s)" pkg ipid)
+ | otherwise
+ = termText pkg
+ where
+ InstalledPackageId ipid = installedPackageId p
+ pkg = display (sourcePackageId p)
+
+ is_tty <- hIsTerminalDevice stdout
+ if not is_tty
+ then mapM_ show_normal stack
+ else do tty <- Terminfo.setupTermFromEnv
+ case Terminfo.getCapability tty withForegroundColor of
+ Nothing -> mapM_ show_normal stack
+ Just w -> runTermOutput tty $ mconcat $
+ map (show_colour w) stack
#endif
simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
@@ -1204,7 +1218,8 @@ checkConsistency verbosity my_flags = do
let pkgs = allPackagesInStack db_stack
checkPackage p = do
- (_,es,ws) <- runValidate $ checkPackageConfig p verbosity db_stack False True
+ (_,es,ws) <- runValidate $ checkPackageConfig p verbosity db_stack
+ False True True
if null es
then do when (not simple_output) $ do
_ <- reportValidateErrors [] ws "" Nothing
@@ -1354,11 +1369,15 @@ validatePackageConfig :: InstalledPackageInfo
-> Verbosity
-> PackageDBStack
-> Bool -- auto-ghc-libs
+ -> Bool -- multi_instance
-> Bool -- update, or check
-> Force
-> IO ()
-validatePackageConfig pkg verbosity db_stack auto_ghci_libs update force = do
- (_,es,ws) <- runValidate $ checkPackageConfig pkg verbosity db_stack auto_ghci_libs update
+validatePackageConfig pkg verbosity db_stack auto_ghci_libs
+ multi_instance update force = do
+ (_,es,ws) <- runValidate $
+ checkPackageConfig pkg verbosity db_stack
+ auto_ghci_libs multi_instance update
ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force)
when (not ok) $ exitWith (ExitFailure 1)
@@ -1366,12 +1385,14 @@ checkPackageConfig :: InstalledPackageInfo
-> Verbosity
-> PackageDBStack
-> Bool -- auto-ghc-libs
+ -> Bool -- multi_instance
-> Bool -- update, or check
-> Validate ()
-checkPackageConfig pkg verbosity db_stack auto_ghci_libs update = do
+checkPackageConfig pkg verbosity db_stack auto_ghci_libs
+ multi_instance update = do
checkInstalledPackageId pkg db_stack update
checkPackageId pkg
- checkDuplicates db_stack pkg update
+ checkDuplicates db_stack pkg multi_instance update
mapM_ (checkDep db_stack) (depends pkg)
checkDuplicateDepends (depends pkg)
mapM_ (checkDir False "import-dirs") (importDirs pkg)
@@ -1410,15 +1431,17 @@ checkPackageId ipi =
[] -> verror CannotForce ("invalid package identifier: " ++ str)
_ -> verror CannotForce ("ambiguous package identifier: " ++ str)
-checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()
-checkDuplicates db_stack pkg update = do
+checkDuplicates :: PackageDBStack -> InstalledPackageInfo
+ -> Bool -> Bool-> Validate ()
+checkDuplicates db_stack pkg multi_instance update = do
let
pkgid = sourcePackageId pkg
pkgs = packages (head db_stack)
--
-- Check whether this package id already exists in this DB
--
- when (not update && (pkgid `elem` map sourcePackageId pkgs)) $
+ when (not update && not multi_instance
+ && (pkgid `elem` map sourcePackageId pkgs)) $
verror CannotForce $
"package " ++ display pkgid ++ " is already installed"
diff --git a/utils/ghc-pkg/ghc-pkg.cabal b/utils/ghc-pkg/ghc-pkg.cabal
index 2f42e31f15..574301086e 100644
--- a/utils/ghc-pkg/ghc-pkg.cabal
+++ b/utils/ghc-pkg/ghc-pkg.cabal
@@ -11,12 +11,13 @@ Description:
XXX
Category: Development
build-type: Simple
-cabal-version: >=1.4
+cabal-version: >=1.10
Executable ghc-pkg
+ Default-Language: Haskell2010
Main-Is: Main.hs
Other-Modules: Version
- Extensions: CPP, ForeignFunctionInterface, NondecreasingIndentation
+ Other-Extensions: CPP
Build-Depends: base >= 4 && < 5,
directory >= 1 && < 1.3,
diff --git a/utils/ghc-pwd/ghc-pwd.cabal b/utils/ghc-pwd/ghc-pwd.cabal
index ba2eb63b82..4d155b0317 100644
--- a/utils/ghc-pwd/ghc-pwd.cabal
+++ b/utils/ghc-pwd/ghc-pwd.cabal
@@ -9,9 +9,10 @@ Synopsis: XXX
Description:
XXX
build-type: Simple
-cabal-version: >=1.2
+cabal-version: >=1.10
Executable ghc-pwd
+ Default-Language: Haskell2010
Main-Is: ghc-pwd.hs
Build-Depends: base >= 3 && < 5,
directory >= 1 && < 1.3
diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs
index a67891e16a..815cc7ca18 100644
--- a/utils/ghctags/Main.hs
+++ b/utils/ghctags/Main.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import Prelude hiding ( mod, id, mapM )
diff --git a/utils/ghctags/ghctags.cabal b/utils/ghctags/ghctags.cabal
index 0e97ccade6..e9c784877b 100644
--- a/utils/ghctags/ghctags.cabal
+++ b/utils/ghctags/ghctags.cabal
@@ -10,13 +10,15 @@ Description:
XXX
Category: Development
build-type: Simple
-cabal-version: >=1.2
+cabal-version: >=1.10
Executable ghctags
+ Default-Language: Haskell2010
+
Main-Is: Main.hs
Build-Depends: base >= 4 && < 5,
containers,
- Cabal >= 1.20 && <1.21,
+ Cabal >= 1.20 && <1.22,
ghc
diff --git a/utils/haddock b/utils/haddock
-Subproject 08aa509ebac58bfb202ea79c7c41291ec280a1c
+Subproject cb96b4f1ed0462b4a394b9fda6612c3bea9886b
diff --git a/utils/hp2ps/HpFile.c b/utils/hp2ps/HpFile.c
index 5ee9cc259e..9459247a03 100644
--- a/utils/hp2ps/HpFile.c
+++ b/utils/hp2ps/HpFile.c
@@ -227,7 +227,7 @@ GetHpLine(FILE *infp)
Error("%s, line %d: integer must follow identifier", hpfile,
linenum);
}
- StoreSample(GetEntry(theident), nsamples, (floatish) theinteger);
+ StoreSample(GetEntry(theident), nsamples, thefloatish);
GetHpTok(infp);
break;
@@ -358,8 +358,13 @@ GetNumber(FILE *infp)
thefloatish = (floatish) atof(numberstring);
return FLOAT_TOK;
} else {
- theinteger = atoi(numberstring);
- return INTEGER_TOK;
+ theinteger = atoi(numberstring);
+ /* Set thefloatish too.
+ If this is an identifier line, the value might exceed
+ the size of 'int', and we are going to convert it to
+ a floatish anyways. */
+ thefloatish = (floatish) atof(numberstring);
+ return INTEGER_TOK;
}
}
diff --git a/utils/hpc/hpc-bin.cabal b/utils/hpc/hpc-bin.cabal
index 4f94ab0fa0..8ec6e5b790 100644
--- a/utils/hpc/hpc-bin.cabal
+++ b/utils/hpc/hpc-bin.cabal
@@ -11,7 +11,7 @@ Description:
XXX
Category: Development
build-type: Simple
-cabal-version: >=1.2
+cabal-version: >=1.10
Flag base4
Description: Choose the even newer, even smaller, split-up base package.
@@ -20,6 +20,7 @@ Flag base3
Description: Choose the new smaller, split-up base package.
Executable hpc
+ Default-Language: Haskell2010
Main-Is: Hpc.hs
Other-Modules: HpcParser
HpcCombine
@@ -45,5 +46,4 @@ Executable hpc
containers >= 0.1 && < 0.6,
array >= 0.1 && < 0.6
Build-Depends: hpc
- Extensions: CPP
diff --git a/utils/hsc2hs b/utils/hsc2hs
new file mode 160000
+Subproject 4a0f67704d89712f8493a0c7eccffa9243d6ef0
diff --git a/utils/mkUserGuidePart/mkUserGuidePart.cabal b/utils/mkUserGuidePart/mkUserGuidePart.cabal
index 3cadaacd47..112bbf6a81 100644
--- a/utils/mkUserGuidePart/mkUserGuidePart.cabal
+++ b/utils/mkUserGuidePart/mkUserGuidePart.cabal
@@ -9,9 +9,10 @@ Synopsis: XXX
Description:
XXX
build-type: Simple
-cabal-version: >=1.2
+cabal-version: >=1.10
Executable mkUserGuidePart
+ Default-Language: Haskell2010
Main-Is: Main.hs
Build-Depends: base >= 3 && < 5,
ghc
diff --git a/utils/runghc/runghc.cabal.in b/utils/runghc/runghc.cabal.in
index f9cbacca54..fde6b9a4d6 100644
--- a/utils/runghc/runghc.cabal.in
+++ b/utils/runghc/runghc.cabal.in
@@ -10,12 +10,13 @@ Description:
XXX
Category: Development
build-type: Simple
-cabal-version: >=1.2
+cabal-version: >=1.10
Flag base3
Description: Choose the new smaller, split-up base package.
Executable runghc
+ Default-Language: Haskell2010
Main-Is: runghc.hs
if flag(base3)
diff --git a/utils/runghc/runghc.hs b/utils/runghc/runghc.hs
index 5280cb3344..47a6bc57d5 100644
--- a/utils/runghc/runghc.hs
+++ b/utils/runghc/runghc.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, ForeignFunctionInterface #-}
+{-# LANGUAGE CPP #-}
#include "ghcconfig.h"
-----------------------------------------------------------------------------
--
View Lorry Controller Status