summaryrefslogtreecommitdiff
path: root/ghc/utils
diff options
context:
space:
mode:
authorSimon Marlow <simonmar@microsoft.com>2006-04-07 02:05:11 +0000
committerSimon Marlow <simonmar@microsoft.com>2006-04-07 02:05:11 +0000
commit0065d5ab628975892cea1ec7303f968c3338cbe1 (patch)
tree8e2afe0ab48ee33cf95009809d67c9649573ef92 /ghc/utils
parent28a464a75e14cece5db40f2765a29348273ff2d2 (diff)
downloadhaskell-0065d5ab628975892cea1ec7303f968c3338cbe1.tar.gz
Reorganisation of the source tree
Most of the other users of the fptools build system have migrated to Cabal, and with the move to darcs we can now flatten the source tree without losing history, so here goes. The main change is that the ghc/ subdir is gone, and most of what it contained is now at the top level. The build system now makes no pretense at being multi-project, it is just the GHC build system. No doubt this will break many things, and there will be a period of instability while we fix the dependencies. A straightforward build should work, but I haven't yet fixed binary/source distributions. Changes to the Building Guide will follow, too.
Diffstat (limited to 'ghc/utils')
-rw-r--r--ghc/utils/Makefile27
-rw-r--r--ghc/utils/debugNCG/Diff_Gcc_Nat.hs380
-rw-r--r--ghc/utils/debugNCG/Makefile19
-rw-r--r--ghc/utils/debugNCG/README46
-rw-r--r--ghc/utils/ext-core/Check.hs421
-rw-r--r--ghc/utils/ext-core/Core.hs150
-rw-r--r--ghc/utils/ext-core/Driver.hs86
-rw-r--r--ghc/utils/ext-core/Env.hs44
-rw-r--r--ghc/utils/ext-core/Interp.hs450
-rw-r--r--ghc/utils/ext-core/Lex.hs92
-rw-r--r--ghc/utils/ext-core/ParseGlue.hs65
-rw-r--r--ghc/utils/ext-core/Parser.y230
-rw-r--r--ghc/utils/ext-core/Prep.hs151
-rw-r--r--ghc/utils/ext-core/Prims.hs834
-rw-r--r--ghc/utils/ext-core/Printer.hs163
-rw-r--r--ghc/utils/ext-core/README9
-rw-r--r--ghc/utils/genapply/GenApply.hs769
-rw-r--r--ghc/utils/genapply/Makefile25
-rw-r--r--ghc/utils/genprimopcode/Main.hs787
-rw-r--r--ghc/utils/genprimopcode/Makefile19
-rw-r--r--ghc/utils/ghc-pkg/Main.hs1184
-rw-r--r--ghc/utils/ghc-pkg/Makefile113
-rw-r--r--ghc/utils/ghc-pkg/ghc-pkg.sh2
-rw-r--r--ghc/utils/hasktags/HaskTags.hs232
-rw-r--r--ghc/utils/hasktags/Makefile14
-rw-r--r--ghc/utils/hasktags/README33
-rw-r--r--ghc/utils/heap-view/Graph.lhs165
-rw-r--r--ghc/utils/heap-view/HaskXLib.c297
-rw-r--r--ghc/utils/heap-view/HpView.lhs296
-rw-r--r--ghc/utils/heap-view/HpView2.lhs225
-rw-r--r--ghc/utils/heap-view/MAIL67
-rw-r--r--ghc/utils/heap-view/Makefile36
-rw-r--r--ghc/utils/heap-view/Makefile.original48
-rw-r--r--ghc/utils/heap-view/Parse.lhs92
-rw-r--r--ghc/utils/heap-view/README62
-rw-r--r--ghc/utils/heap-view/common-bits35
-rw-r--r--ghc/utils/hp2ps/AreaBelow.c62
-rw-r--r--ghc/utils/hp2ps/AreaBelow.h6
-rw-r--r--ghc/utils/hp2ps/AuxFile.c168
-rw-r--r--ghc/utils/hp2ps/AuxFile.h7
-rw-r--r--ghc/utils/hp2ps/Axes.c241
-rw-r--r--ghc/utils/hp2ps/Axes.h6
-rw-r--r--ghc/utils/hp2ps/CHANGES37
-rw-r--r--ghc/utils/hp2ps/Curves.c165
-rw-r--r--ghc/utils/hp2ps/Curves.h10
-rw-r--r--ghc/utils/hp2ps/Defines.h61
-rw-r--r--ghc/utils/hp2ps/Deviation.c139
-rw-r--r--ghc/utils/hp2ps/Deviation.h7
-rw-r--r--ghc/utils/hp2ps/Dimensions.c203
-rw-r--r--ghc/utils/hp2ps/Dimensions.h22
-rw-r--r--ghc/utils/hp2ps/Error.c59
-rw-r--r--ghc/utils/hp2ps/Error.h8
-rw-r--r--ghc/utils/hp2ps/HpFile.c587
-rw-r--r--ghc/utils/hp2ps/HpFile.h77
-rw-r--r--ghc/utils/hp2ps/Key.c63
-rw-r--r--ghc/utils/hp2ps/Key.h6
-rw-r--r--ghc/utils/hp2ps/Main.c253
-rw-r--r--ghc/utils/hp2ps/Main.h77
-rw-r--r--ghc/utils/hp2ps/Makefile14
-rw-r--r--ghc/utils/hp2ps/Marks.c43
-rw-r--r--ghc/utils/hp2ps/Marks.h6
-rw-r--r--ghc/utils/hp2ps/PsFile.c280
-rw-r--r--ghc/utils/hp2ps/PsFile.h6
-rw-r--r--ghc/utils/hp2ps/README.GHC4
-rw-r--r--ghc/utils/hp2ps/Reorder.c89
-rw-r--r--ghc/utils/hp2ps/Reorder.h8
-rw-r--r--ghc/utils/hp2ps/Scale.c86
-rw-r--r--ghc/utils/hp2ps/Scale.h7
-rw-r--r--ghc/utils/hp2ps/Shade.c130
-rw-r--r--ghc/utils/hp2ps/Shade.h8
-rw-r--r--ghc/utils/hp2ps/TopTwenty.c72
-rw-r--r--ghc/utils/hp2ps/TopTwenty.h6
-rw-r--r--ghc/utils/hp2ps/TraceElement.c96
-rw-r--r--ghc/utils/hp2ps/TraceElement.h6
-rw-r--r--ghc/utils/hp2ps/Utilities.c132
-rw-r--r--ghc/utils/hp2ps/Utilities.h13
-rw-r--r--ghc/utils/hp2ps/hp2ps.1145
-rw-r--r--ghc/utils/hp2ps/makefile.original42
-rw-r--r--ghc/utils/hsc2hs/Main.hs938
-rw-r--r--ghc/utils/hsc2hs/Makefile101
-rw-r--r--ghc/utils/hsc2hs/Makefile.inc7
-rw-r--r--ghc/utils/hsc2hs/Makefile.nhc9848
-rw-r--r--ghc/utils/hsc2hs/hsc2hs.sh13
-rw-r--r--ghc/utils/hsc2hs/template-hsc.h105
-rw-r--r--ghc/utils/hstags/Makefile70
-rw-r--r--ghc/utils/hstags/README10
-rw-r--r--ghc/utils/hstags/hstags-help.c59
-rw-r--r--ghc/utils/hstags/hstags.prl94
-rw-r--r--ghc/utils/hstags/prefix.txt9
-rw-r--r--ghc/utils/parallel/AVG.pl108
-rw-r--r--ghc/utils/parallel/GrAnSim.el432
-rw-r--r--ghc/utils/parallel/Makefile49
-rw-r--r--ghc/utils/parallel/RTS2gran.pl684
-rw-r--r--ghc/utils/parallel/SN.pl280
-rw-r--r--ghc/utils/parallel/SPLIT.pl379
-rw-r--r--ghc/utils/parallel/avg-RTS.pl15
-rw-r--r--ghc/utils/parallel/get_SN.pl40
-rw-r--r--ghc/utils/parallel/ghc-fool-sort.pl23
-rw-r--r--ghc/utils/parallel/ghc-unfool-sort.pl16
-rw-r--r--ghc/utils/parallel/gp-ext-imp.pl86
-rw-r--r--ghc/utils/parallel/gr2RTS.pl138
-rw-r--r--ghc/utils/parallel/gr2ap.bash124
-rw-r--r--ghc/utils/parallel/gr2gran.bash113
-rw-r--r--ghc/utils/parallel/gr2java.pl322
-rw-r--r--ghc/utils/parallel/gr2jv.bash123
-rw-r--r--ghc/utils/parallel/gr2pe.pl1434
-rw-r--r--ghc/utils/parallel/gr2ps.bash169
-rw-r--r--ghc/utils/parallel/gr2qp.pl329
-rw-r--r--ghc/utils/parallel/gran-extr.pl2114
-rw-r--r--ghc/utils/parallel/grs2gr.pl48
-rw-r--r--ghc/utils/parallel/par-aux.pl89
-rw-r--r--ghc/utils/parallel/ps-scale-y.pl188
-rw-r--r--ghc/utils/parallel/qp2ap.pl495
-rw-r--r--ghc/utils/parallel/qp2ps.pl988
-rw-r--r--ghc/utils/parallel/sn_filter.pl92
-rw-r--r--ghc/utils/parallel/stats.pl168
-rw-r--r--ghc/utils/parallel/template.pl141
-rw-r--r--ghc/utils/parallel/tf.pl148
-rw-r--r--ghc/utils/prof/Makefile46
-rw-r--r--ghc/utils/prof/cgprof/Makefile15
-rw-r--r--ghc/utils/prof/cgprof/README7
-rw-r--r--ghc/utils/prof/cgprof/cgprof.c1284
-rw-r--r--ghc/utils/prof/cgprof/cgprof.h82
-rw-r--r--ghc/utils/prof/cgprof/daVinci.c760
-rw-r--r--ghc/utils/prof/cgprof/daVinci.h95
-rw-r--r--ghc/utils/prof/cgprof/main.c436
-rw-r--r--ghc/utils/prof/cgprof/matrix.c98
-rw-r--r--ghc/utils/prof/cgprof/matrix.h42
-rw-r--r--ghc/utils/prof/cgprof/symbol.c115
-rw-r--r--ghc/utils/prof/cgprof/symbol.h58
-rw-r--r--ghc/utils/prof/ghcprof.prl280
-rw-r--r--ghc/utils/prof/icons/Makefile13
-rw-r--r--ghc/utils/prof/icons/absdelta.xbm8
-rw-r--r--ghc/utils/prof/icons/absolute.xbm8
-rw-r--r--ghc/utils/prof/icons/comm.xbm8
-rw-r--r--ghc/utils/prof/icons/commslack.xbm8
-rw-r--r--ghc/utils/prof/icons/comp.xbm8
-rw-r--r--ghc/utils/prof/icons/compress.xbm8
-rw-r--r--ghc/utils/prof/icons/compslack.xbm8
-rw-r--r--ghc/utils/prof/icons/delete.xbm8
-rw-r--r--ghc/utils/prof/icons/help.xbm8
-rw-r--r--ghc/utils/prof/icons/hrel.xbm8
-rw-r--r--ghc/utils/prof/icons/hrelslack.xbm8
-rw-r--r--ghc/utils/prof/icons/jump.xbm8
-rw-r--r--ghc/utils/prof/icons/mycomm.xbm8
-rw-r--r--ghc/utils/prof/icons/oxpara.xbm198
-rw-r--r--ghc/utils/prof/icons/percent.xbm8
-rw-r--r--ghc/utils/prof/icons/reldelta.xbm8
-rw-r--r--ghc/utils/prof/icons/sync.xbm8
-rw-r--r--ghc/utils/prof/icons/time.xbm8
-rw-r--r--ghc/utils/prof/icons/time1.xbm8
-rw-r--r--ghc/utils/prof/icons/uncompress.xbm8
-rw-r--r--ghc/utils/prof/icons/undo.xbm8
-rw-r--r--ghc/utils/prof/icons/wait.xbm8
-rw-r--r--ghc/utils/prof/icons/weightdelta.xbm8
-rw-r--r--ghc/utils/pvm/README4
-rw-r--r--ghc/utils/pvm/debugger.emacs37
-rw-r--r--ghc/utils/pvm/debugger248
-rw-r--r--ghc/utils/runghc/Makefile32
-rw-r--r--ghc/utils/runghc/runghc.hs66
-rw-r--r--ghc/utils/stat2resid/Makefile59
-rw-r--r--ghc/utils/stat2resid/parse-gcstats.prl232
-rw-r--r--ghc/utils/stat2resid/prefix.txt10
-rw-r--r--ghc/utils/stat2resid/process-gcstats.prl45
-rw-r--r--ghc/utils/stat2resid/stat2resid.prl81
-rw-r--r--ghc/utils/touchy/Makefile20
-rw-r--r--ghc/utils/touchy/touchy.c63
-rw-r--r--ghc/utils/unlit/Makefile16
-rw-r--r--ghc/utils/unlit/README8
-rw-r--r--ghc/utils/unlit/unlit.c401
170 files changed, 0 insertions, 26741 deletions
diff --git a/ghc/utils/Makefile b/ghc/utils/Makefile
deleted file mode 100644
index 7348160a74..0000000000
--- a/ghc/utils/Makefile
+++ /dev/null
@@ -1,27 +0,0 @@
-TOP=..
-include $(TOP)/mk/boilerplate.mk
-
-ifneq "$(BIN_DIST_NAME)" ""
-# We're doing a binary-dist, descend into a subset of the dirs.
-SUBDIRS = hp2ps stat2resid unlit
-else
-ifeq "$(BootingFromHc)" "YES"
-SUBDIRS = genapply genprimopcode ghc-pkg unlit
-else
-SUBDIRS = hasktags ghc-pkg hp2ps hsc2hs parallel stat2resid prof unlit genprimopcode genapply runghc
-endif
-endif
-
-ifeq "$(TARGETPLATFORM)" "i386-unknown-mingw32"
-SUBDIRS += touchy
-endif
-
-# hstags died when the new parser was introduced.
-# hstags \
-
-# "heap-view" is not in the list because (a) it requires
-# a Haskell compiler (which you may not have yet), and (b) you are
-# unlikely to want it desperately. It is easy to build once you have
-# a Haskell compiler and if you want it.
-
-include $(TOP)/mk/target.mk
diff --git a/ghc/utils/debugNCG/Diff_Gcc_Nat.hs b/ghc/utils/debugNCG/Diff_Gcc_Nat.hs
deleted file mode 100644
index 02b642821e..0000000000
--- a/ghc/utils/debugNCG/Diff_Gcc_Nat.hs
+++ /dev/null
@@ -1,380 +0,0 @@
-
-module Main where
-import List
-import System
-import Char
-import Array
-
---import IOExts(trace)
-
-type Label = String
-type Code = [String]
-
-pzipWith f [] [] = []
-pzipWith f (a:as) (b:bs) = (f a b) : pzipWith f as bs
-pzipWith f _ _ = error "pzipWith: unbalanced list"
-
-main
- = getArgs >>= \args ->
- --return ["/home/v-julsew/SOLARIS/NCG/fpt/ghc/tests/codeGen/should_run/cg001.s"]
- -- >>= \args ->
- if length args /= 1
- then putStr ("\ndiff_gcc_nat:\n" ++
- " usage: create File.s-gcc and File.s-nat\n" ++
- " then do: diff_gcc_nat File.s > synth.S\n" ++
- " and compile synth.S into your program.\n" ++
- "diff_gcc_nat is to help debug GHC's native code generator;\n" ++
- "it is quite useless for any other purpose. For details, see\n" ++
- " fptools/ghc/utils/debugNCG/README.\n"++
- "\n"
- )
- else
- do
- let [f_root] = args
- f_gcc <- readFile (f_root ++ "-gcc")
- f_nat <- readFile (f_root ++ "-nat")
-
- let split_nat0 = breakOn is_split_line (lines f_nat)
- split_nat = filter (not.null.getLabels) split_nat0
-
- split_markers_present
- = any is_split_line (lines f_nat)
-
- labels_nat = map getLabels split_nat
- labels_cls = map (map breakLabel) labels_nat
-
- labels_merged :: [(Label, [LabelKind])]
- labels_merged = map mergeBroken labels_cls
-
- classified :: [(Label, [LabelKind], [String])]
- classified
- = pzipWith (\ merged text -> (fst merged, snd merged, text))
- labels_merged split_nat
-
- lines_gcc = lines f_gcc
-
- (syncd, gcc_unused)
- = find_correspondings classified lines_gcc
- (ok_syncs, nat_unused)
- = check_syncs syncd
-
- num_ok = length ok_syncs
-
- preamble
- = map (\i -> "#define NATIVE_" ++ show i ++ " 0") [1 .. num_ok]
- ++ ["",
- "#define UNMATCHED_NAT 0",
- "#define UNMATCHED_GCC 1",
- ""]
-
- final
- = preamble
- ++ concat (pzipWith pp_ok_sync ok_syncs [1 .. num_ok])
- ++ ["",
- "//============== unmatched NAT =================",
- "#if UNMATCHED_NAT",
- ""]
- ++ nat_unused
- ++ ["",
- "#endif",
- "",
- "//============== unmatched GCC =================",
- "#if UNMATCHED_GCC"]
- ++ gcc_unused
- ++ ["#endif"
- ]
-
- if split_markers_present
- then putStr (unlines final)
- else putStr ("\ndiff_gcc_nat:\n"
- ++ " fatal error: NCG output doesn't contain any\n"
- ++ " ___ncg_debug_marker marks. Can't continue!\n"
- ++ " To fix: enable these markers in\n"
- ++ " fptools/ghc/compiler/nativeGen/AsmCodeGen.lhs,\n"
- ++ " recompile the compiler, and regenerate the assembly.\n\n")
-
-
-pp_ok_sync :: (Label, [LabelKind], [String], [String])
- -> Int
- -> [String]
-pp_ok_sync (lbl, kinds, nat_code, gcc_code) number
- = reconstruct number nat_code gcc_code
-
-
-check_syncs :: [(Label, [LabelKind], [String], Maybe [String])] -- raw syncd
- -> ( [(Label, [LabelKind], [String], [String])], -- ok syncs
- [String] ) -- nat unsyncd
-
-check_syncs [] = ([],[])
-check_syncs (sync:syncs)
- = let (syncs_ok, syncs_uu) = check_syncs syncs
- in case sync of
- (lbl, kinds, nat, Nothing)
- -> (syncs_ok, nat ++ syncs_uu)
- (lbl, kinds, nat, Just gcc_code)
- -> ((lbl,kinds,nat,gcc_code):syncs_ok, syncs_uu)
-
-
-find_correspondings :: [(Label, [LabelKind], [String])] -- native info
- -> [String] -- gcc initial
- -> ( [(Label, [LabelKind], [String], Maybe [String])],
- [String] )
- -- ( native info + found gcc stuff,
- -- unused gcc stuff )
-
-find_correspondings native gcc_init
- = f native gcc_init
- where
- wurble x (xs, gcc_final) = (x:xs, gcc_final)
-
- f [] gcc_uu = ( [], gcc_uu )
- f (nat:nats) gcc_uu
- = case nat of { (lbl, kinds, nat_code) ->
- case find_corresponding lbl kinds gcc_uu of
- Just (gcc_code, gcc_uu2)
- | gcc_code == gcc_code
- -> --gcc_code `seq` gcc_uu2 `seq`
- wurble (lbl, kinds, nat_code, Just gcc_code) (f nats gcc_uu2)
- Nothing
- -> gcc_uu `seq`
- wurble (lbl, kinds, nat_code, Nothing) (f nats gcc_uu)
- }
-
-
-find_corresponding :: Label -- root
- -> [LabelKind] -- kinds
- -> [String] -- gcc text
- -> Maybe ([String],[String]) -- (found text, gcc leftovers)
-
-find_corresponding root kinds gcc_lines
- = -- Enable the following trace in order to debug pattern matching problems.
- --trace (
- -- case result of
- -- Nothing -> show (root,kinds) ++ "\nNothing\n\n"
- -- Just (found,uu)
- -- -> show (root, kinds) ++ "\n" ++ unlines found ++ "\n\n"
- --)
- result
- where
-
- arr = listArray (1, length gcc_lines) gcc_lines
- pfxMatch ss t
- = let clean_t = filter (not.isSpace) t
- in any (`isPrefixOf` clean_t) ss
-
- result
- = case kinds of
-
- [Vtbl]
- -> let lbl_i = find_label arr (reconstruct_label root Vtbl)
- fst_i = search_back arr lbl_i (pfxMatch [".text"])
- in
- splice arr fst_i lbl_i
-
- [Closure]
- -> let lbl_i = find_label arr (reconstruct_label root Closure)
- fst_i = search_back arr lbl_i (pfxMatch [".data"])
- lst_i = search_fwds arr (lbl_i+1)
- (not . pfxMatch [".long",".uaword",".uahalf"])
- in
- splice arr fst_i (lst_i-1)
-
- [Alt]
- -> let lbl_i = find_label arr (reconstruct_label root Alt)
- fst_i = search_back arr lbl_i (pfxMatch ["."])
- lst_i = search_fwds arr lbl_i (pfxMatch [".d", ".t", ".r", ".g"])
- in
- splice arr fst_i (lst_i-1)
-
- [Dflt]
- -> let lbl_i = find_label arr (reconstruct_label root Dflt)
- fst_i = search_back arr lbl_i (pfxMatch ["."])
- lst_i = search_fwds arr lbl_i (pfxMatch [".d", ".t", ".r", ".g"])
- in
- splice arr fst_i (lst_i-1)
-
- [Info,Entry]
- -> let info_i = find_label arr (reconstruct_label root Info)
- fst_i = search_back arr info_i (pfxMatch [".text"])
- entry_i = find_label arr (reconstruct_label root Entry)
- lst_i = search_fwds arr entry_i (pfxMatch [".d", ".t", ".r", ".g"])
- in
- splice arr fst_i (lst_i-1)
-
- [Info,Entry,Fast k]
- -> let info_i = find_label arr (reconstruct_label root Info)
- fst_i = search_back arr info_i (pfxMatch [".text"])
- fast_i = find_label arr (reconstruct_label root (Fast k))
- lst_i = search_fwds arr fast_i (pfxMatch [".d", ".t", ".r", ".g"])
- in
- splice arr fst_i (lst_i-1)
-
- [Info,Ret]
- -> let info_i = find_label arr (reconstruct_label root Info)
- fst_i = search_back arr info_i (pfxMatch [".text"])
- ret_i = find_label arr (reconstruct_label root Ret)
- lst_i = search_fwds arr ret_i (pfxMatch [".d", ".t", ".r", ".g"])
- in
- splice arr fst_i (lst_i-1)
-
- [Srt]
- -> let lbl_i = find_label arr (reconstruct_label root Srt)
- fst_i = search_back arr lbl_i (pfxMatch [".text",".data"])
- lst_i = search_fwds arr (lbl_i+1)
- (not . pfxMatch [".long",".uaword",".uahalf"])
- in
- splice arr fst_i (lst_i-1)
-
- [CTbl]
- -> let lbl_i = find_label arr (reconstruct_label root CTbl)
- fst_i = search_back arr lbl_i (pfxMatch [".text"])
- lst_i = search_fwds arr (lbl_i+1)
- (not . pfxMatch [".long",".uaword",".uahalf"])
- in
- splice arr fst_i (lst_i-1)
-
- [Init]
- -> let lbl_i = find_label arr (reconstruct_label root Init)
- fst_i = search_back arr lbl_i (pfxMatch [".data"])
- lst_i = search_fwds arr lbl_i (pfxMatch [".d", ".t", ".r", ".g"])
- in
- splice arr fst_i (lst_i-1)
- other
- -> error ("find_corresponding: " ++ show kinds)
-
-
-search_back :: Array Int String -> Int -> (String -> Bool) -> Int
-search_back code start_ix pred
- = let test_ixs = [start_ix, start_ix-1 .. fst (bounds code)]
- in case dropWhile (not . pred . (code !)) test_ixs of
- (ok:_) -> ok
- [] -> fst (bounds code) - 1
-
-search_fwds :: Array Int String -> Int -> (String -> Bool) -> Int
-search_fwds code start_ix pred
- = let test_ixs = [start_ix .. snd (bounds code)]
- in case dropWhile (not . pred . (code !)) test_ixs of
- (ok:_) -> ok
- [] -> snd (bounds code) + 1
-
-
-find_label :: Array Int String -> Label -> Int
-find_label code lbl
- = --trace (unlines (map show (assocs code))) (
- case [idx | (idx, lbl2) <- assocs code, lbl == lbl2] of
- [idx] -> idx
- other -> error ("find_label `" ++ lbl ++ "'\n")
- --)
-
-reconstruct_label :: Label -> LabelKind -> Label
-reconstruct_label root Init
- = "__stginit_" ++ root ++ ":"
-reconstruct_label root kind
- = root ++ "_" ++ pp kind ++ ":"
- where
- pp Info = "info"
- pp Entry = "entry"
- pp Closure = "closure"
- pp Alt = "alt"
- pp Vtbl = "vtbl"
- pp Default = "dflt"
- pp (Fast i) = "fast" ++ show i
- pp Dflt = "dflt"
- pp Srt = "srt"
- pp Ret = "ret"
- pp CTbl = "tbl"
-
-splice :: Array Int String -> Int -> Int -> Maybe ([String],[String])
-splice gcc_code lo hi
- | lo <= hi && clo <= lo && hi <= chi
- = Just (map (gcc_code !) ix_used,
- map (gcc_code !) (low_ix_uu ++ high_ix_uu))
- | otherwise
- = error "splice"
- where
- (clo,chi) = bounds gcc_code
- low_ix_uu = [clo .. lo-1]
- high_ix_uu = [hi+1 .. chi]
- ix_used = [lo .. hi]
-
-------------------------------------
-
-getLabels :: [Label] -> [Label]
-getLabels = sort . nub . filter is_interesting_label
-
-data LabelKind
- = Info | Entry | Fast Int | Closure | Alt | Vtbl | Default
- | Dflt | Srt | Ret | CTbl | Init
- deriving (Eq, Ord, Show)
-
-breakLabel :: Label -> (Label,LabelKind)
-breakLabel s
- = let sr = reverse s
- kr = takeWhile (/= '_') sr
- mr = drop (1 + length kr) sr
- m = reverse mr
- k = reverse kr
- kind
- | take 4 k == "fast"
- = Fast (read (takeWhile isDigit (drop 4 k)))
- | otherwise
- = case k of
- "info:" -> Info
- "entry:" -> Entry
- "closure:" -> Closure
- "alt:" -> Alt
- "vtbl:" -> Vtbl
- "dflt:" -> Dflt
- "srt:" -> Srt
- "ret:" -> Ret
- "tbl:" -> CTbl
- _ -> error ("breakLabel: " ++ show (s,k,m))
- in
- if head m == '_' && dropWhile (== '_') m == "stginit"
- then (init k, Init)
- else (m, kind)
-
-mergeBroken :: [(Label,LabelKind)] -> (Label, [LabelKind])
-mergeBroken pairs
- = let (roots, kinds) = unzip pairs
- ok = all (== (head roots)) (tail roots)
- && length kinds == length (nub kinds)
- in
- if ok
- then (head roots, sort kinds)
- else error ("mergeBroken: " ++ show pairs)
-
-
-reconstruct :: Int -> Code -> Code -> Code
-reconstruct number nat_code gcc_code
- = ["",
- "//------------------------------------------"]
- ++ map (comment ("//-- ")) (getLabels gcc_code)
- ++ ["", "#if NATIVE_" ++ show number, "//nat version", ""]
- ++ nat_code
- ++ ["", "#else", "//gcc version", ""]
- ++ gcc_code
- ++ ["", "#endif"]
-
-comment str x = str ++ x
-
------------------------------------------------------
-split_marker = "___ncg_debug_marker"
-
-is_split_line s
- = let m = split_marker
- in take 19 s == m || take 19 (drop 2 s) == m
-
-is_interesting_label s
- = not (null s)
- && not (any isSpace s)
- && last s == ':'
- && '_' `elem` s
-
-breakOn :: (a -> Bool) -> [a] -> [[a]]
-breakOn p [] = []
-breakOn p xs
- = let ys = takeWhile (not . p) xs
- rest = drop (1 + length ys) xs
- in
- if null ys then breakOn p rest else ys : breakOn p rest
diff --git a/ghc/utils/debugNCG/Makefile b/ghc/utils/debugNCG/Makefile
deleted file mode 100644
index 0ea51a1e06..0000000000
--- a/ghc/utils/debugNCG/Makefile
+++ /dev/null
@@ -1,19 +0,0 @@
-TOP=../..
-include $(TOP)/mk/boilerplate.mk
-
-INSTALL_PROGS += diff_gcc_nat
-
-SRC_HC_OPTS += -O
-OBJS = Diff_Gcc_Nat.o
-
-CLEAN_FILES += diff_gcc_nat
-
-all :: diff_gcc_nat
-
-diff_gcc_nat: Diff_Gcc_Nat.o
- $(HC) -o $@ $(HC_OPTS) $(LD_OPTS) $(OBJS)
-
-CLEAN_FILES += diff_gcc_nat
-CLEAN_FILES += $(OBJS)
-
-include $(TOP)/mk/target.mk
diff --git a/ghc/utils/debugNCG/README b/ghc/utils/debugNCG/README
deleted file mode 100644
index 90eb2197cc..0000000000
--- a/ghc/utils/debugNCG/README
+++ /dev/null
@@ -1,46 +0,0 @@
-
-This program is to assist in debugging GHC's native code generator.
-
-Finding out which particular code block the native code block has
-mis-compiled is like finding a needle in a haystack. This program
-solves that problem. Given an assembly file created by the NCG (call
-it Foo.s-nat) and one created by gcc (Foo.s-gcc), then
-
- diff_gcc_nat Foo.s
-
-will pair up corresponding code blocks, wrap each one in an #if and
-spew the entire result out to stdout, along with a load of #defines at
-the top, which you can use to switch between the gcc and ncg versions
-of each code block. Pipe this into a .S file (I use the name
-synth.S). Then you can used the #defines to do a binary search to
-quickly arrive at the code block(s) which have been mis-compiled.
-
-Note that the .S suffix tells ghc that this assembly file needs to be
-cpp'd; so you should be sure to use .S and not .s.
-
-The pattern matching can cope with the fact that the code blocks are
-in different orders in the two files. The result synth.S is ordered
-by in the order of the -nat input; the -gcc input is searched for the
-corresponding stuff. The search relies on spotting artefacts like
-section changes, so is fragile and susceptible to minor changes in the
-gcc's assembly output. If that happens, it's well worth the effort
-fixing this program, rather than trying to infer what's wrong with the
-NCG directly from the -nat input.
-
-This is only known to work on x86 linux, sparc-solaris (and possibly
-cygwin). No idea if the same matching heuristics will work on other
-archs -- if not, we need to have multiple versions of this program, on
-a per-arch basis.
-
-One other IMPORTANT thing: you *must* enable stg-split-markers in the
-native code generator output, otherwise this won't work at all --
-since it won't be able to find out where the code blocks start and
-end. Enable these markers by compiling ghc (or at least
-ghc/compiler/nativeGen/AsmCodeGen.lhs, function nativeCodeGen) with
--DDEBUG_NCG enabled.
-
-Matching is simple but inefficient; diff-ing a large module could take
-a minute or two.
-
-JRS, 29 June 2000
-
diff --git a/ghc/utils/ext-core/Check.hs b/ghc/utils/ext-core/Check.hs
deleted file mode 100644
index a9a3eac8f4..0000000000
--- a/ghc/utils/ext-core/Check.hs
+++ /dev/null
@@ -1,421 +0,0 @@
-module Check where
-
-import Monad
-import Core
-import Printer
-import List
-import Env
-
-{- Checking is done in a simple error monad. In addition to
- allowing errors to be captured, this makes it easy to guarantee
- that checking itself has been completed for an entire module. -}
-
-data CheckResult a = OkC a | FailC String
-
-instance Monad CheckResult where
- OkC a >>= k = k a
- FailC s >>= k = fail s
- return = OkC
- fail = FailC
-
-require :: Bool -> String -> CheckResult ()
-require False s = fail s
-require True _ = return ()
-
-requireM :: CheckResult Bool -> String -> CheckResult ()
-requireM cond s =
- do b <- cond
- require b s
-
-{- Environments. -}
-type Tvenv = Env Tvar Kind -- type variables (local only)
-type Tcenv = Env Tcon Kind -- type constructors
-type Tsenv = Env Tcon ([Tvar],Ty) -- type synonyms
-type Cenv = Env Dcon Ty -- data constructors
-type Venv = Env Var Ty -- values
-type Menv = Env Mname Envs -- modules
-data Envs = Envs {tcenv_::Tcenv,tsenv_::Tsenv,cenv_::Cenv,venv_::Venv} -- all the exportable envs
-
-{- Extend an environment, checking for illegal shadowing of identifiers. -}
-extendM :: (Ord a, Show a) => Env a b -> (a,b) -> CheckResult (Env a b)
-extendM env (k,d) =
- case elookup env k of
- Just _ -> fail ("multiply-defined identifier: " ++ show k)
- Nothing -> return (eextend env (k,d))
-
-lookupM :: (Ord a, Show a) => Env a b -> a -> CheckResult b
-lookupM env k =
- case elookup env k of
- Just v -> return v
- Nothing -> fail ("undefined identifier: " ++ show k)
-
-{- Main entry point. -}
-checkModule :: Menv -> Module -> CheckResult Menv
-checkModule globalEnv (Module mn tdefs vdefgs) =
- do (tcenv,tsenv) <- foldM checkTdef0 (eempty,eempty) tdefs
- cenv <- foldM (checkTdef tcenv) eempty tdefs
- (e_venv,l_venv) <- foldM (checkVdefg True (tcenv,tsenv,eempty,cenv)) (eempty,eempty) vdefgs
- return (eextend globalEnv (mn,Envs{tcenv_=tcenv,tsenv_=tsenv,cenv_=cenv,venv_=e_venv}))
- where
-
- checkTdef0 :: (Tcenv,Tsenv) -> Tdef -> CheckResult (Tcenv,Tsenv)
- checkTdef0 (tcenv,tsenv) tdef = ch tdef
- where
- ch (Data (m,c) tbs _) =
- do require (m == mn) ("wrong module name in data type declaration:\n" ++ show tdef)
- tcenv' <- extendM tcenv (c,k)
- return (tcenv',tsenv)
- where k = foldr Karrow Klifted (map snd tbs)
- ch (Newtype (m,c) tbs rhs) =
- do require (m == mn) ("wrong module name in newtype declaration:\n" ++ show tdef)
- tcenv' <- extendM tcenv (c,k)
- tsenv' <- case rhs of
- Nothing -> return tsenv
- Just rep -> extendM tsenv (c,(map fst tbs,rep))
- return (tcenv', tsenv')
- where k = foldr Karrow Klifted (map snd tbs)
-
- checkTdef :: Tcenv -> Cenv -> Tdef -> CheckResult Cenv
- checkTdef tcenv cenv = ch
- where
- ch (Data (_,c) utbs cdefs) =
- do cbinds <- mapM checkCdef cdefs
- foldM extendM cenv cbinds
- where checkCdef (cdef@(Constr (m,dcon) etbs ts)) =
- do require (m == mn) ("wrong module name in constructor declaration:\n" ++ show cdef)
- tvenv <- foldM extendM eempty tbs
- ks <- mapM (checkTy (tcenv,tvenv)) ts
- mapM_ (\k -> require (baseKind k)
- ("higher-order kind in:\n" ++ show cdef ++ "\n" ++
- "kind: " ++ show k) ) ks
- return (dcon,t)
- where tbs = utbs ++ etbs
- t = foldr Tforall
- (foldr tArrow
- (foldl Tapp (Tcon (mn,c))
- (map (Tvar . fst) utbs)) ts) tbs
- ch (tdef@(Newtype c tbs (Just t))) =
- do tvenv <- foldM extendM eempty tbs
- k <- checkTy (tcenv,tvenv) t
- require (k==Klifted) ("bad kind:\n" ++ show tdef)
- return cenv
- ch (tdef@(Newtype c tbs Nothing)) =
- {- should only occur for recursive Newtypes -}
- return cenv
-
-
- checkVdefg :: Bool -> (Tcenv,Tsenv,Tvenv,Cenv) -> (Venv,Venv) -> Vdefg -> CheckResult (Venv,Venv)
- checkVdefg top_level (tcenv,tsenv,tvenv,cenv) (e_venv,l_venv) vdefg =
- case vdefg of
- Rec vdefs ->
- do e_venv' <- foldM extendM e_venv e_vts
- l_venv' <- foldM extendM l_venv l_vts
- let env' = (tcenv,tsenv,tvenv,cenv,e_venv',l_venv')
- mapM_ (\ (vdef@(Vdef ((m,v),t,e))) ->
- do require (m == "" || m == mn) ("wrong module name in value definition:\n" ++ show vdef)
- k <- checkTy (tcenv,tvenv) t
- require (k==Klifted) ("unlifted kind in:\n" ++ show vdef)
- t' <- checkExp env' e
- requireM (equalTy tsenv t t')
- ("declared type doesn't match expression type in:\n" ++ show vdef ++ "\n" ++
- "declared type: " ++ show t ++ "\n" ++
- "expression type: " ++ show t')) vdefs
- return (e_venv',l_venv')
- where e_vts = [ (v,t) | Vdef ((m,v),t,_) <- vdefs, m /= "" ]
- l_vts = [ (v,t) | Vdef (("",v),t,_) <- vdefs]
- Nonrec (vdef@(Vdef ((m,v),t,e))) ->
- do require (m == "" || m == mn) ("wrong module name in value definition:\n" ++ show vdef)
- k <- checkTy (tcenv,tvenv) t
- require (k /= Kopen) ("open kind in:\n" ++ show vdef)
- require ((not top_level) || (k /= Kunlifted)) ("top-level unlifted kind in:\n" ++ show vdef)
- t' <- checkExp (tcenv,tsenv,tvenv,cenv,e_venv,l_venv) e
- requireM (equalTy tsenv t t')
- ("declared type doesn't match expression type in:\n" ++ show vdef ++ "\n" ++
- "declared type: " ++ show t ++ "\n" ++
- "expression type: " ++ show t')
- if m == "" then
- do l_venv' <- extendM l_venv (v,t)
- return (e_venv,l_venv')
- else
- do e_venv' <- extendM e_venv (v,t)
- return (e_venv',l_venv)
-
- checkExp :: (Tcenv,Tsenv,Tvenv,Cenv,Venv,Venv) -> Exp -> CheckResult Ty
- checkExp (tcenv,tsenv,tvenv,cenv,e_venv,l_venv) = ch
- where
- ch e0 =
- case e0 of
- Var qv ->
- qlookupM venv_ e_venv l_venv qv
- Dcon qc ->
- qlookupM cenv_ cenv eempty qc
- Lit l ->
- checkLit l
- Appt e t ->
- do t' <- ch e
- k' <- checkTy (tcenv,tvenv) t
- case t' of
- Tforall (tv,k) t0 ->
- do require (k' <= k)
- ("kind doesn't match at type application in:\n" ++ show e0 ++ "\n" ++
- "operator kind: " ++ show k ++ "\n" ++
- "operand kind: " ++ show k')
- return (substl [tv] [t] t0)
- _ -> fail ("bad operator type in type application:\n" ++ show e0 ++ "\n" ++
- "operator type: " ++ show t')
- App e1 e2 ->
- do t1 <- ch e1
- t2 <- ch e2
- case t1 of
- Tapp(Tapp(Tcon tc) t') t0 | tc == tcArrow ->
- do requireM (equalTy tsenv t2 t')
- ("type doesn't match at application in:\n" ++ show e0 ++ "\n" ++
- "operator type: " ++ show t' ++ "\n" ++
- "operand type: " ++ show t2)
- return t0
- _ -> fail ("bad operator type at application in:\n" ++ show e0 ++ "\n" ++
- "operator type: " ++ show t1)
- Lam (Tb tb) e ->
- do tvenv' <- extendM tvenv tb
- t <- checkExp (tcenv,tsenv,tvenv',cenv,e_venv,l_venv) e
- return (Tforall tb t)
- Lam (Vb (vb@(_,vt))) e ->
- do k <- checkTy (tcenv,tvenv) vt
- require (baseKind k)
- ("higher-order kind in:\n" ++ show e0 ++ "\n" ++
- "kind: " ++ show k)
- l_venv' <- extendM l_venv vb
- t <- checkExp (tcenv,tsenv,tvenv,cenv,e_venv,l_venv') e
- require (not (isUtupleTy vt)) ("lambda-bound unboxed tuple in:\n" ++ show e0)
- return (tArrow vt t)
- Let vdefg e ->
- do (e_venv',l_venv') <- checkVdefg False (tcenv,tsenv,tvenv,cenv) (e_venv,l_venv) vdefg
- checkExp (tcenv,tsenv,tvenv,cenv,e_venv',l_venv') e
- Case e (v,t) alts ->
- do t' <- ch e
- checkTy (tcenv,tvenv) t
- requireM (equalTy tsenv t t')
- ("scrutinee declared type doesn't match expression type in:\n" ++ show e0 ++ "\n" ++
- "declared type: " ++ show t ++ "\n" ++
- "expression type: " ++ show t')
- case (reverse alts) of
- (Acon c _ _ _):as ->
- let ok ((Acon c _ _ _):as) cs = do require (notElem c cs)
- ("duplicate alternative in case:\n" ++ show e0)
- ok as (c:cs)
- ok ((Alit _ _):_) _ = fail ("invalid alternative in constructor case:\n" ++ show e0)
- ok [Adefault _] _ = return ()
- ok (Adefault _:_) _ = fail ("misplaced default alternative in case:\n" ++ show e0)
- ok [] _ = return ()
- in ok as [c]
- (Alit l _):as ->
- let ok ((Acon _ _ _ _):_) _ = fail ("invalid alternative in literal case:\n" ++ show e0)
- ok ((Alit l _):as) ls = do require (notElem l ls)
- ("duplicate alternative in case:\n" ++ show e0)
- ok as (l:ls)
- ok [Adefault _] _ = return ()
- ok (Adefault _:_) _ = fail ("misplaced default alternative in case:\n" ++ show e0)
- ok [] _ = fail ("missing default alternative in literal case:\n" ++ show e0)
- in ok as [l]
- [Adefault _] -> return ()
- [] -> fail ("no alternatives in case:\n" ++ show e0)
- l_venv' <- extendM l_venv (v,t)
- t:ts <- mapM (checkAlt (tcenv,tsenv,tvenv,cenv,e_venv,l_venv') t) alts
- bs <- mapM (equalTy tsenv t) ts
- require (and bs)
- ("alternative types don't match in:\n" ++ show e0 ++ "\n" ++
- "types: " ++ show (t:ts))
- return t
- Coerce t e ->
- do ch e
- checkTy (tcenv,tvenv) t
- return t
- Note s e ->
- ch e
- External _ t ->
- do checkTy (tcenv,eempty) t {- external types must be closed -}
- return t
-
- checkAlt :: (Tcenv,Tsenv,Tvenv,Cenv,Venv,Venv) -> Ty -> Alt -> CheckResult Ty
- checkAlt (env@(tcenv,tsenv,tvenv,cenv,e_venv,l_venv)) t0 = ch
- where
- ch a0 =
- case a0 of
- Acon qc etbs vbs e ->
- do let uts = f t0
- where f (Tapp t0 t) = f t0 ++ [t]
- f _ = []
- ct <- qlookupM cenv_ cenv eempty qc
- let (tbs,ct_args0,ct_res0) = splitTy ct
- {- get universals -}
- let (utbs,etbs') = splitAt (length uts) tbs
- let utvs = map fst utbs
- {- check existentials -}
- let (etvs,eks) = unzip etbs
- let (etvs',eks') = unzip etbs'
- require (eks == eks')
- ("existential kinds don't match in:\n" ++ show a0 ++ "\n" ++
- "kinds declared in data constructor: " ++ show eks ++
- "kinds declared in case alternative: " ++ show eks')
- tvenv' <- foldM extendM tvenv etbs
- {- check term variables -}
- let vts = map snd vbs
- mapM_ (\vt -> require ((not . isUtupleTy) vt)
- ("pattern-bound unboxed tuple in:\n" ++ show a0 ++ "\n" ++
- "pattern type: " ++ show vt)) vts
- vks <- mapM (checkTy (tcenv,tvenv')) vts
- mapM_ (\vk -> require (baseKind vk)
- ("higher-order kind in:\n" ++ show a0 ++ "\n" ++
- "kind: " ++ show vk)) vks
- let (ct_res:ct_args) = map (substl (utvs++etvs') (uts++(map Tvar etvs))) (ct_res0:ct_args0)
- zipWithM_
- (\ct_arg vt ->
- requireM (equalTy tsenv ct_arg vt)
- ("pattern variable type doesn't match constructor argument type in:\n" ++ show a0 ++ "\n" ++
- "pattern variable type: " ++ show ct_arg ++ "\n" ++
- "constructor argument type: " ++ show vt)) ct_args vts
- requireM (equalTy tsenv ct_res t0)
- ("pattern constructor type doesn't match scrutinee type in:\n" ++ show a0 ++ "\n" ++
- "pattern constructor type: " ++ show ct_res ++ "\n" ++
- "scrutinee type: " ++ show t0)
- l_venv' <- foldM extendM l_venv vbs
- t <- checkExp (tcenv,tsenv,tvenv',cenv,e_venv,l_venv') e
- checkTy (tcenv,tvenv) t {- check that existentials don't escape in result type -}
- return t
- Alit l e ->
- do t <- checkLit l
- requireM (equalTy tsenv t t0)
- ("pattern type doesn't match scrutinee type in:\n" ++ show a0 ++ "\n" ++
- "pattern type: " ++ show t ++ "\n" ++
- "scrutinee type: " ++ show t0)
- checkExp env e
- Adefault e ->
- checkExp env e
-
- checkTy :: (Tcenv,Tvenv) -> Ty -> CheckResult Kind
- checkTy (tcenv,tvenv) = ch
- where
- ch (Tvar tv) = lookupM tvenv tv
- ch (Tcon qtc) = qlookupM tcenv_ tcenv eempty qtc
- ch (t@(Tapp t1 t2)) =
- do k1 <- ch t1
- k2 <- ch t2
- case k1 of
- Karrow k11 k12 ->
- do require (k2 <= k11)
- ("kinds don't match in type application: " ++ show t ++ "\n" ++
- "operator kind: " ++ show k11 ++ "\n" ++
- "operand kind: " ++ show k2)
- return k12
- _ -> fail ("applied type has non-arrow kind: " ++ show t)
- ch (Tforall tb t) =
- do tvenv' <- extendM tvenv tb
- checkTy (tcenv,tvenv') t
-
- {- Type equality modulo newtype synonyms. -}
- equalTy :: Tsenv -> Ty -> Ty -> CheckResult Bool
- equalTy tsenv t1 t2 =
- do t1' <- expand t1
- t2' <- expand t2
- return (t1' == t2')
- where expand (Tvar v) = return (Tvar v)
- expand (Tcon qtc) = return (Tcon qtc)
- expand (Tapp t1 t2) =
- do t2' <- expand t2
- expapp t1 [t2']
- expand (Tforall tb t) =
- do t' <- expand t
- return (Tforall tb t')
- expapp (t@(Tcon (m,tc))) ts =
- do env <- mlookupM tsenv_ tsenv eempty m
- case elookup env tc of
- Just (formals,rhs) | (length formals) == (length ts) -> return (substl formals ts rhs)
- _ -> return (foldl Tapp t ts)
- expapp (Tapp t1 t2) ts =
- do t2' <- expand t2
- expapp t1 (t2':ts)
- expapp t ts =
- do t' <- expand t
- return (foldl Tapp t' ts)
-
-
- mlookupM :: (Envs -> Env a b) -> Env a b -> Env a b -> Mname -> CheckResult (Env a b)
- mlookupM selector external_env local_env m =
- if m == "" then
- return local_env
- else if m == mn then
- return external_env
- else
- case elookup globalEnv m of
- Just env' -> return (selector env')
- Nothing -> fail ("undefined module name: " ++ show m)
-
- qlookupM :: (Ord a, Show a) => (Envs -> Env a b) -> Env a b -> Env a b -> (Mname,a) -> CheckResult b
- qlookupM selector external_env local_env (m,k) =
- do env <- mlookupM selector external_env local_env m
- lookupM env k
-
-
-checkLit :: Lit -> CheckResult Ty
-checkLit lit =
- case lit of
- Lint _ t ->
- do {- require (elem t [tIntzh, {- tInt32zh,tInt64zh, -} tWordzh, {- tWord32zh,tWord64zh, -} tAddrzh, tCharzh])
- ("invalid int literal: " ++ show lit ++ "\n" ++ "type: " ++ show t) -}
- return t
- Lrational _ t ->
- do {- require (elem t [tFloatzh,tDoublezh])
- ("invalid rational literal: " ++ show lit ++ "\n" ++ "type: " ++ show t) -}
- return t
- Lchar _ t ->
- do {- require (t == tCharzh)
- ("invalid char literal: " ++ show lit ++ "\n" ++ "type: " ++ show t) -}
- return t
- Lstring _ t ->
- do {- require (t == tAddrzh)
- ("invalid string literal: " ++ show lit ++ "\n" ++ "type: " ++ show t) -}
- return t
-
-{- Utilities -}
-
-{- Split off tbs, arguments and result of a (possibly abstracted) arrow type -}
-splitTy :: Ty -> ([Tbind],[Ty],Ty)
-splitTy (Tforall tb t) = (tb:tbs,ts,tr)
- where (tbs,ts,tr) = splitTy t
-splitTy (Tapp(Tapp(Tcon tc) t0) t) | tc == tcArrow = (tbs,t0:ts,tr)
- where (tbs,ts,tr) = splitTy t
-splitTy t = ([],[],t)
-
-
-{- Simultaneous substitution on types for type variables,
- renaming as neceessary to avoid capture.
- No checks for correct kindedness. -}
-substl :: [Tvar] -> [Ty] -> Ty -> Ty
-substl tvs ts t = f (zip tvs ts) t
- where
- f env t0 =
- case t0 of
- Tcon _ -> t0
- Tvar v -> case lookup v env of
- Just t1 -> t1
- Nothing -> t0
- Tapp t1 t2 -> Tapp (f env t1) (f env t2)
- Tforall (t,k) t1 ->
- if t `elem` free then
- Tforall (t',k) (f ((t,Tvar t'):env) t1)
- else
- Tforall (t,k) (f (filter ((/=t).fst) env) t1)
- where free = foldr union [] (map (freeTvars.snd) env)
- t' = freshTvar free
-
-{- Return free tvars in a type -}
-freeTvars :: Ty -> [Tvar]
-freeTvars (Tcon _) = []
-freeTvars (Tvar v) = [v]
-freeTvars (Tapp t1 t2) = (freeTvars t1) `union` (freeTvars t2)
-freeTvars (Tforall (t,_) t1) = delete t (freeTvars t1)
-
-{- Return any tvar *not* in the argument list. -}
-freshTvar :: [Tvar] -> Tvar
-freshTvar tvs = maximum ("":tvs) ++ "x" -- one simple way!
-
diff --git a/ghc/utils/ext-core/Core.hs b/ghc/utils/ext-core/Core.hs
deleted file mode 100644
index 2f94f80b3e..0000000000
--- a/ghc/utils/ext-core/Core.hs
+++ /dev/null
@@ -1,150 +0,0 @@
-module Core where
-
-import List (elemIndex)
-
-data Module
- = Module Mname [Tdef] [Vdefg]
-
-data Tdef
- = Data (Qual Tcon) [Tbind] [Cdef]
- | Newtype (Qual Tcon) [Tbind] (Maybe Ty)
-
-data Cdef
- = Constr (Qual Dcon) [Tbind] [Ty]
-
-data Vdefg
- = Rec [Vdef]
- | Nonrec Vdef
-
-newtype Vdef = Vdef (Qual Var,Ty,Exp)
-
-data Exp
- = Var (Qual Var)
- | Dcon (Qual Dcon)
- | Lit Lit
- | App Exp Exp
- | Appt Exp Ty
- | Lam Bind Exp
- | Let Vdefg Exp
- | Case Exp Vbind [Alt] {- non-empty list -}
- | Coerce Ty Exp
- | Note String Exp
- | External String Ty
-
-data Bind
- = Vb Vbind
- | Tb Tbind
-
-data Alt
- = Acon (Qual Dcon) [Tbind] [Vbind] Exp
- | Alit Lit Exp
- | Adefault Exp
-
-type Vbind = (Var,Ty)
-type Tbind = (Tvar,Kind)
-
-data Ty
- = Tvar Tvar
- | Tcon (Qual Tcon)
- | Tapp Ty Ty
- | Tforall Tbind Ty
-
-data Kind
- = Klifted
- | Kunlifted
- | Kopen
- | Karrow Kind Kind
- deriving (Eq)
-
-data Lit
- = Lint Integer Ty
- | Lrational Rational Ty
- | Lchar Char Ty
- | Lstring String Ty
- deriving (Eq) -- with nearlyEqualTy
-
-type Mname = Id
-type Var = Id
-type Tvar = Id
-type Tcon = Id
-type Dcon = Id
-
-type Qual t = (Mname,t)
-
-type Id = String
-
-{- Doesn't expand out fully applied newtype synonyms
- (for which an environment is needed). -}
-nearlyEqualTy t1 t2 = eqTy [] [] t1 t2
- where eqTy e1 e2 (Tvar v1) (Tvar v2) =
- case (elemIndex v1 e1,elemIndex v2 e2) of
- (Just i1, Just i2) -> i1 == i2
- (Nothing, Nothing) -> v1 == v2
- _ -> False
- eqTy e1 e2 (Tcon c1) (Tcon c2) = c1 == c2
- eqTy e1 e2 (Tapp t1a t1b) (Tapp t2a t2b) =
- eqTy e1 e2 t1a t2a && eqTy e1 e2 t1b t2b
- eqTy e1 e2 (Tforall (tv1,tk1) t1) (Tforall (tv2,tk2) t2) =
- tk1 == tk2 && eqTy (tv1:e1) (tv2:e2) t1 t2
- eqTy _ _ _ _ = False
-instance Eq Ty where (==) = nearlyEqualTy
-
-
-subKindOf :: Kind -> Kind -> Bool
-_ `subKindOf` Kopen = True
-k1 `subKindOf` k2 = k1 == k2 -- doesn't worry about higher kinds
-
-instance Ord Kind where (<=) = subKindOf
-
-baseKind :: Kind -> Bool
-baseKind (Karrow _ _ ) = False
-baseKind _ = True
-
-primMname = "PrelGHC"
-
-tcArrow :: Qual Tcon
-tcArrow = (primMname, "ZLzmzgZR")
-
-tArrow :: Ty -> Ty -> Ty
-tArrow t1 t2 = Tapp (Tapp (Tcon tcArrow) t1) t2
-
-ktArrow :: Kind
-ktArrow = Karrow Kopen (Karrow Kopen Klifted)
-
-{- Unboxed tuples -}
-
-maxUtuple :: Int
-maxUtuple = 100
-
-tcUtuple :: Int -> Qual Tcon
-tcUtuple n = (primMname,"Z"++ (show n) ++ "H")
-
-ktUtuple :: Int -> Kind
-ktUtuple n = foldr Karrow Kunlifted (replicate n Kopen)
-
-tUtuple :: [Ty] -> Ty
-tUtuple ts = foldl Tapp (Tcon (tcUtuple (length ts))) ts
-
-isUtupleTy :: Ty -> Bool
-isUtupleTy (Tapp t _) = isUtupleTy t
-isUtupleTy (Tcon tc) = tc `elem` [tcUtuple n | n <- [1..maxUtuple]]
-isUtupleTy _ = False
-
-dcUtuple :: Int -> Qual Dcon
-dcUtuple n = (primMname,"ZdwZ" ++ (show n) ++ "H")
-
-isUtupleDc :: Qual Dcon -> Bool
-isUtupleDc dc = dc `elem` [dcUtuple n | n <- [1..maxUtuple]]
-
-dcUtupleTy :: Int -> Ty
-dcUtupleTy n =
- foldr ( \tv t -> Tforall (tv,Kopen) t)
- (foldr ( \tv t -> tArrow (Tvar tv) t)
- (tUtuple (map Tvar tvs)) tvs)
- tvs
- where tvs = map ( \i -> ("a" ++ (show i))) [1..n]
-
-utuple :: [Ty] -> [Exp] -> Exp
-utuple ts es = foldl App (foldl Appt (Dcon (dcUtuple (length es))) ts) es
-
-
diff --git a/ghc/utils/ext-core/Driver.hs b/ghc/utils/ext-core/Driver.hs
deleted file mode 100644
index 2328eca22a..0000000000
--- a/ghc/utils/ext-core/Driver.hs
+++ /dev/null
@@ -1,86 +0,0 @@
-{- A simple driver that loads, typechecks, prepares, re-typechecks, and interprets the
- GHC standard Prelude modules and an application module called Main.
-
- Note that, if compiled under GHC, this requires a very large heap to run!
--}
-
-import Monad
-import Core
-import Printer
-import Parser
-import Lex
-import ParseGlue
-import Env
-import Prims
-import Check
-import Prep
-import Interp
-
-process (senv,modules) f =
- do putStrLn ("Processing " ++ f)
- s <- readFile f
- case parse s 1 of
- OkP m -> do putStrLn "Parse succeeded"
- {- writeFile (f ++ ".parsed") (show m) -}
- case checkModule senv m of
- OkC senv' ->
- do putStrLn "Check succeeded"
- let m' = prepModule senv' m
- {- writeFile (f ++ ".prepped") (show m') -}
- case checkModule senv m' of
- OkC senv'' ->
- do putStrLn "Recheck succeeded"
- return (senv'',modules ++ [m'])
- FailC s ->
- do putStrLn ("Recheck failed: " ++ s)
- error "quit"
- FailC s ->
- do putStrLn ("Check failed: " ++ s)
- error "quit"
- FailP s -> do putStrLn ("Parse failed: " ++ s)
- error "quit"
-
-main = do (_,modules) <- foldM process (initialEnv,[]) flist
- let result = evalProgram modules
- putStrLn ("Result = " ++ show result)
- putStrLn "All done"
- where flist = ["PrelBase.hcr",
- "PrelMaybe.hcr",
- "PrelTup.hcr",
- "PrelList.hcr",
- "PrelShow.hcr",
- "PrelEnum.hcr",
- "PrelNum.hcr",
- "PrelST.hcr",
- "PrelArr.hcr",
- "PrelDynamic.hcr",
- "PrelReal.hcr",
- "PrelFloat.hcr",
- "PrelRead.hcr",
- "PrelIOBase.hcr",
- "PrelException.hcr",
- "PrelErr.hcr",
- "PrelConc.hcr",
- "PrelPtr.hcr",
- "PrelByteArr.hcr",
- "PrelPack.hcr",
- "PrelBits.hcr",
- "PrelWord.hcr",
- "PrelInt.hcr",
- "PrelCTypes.hcr",
- "PrelStable.hcr",
- "PrelCTypesISO.hcr",
- "Monad.hcr",
- "PrelStorable.hcr",
- "PrelMarshalAlloc.hcr",
- "PrelMarshalUtils.hcr",
- "PrelMarshalArray.hcr",
- "PrelCString.hcr",
- "PrelMarshalError.hcr",
- "PrelCError.hcr",
- "PrelPosix.hcr",
- "PrelHandle.hcr",
- "PrelIO.hcr",
- "Prelude.hcr",
- "Main.hcr" ]
-
diff --git a/ghc/utils/ext-core/Env.hs b/ghc/utils/ext-core/Env.hs
deleted file mode 100644
index 6f6973c558..0000000000
--- a/ghc/utils/ext-core/Env.hs
+++ /dev/null
@@ -1,44 +0,0 @@
-{- Environments.
- Uses lists for simplicity and to make the semantics clear.
- A real implementation should use balanced trees or hash tables.
--}
-
-module Env (Env,
- eempty,
- elookup,
- eextend,
- edomain,
- efromlist,
- efilter,
- eremove)
-where
-
-import List
-
-data Env a b = Env [(a,b)]
- deriving (Show)
-
-eempty :: Env a b
-eempty = Env []
-
-{- In case of duplicates, returns most recently added entry. -}
-elookup :: (Eq a) => Env a b -> a -> Maybe b
-elookup (Env l) k = lookup k l
-
-{- May hide existing entries. -}
-eextend :: Env a b -> (a,b) -> Env a b
-eextend (Env l) (k,d) = Env ((k,d):l)
-
-edomain :: (Eq a) => Env a b -> [a]
-edomain (Env l) = nub (map fst l)
-
-{- In case of duplicates, first entry hides others. -}
-efromlist :: [(a,b)] -> Env a b
-efromlist l = Env l
-
-eremove :: (Eq a) => Env a b -> a -> Env a b
-eremove (Env l) k = Env (filter ((/= k).fst) l)
-
-efilter :: Env a b -> (a -> Bool) -> Env a b
-efilter (Env l) p = Env (filter (p.fst) l)
-
diff --git a/ghc/utils/ext-core/Interp.hs b/ghc/utils/ext-core/Interp.hs
deleted file mode 100644
index 1988ae9cf3..0000000000
--- a/ghc/utils/ext-core/Interp.hs
+++ /dev/null
@@ -1,450 +0,0 @@
-{-
-Interprets the subset of well-typed Core programs for which
- (a) All constructor and primop applications are saturated
- (b) All non-trivial expressions of unlifted kind ('#') are
- scrutinized in a Case expression.
-
-This is by no means a "minimal" interpreter, in the sense that considerably
-simpler machinary could be used to run programs and get the right answers.
-However, it attempts to mirror the intended use of various Core constructs,
-particularly with respect to heap usage. So considerations such as unboxed
-tuples, sharing, trimming, black-holing, etc. are all covered.
-The only major omission is garbage collection.
-
-Just a sampling of primitive types and operators are included.
--}
-
-module Interp where
-
-import Core
-import Printer
-import Monad
-import Env
-import List
-import Char
-import Prims
-
-data HeapValue =
- Hconstr Dcon [Value] -- constructed value (note: no qualifier needed!)
- | Hclos Venv Var Exp -- function closure
- | Hthunk Venv Exp -- unevaluated thunk
- deriving (Show)
-
-type Ptr = Int
-
-data Value =
- Vheap Ptr -- heap pointer (boxed)
- | Vimm PrimValue -- immediate primitive value (unboxed)
- | Vutuple [Value] -- unboxed tuples
- deriving (Show)
-
-type Venv = Env Var Value -- values of vars
-
-data PrimValue = -- values of the (unboxed) primitive types
- PCharzh Integer -- actually 31-bit unsigned
- | PIntzh Integer -- actually WORD_SIZE_IN_BITS-bit signed
- | PWordzh Integer -- actually WORD_SIZE_IN_BITS-bit unsigned
- | PAddrzh Integer -- actually native pointer size
- | PFloatzh Rational -- actually 32-bit
- | PDoublezh Rational -- actually 64-bit
--- etc., etc.
- deriving (Eq,Show)
-
-type Menv = Env Mname Venv -- modules
-
-initialGlobalEnv :: Menv
-initialGlobalEnv =
- efromlist
- [(primMname,efromlist [("realWorldzh",Vimm (PIntzh 0))])]
-
-{- Heap management. -}
-{- Nothing is said about garbage collection. -}
-
-data Heap = Heap Ptr (Env Ptr HeapValue) -- last cell allocated; environment of allocated cells
- deriving (Show)
-
-hallocate :: Heap -> HeapValue -> (Heap,Ptr)
-hallocate (Heap last contents) v =
- let next = last+1
- in (Heap next (eextend contents (next,v)),next)
-
-hupdate :: Heap -> Ptr -> HeapValue -> Heap
-hupdate (Heap last contents) p v =
- Heap last (eextend contents (p,v))
-
-hlookup:: Heap -> Ptr -> HeapValue
-hlookup (Heap _ contents) p =
- case elookup contents p of
- Just v -> v
- Nothing -> error "Missing heap entry (black hole?)"
-
-hremove :: Heap -> Ptr -> Heap
-hremove (Heap last contents) p =
- Heap last (eremove contents p)
-
-hempty :: Heap
-hempty = Heap 0 eempty
-
-{- The evaluation monad manages the heap and the possiblity
- of exceptions. -}
-
-type Exn = Value
-
-newtype Eval a = Eval (Heap -> (Heap,Either a Exn))
-
-instance Monad Eval where
- (Eval m) >>= k = Eval (
- \h -> case m h of
- (h',Left x) -> case k x of
- Eval k' -> k' h'
- (h',Right exn) -> (h',Right exn))
- return x = Eval (\h -> (h,Left x))
-
-hallocateE :: HeapValue -> Eval Ptr
-hallocateE v = Eval (\ h ->
- let (h',p) = hallocate h v
- in (h', Left p))
-
-hupdateE :: Ptr -> HeapValue -> Eval ()
-hupdateE p v = Eval (\h -> (hupdate h p v,Left ()))
-
-hlookupE :: Ptr -> Eval HeapValue
-hlookupE p = Eval (\h -> (h,Left (hlookup h p)))
-
-hremoveE :: Ptr -> Eval ()
-hremoveE p = Eval (\h -> (hremove h p, Left ()))
-
-raiseE :: Exn -> Eval a
-raiseE exn = Eval (\h -> (h,Right exn))
-
-catchE :: Eval a -> (Exn -> Eval a) -> Eval a
-catchE (Eval m) f = Eval
- (\h -> case m h of
- (h',Left x) -> (h',Left x)
- (h',Right exn) ->
- case f exn of
- Eval f' -> f' h')
-
-runE :: Eval a -> a
-runE (Eval f) =
- case f hempty of
- (_,Left v) -> v
- (_,Right exn) -> error ("evaluation failed with uncaught exception: " ++ show exn)
-
-
-{- Main entry point -}
-evalProgram :: [Module] -> Value
-evalProgram modules =
- runE(
- do globalEnv <- foldM evalModule initialGlobalEnv modules
- Vutuple [_,v] <- evalExp globalEnv eempty (App (Var ("Main","main")) (Var (primMname,"realWorldzh")))
- return v)
-
-{- Environments:
-
-Evaluating a module just fills an environment with suspensions for all
-the external top-level values; it doesn't actually do any evaluation
-or look anything up.
-
-By the time we actually evaluate an expression, all external values from
-all modules will be in globalEnv. So evaluation just maintains an environment
-of non-external values (top-level or local). In particular, only non-external
-values end up in closures (all other values are accessible from globalEnv.)
-
-Throughout:
-
-- globalEnv contains external values (all top-level) from all modules seen so far.
-
-In evalModule:
-
-- e_venv contains external values (all top-level) seen so far in current module
-- l_venv contains non-external values (top-level or local)
- seen so far in current module.
-In evalExp:
-
-- env contains non-external values (top-level or local) seen so far
- in current expression.
--}
-
-
-evalModule :: Menv -> Module -> Eval Menv
-evalModule globalEnv (Module mn tdefs vdefgs) =
- do (e_venv,l_venv) <- foldM evalVdef (eempty,eempty) vdefgs
- return (eextend globalEnv (mn,e_venv))
- where
- evalVdef :: (Venv,Venv) -> Vdefg -> Eval (Venv,Venv)
- evalVdef (e_env,l_env) (Nonrec(Vdef((m,x),t,e))) =
- do p <- hallocateE (suspendExp l_env e)
- let heaps =
- if m == "" then
- (e_env,eextend l_env (x,Vheap p))
- else
- (eextend e_env (x,Vheap p),l_env)
- return heaps
- evalVdef (e_env,l_env) (Rec vdefs) =
- do l_vs0 <- mapM preallocate l_xs
- let l_env' = foldl eextend l_env (zip l_xs l_vs0)
- let l_hs = map (suspendExp l_env') l_es
- mapM_ reallocate (zip l_vs0 l_hs)
- let e_hs = map (suspendExp l_env') e_es
- e_vs <- mapM allocate e_hs
- let e_env' = foldl eextend e_env (zip e_xs e_vs)
- return (e_env',l_env')
- where
- (l_xs,l_es) = unzip [(x,e) | Vdef(("",x),_,e) <- vdefs]
- (e_xs,e_es) = unzip [(x,e) | Vdef((m,x),_,e) <- vdefs, m /= ""]
- preallocate _ =
- do p <- hallocateE undefined
- return (Vheap p)
- reallocate (Vheap p0,h) =
- hupdateE p0 h
- allocate h =
- do p <- hallocateE h
- return (Vheap p)
-
- suspendExp:: Venv -> Exp -> HeapValue
- suspendExp env (Lam (Vb(x,_)) e) = Hclos env' x e
- where env' = thin env (delete x (freevarsExp e))
- suspendExp env e = Hthunk env' e
- where env' = thin env (freevarsExp e)
-
-
-evalExp :: Menv -> Venv -> Exp -> Eval Value
-evalExp globalEnv env (Var qv) =
- let v = qlookup globalEnv env qv
- in case v of
- Vheap p ->
- do z <- hlookupE p -- can fail due to black-holing
- case z of
- Hthunk env' e ->
- do hremoveE p -- black-hole
- w@(Vheap p') <- evalExp globalEnv env' e -- result is guaranteed to be boxed!
- h <- hlookupE p'
- hupdateE p h
- return w
- _ -> return v -- return pointer to Hclos or Hconstr
- _ -> return v -- return Vimm or Vutuple
-evalExp globalEnv env (Lit l) = return (Vimm (evalLit l))
-evalExp globalEnv env (Dcon (_,c)) =
- do p <- hallocateE (Hconstr c [])
- return (Vheap p)
-
-evalExp globalEnv env (App e1 e2) = evalApp env e1 [e2]
- where
- evalApp :: Venv -> Exp -> [Exp] -> Eval Value
- evalApp env (App e1 e2) es = evalApp env e1 (e2:es)
- evalApp env (op @(Dcon (qdc@(m,c)))) es =
- do vs <- suspendExps globalEnv env es
- if isUtupleDc qdc then
- return (Vutuple vs)
- else
- {- allocate a thunk -}
- do p <- hallocateE (Hconstr c vs)
- return (Vheap p)
- evalApp env (op @ (Var(m,p))) es | m == primMname =
- do vs <- evalExps globalEnv env es
- case (p,vs) of
- ("raisezh",[exn]) -> raiseE exn
- ("catchzh",[body,handler,rws]) ->
- catchE (apply body [rws])
- (\exn -> apply handler [exn,rws])
- _ -> evalPrimop p vs
- evalApp env (External s _) es =
- do vs <- evalExps globalEnv env es
- evalExternal s vs
- evalApp env (Appt e _) es = evalApp env e es
- evalApp env (Lam (Tb _) e) es = evalApp env e es
- evalApp env (Coerce _ e) es = evalApp env e es
- evalApp env (Note _ e) es = evalApp env e es
- evalApp env e es =
- {- e must now evaluate to a closure -}
- do vs <- suspendExps globalEnv env es
- vop <- evalExp globalEnv env e
- apply vop vs
-
- apply :: Value -> [Value] -> Eval Value
- apply vop [] = return vop
- apply (Vheap p) (v:vs) =
- do Hclos env' x b <- hlookupE p
- v' <- evalExp globalEnv (eextend env' (x,v)) b
- apply v' vs
-
-
-evalExp globalEnv env (Appt e _) = evalExp globalEnv env e
-evalExp globalEnv env (Lam (Vb(x,_)) e) =
- do p <- hallocateE (Hclos env' x e)
- return (Vheap p)
- where env' = thin env (delete x (freevarsExp e))
-evalExp globalEnv env (Lam _ e) = evalExp globalEnv env e
-evalExp globalEnv env (Let vdef e) =
- do env' <- evalVdef globalEnv env vdef
- evalExp globalEnv env' e
- where
- evalVdef :: Menv -> Venv -> Vdefg -> Eval Venv
- evalVdef globalEnv env (Nonrec(Vdef((m,x),t,e))) =
- do v <- suspendExp globalEnv env e
- return (eextend env (x,v))
- evalVdef globalEnv env (Rec vdefs) =
- do vs0 <- mapM preallocate xs
- let env' = foldl eextend env (zip xs vs0)
- vs <- suspendExps globalEnv env' es
- mapM_ reallocate (zip vs0 vs)
- return env'
- where
- (xs,es) = unzip [(x,e) | Vdef((_,x),_,e) <- vdefs]
- preallocate _ =
- do p <- hallocateE (Hconstr "UGH" [])
- return (Vheap p)
- reallocate (Vheap p0,Vheap p) =
- do h <- hlookupE p
- hupdateE p0 h
-
-evalExp globalEnv env (Case e (x,_) alts) =
- do z <- evalExp globalEnv env e
- let env' = eextend env (x,z)
- case z of
- Vheap p ->
- do h <- hlookupE p -- can fail due to black-holing
- case h of
- Hconstr dcon vs -> evalDcAlt env' dcon vs (reverse alts)
- _ -> evalDefaultAlt env' alts
- Vutuple vs ->
- evalUtupleAlt env' vs (reverse alts)
- Vimm pv ->
- evalLitAlt env' pv (reverse alts)
- where
- evalDcAlt :: Venv -> Dcon -> [Value] -> [Alt] -> Eval Value
- evalDcAlt env dcon vs alts =
- f alts
- where
- f ((Acon (_,dcon') _ xs e):as) =
- if dcon == dcon' then
- evalExp globalEnv (foldl eextend env (zip (map fst xs) vs)) e
- else f as
- f [Adefault e] =
- evalExp globalEnv env e
- f _ = error "impossible Case-evalDcAlt"
-
- evalUtupleAlt :: Venv -> [Value] -> [Alt] -> Eval Value
- evalUtupleAlt env vs [Acon _ _ xs e] =
- evalExp globalEnv (foldl eextend env (zip (map fst xs) vs)) e
-
- evalLitAlt :: Venv -> PrimValue -> [Alt] -> Eval Value
- evalLitAlt env pv alts =
- f alts
- where
- f ((Alit lit e):as) =
- let pv' = evalLit lit
- in if pv == pv' then
- evalExp globalEnv env e
- else f as
- f [Adefault e] =
- evalExp globalEnv env e
- f _ = error "impossible Case-evalLitAlt"
-
- evalDefaultAlt :: Venv -> [Alt] -> Eval Value
- evalDefaultAlt env [Adefault e] = evalExp globalEnv env e
-
-evalExp globalEnv env (Coerce _ e) = evalExp globalEnv env e
-evalExp globalEnv env (Note _ e) = evalExp globalEnv env e
-evalExp globalEnv env (External s t) = evalExternal s []
-
-evalExps :: Menv -> Venv -> [Exp] -> Eval [Value]
-evalExps globalEnv env = mapM (evalExp globalEnv env)
-
-suspendExp:: Menv -> Venv -> Exp -> Eval Value
-suspendExp globalEnv env (Var qv) = return (qlookup globalEnv env qv)
-suspendExp globalEnv env (Lit l) = return (Vimm (evalLit l))
-suspendExp globalEnv env (Lam (Vb(x,_)) e) =
- do p <- hallocateE (Hclos env' x e)
- return (Vheap p)
- where env' = thin env (delete x (freevarsExp e))
-suspendExp globalEnv env (Lam _ e) = suspendExp globalEnv env e
-suspendExp globalEnv env (Appt e _) = suspendExp globalEnv env e
-suspendExp globalEnv env (Coerce _ e) = suspendExp globalEnv env e
-suspendExp globalEnv env (Note _ e) = suspendExp globalEnv env e
-suspendExp globalEnv env (External s _) = evalExternal s []
-suspendExp globalEnv env e =
- do p <- hallocateE (Hthunk env' e)
- return (Vheap p)
- where env' = thin env (freevarsExp e)
-
-suspendExps :: Menv -> Venv -> [Exp] -> Eval [Value]
-suspendExps globalEnv env = mapM (suspendExp globalEnv env)
-
-mlookup :: Menv -> Venv -> Mname -> Venv
-mlookup _ env "" = env
-mlookup globalEnv _ m =
- case elookup globalEnv m of
- Just env' -> env'
- Nothing -> error ("undefined module name: " ++ m)
-
-qlookup :: Menv -> Venv -> (Mname,Var) -> Value
-qlookup globalEnv env (m,k) =
- case elookup (mlookup globalEnv env m) k of
- Just v -> v
- Nothing -> error ("undefined identifier: " ++ show m ++ "." ++ show k)
-
-evalPrimop :: Var -> [Value] -> Eval Value
-evalPrimop "zpzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = return (Vimm (PIntzh (i1+i2)))
-evalPrimop "zmzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = return (Vimm (PIntzh (i1-i2)))
-evalPrimop "ztzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = return (Vimm (PIntzh (i1*i2)))
-evalPrimop "zgzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = mkBool (i1 > i2)
-evalPrimop "remIntzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = return (Vimm (PIntzh (i1 `rem` i2)))
--- etc.
-evalPrimop p vs = error ("undefined primop: " ++ p)
-
-evalExternal :: String -> [Value] -> Eval Value
--- etc.
-evalExternal s vs = error "evalExternal undefined for now" -- etc.,etc.
-
-evalLit :: Lit -> PrimValue
-evalLit l =
- case l of
- Lint i (Tcon(_,"Intzh")) -> PIntzh i
- Lint i (Tcon(_,"Wordzh")) -> PWordzh i
- Lint i (Tcon(_,"Addrzh")) -> PAddrzh i
- Lint i (Tcon(_,"Charzh")) -> PCharzh i
- Lrational r (Tcon(_,"Floatzh")) -> PFloatzh r
- Lrational r (Tcon(_,"Doublezh")) -> PDoublezh r
- Lchar c (Tcon(_,"Charzh")) -> PCharzh (toEnum (ord c))
- Lstring s (Tcon(_,"Addrzh")) -> PAddrzh 0 -- should really be address of non-heap copy of C-format string s
-
-{- Utilities -}
-
-mkBool True =
- do p <- hallocateE (Hconstr "ZdwTrue" [])
- return (Vheap p)
-mkBool False =
- do p <- hallocateE (Hconstr "ZdwFalse" [])
- return (Vheap p)
-
-thin env vars = efilter env (`elem` vars)
-
-{- Return the free non-external variables in an expression. -}
-
-freevarsExp :: Exp -> [Var]
-freevarsExp (Var ("",v)) = [v]
-freevarsExp (Var qv) = []
-freevarsExp (Dcon _) = []
-freevarsExp (Lit _) = []
-freevarsExp (App e1 e2) = freevarsExp e1 `union` freevarsExp e2
-freevarsExp (Appt e t) = freevarsExp e
-freevarsExp (Lam (Vb(v,_)) e) = delete v (freevarsExp e)
-freevarsExp (Lam _ e) = freevarsExp e
-freevarsExp (Let vdefg e) = freevarsVdefg vdefg `union` freevarsExp e
- where freevarsVdefg (Rec vdefs) = (foldl union [] (map freevarsExp es)) \\ vs
- where (vs,es) = unzip [(v,e) | Vdef((_,v),_,e) <- vdefs]
- freevarsVdefg (Nonrec (Vdef (_,_,e))) = freevarsExp e
-freevarsExp (Case e (v,_) as) = freevarsExp e `union` [v] `union` freevarsAlts as
- where freevarsAlts alts = foldl union [] (map freevarsAlt alts)
- freevarsAlt (Acon _ _ vbs e) = freevarsExp e \\ (map fst vbs)
- freevarsAlt (Alit _ e) = freevarsExp e
- freevarsAlt (Adefault e) = freevarsExp e
-freevarsExp (Coerce _ e) = freevarsExp e
-freevarsExp (Note _ e) = freevarsExp e
-freevarsExp (External _ _) = []
-
-
-
-
diff --git a/ghc/utils/ext-core/Lex.hs b/ghc/utils/ext-core/Lex.hs
deleted file mode 100644
index ad9d2eb00f..0000000000
--- a/ghc/utils/ext-core/Lex.hs
+++ /dev/null
@@ -1,92 +0,0 @@
-module Lex where
-
-import ParseGlue
-import Ratio
-import Char
-
-isNameChar c = isAlpha c || isDigit c || (c == '_') || (c == '\'')
-isKeywordChar c = isAlpha c || (c == '_')
-
-lexer :: (Token -> P a) -> P a
-lexer cont [] = cont TKEOF []
-lexer cont ('\n':cs) = \line -> lexer cont cs (line+1)
-lexer cont ('-':'>':cs) = cont TKrarrow cs
-lexer cont (c:cs)
- | isSpace c = lexer cont cs
- | isLower c || (c == '_') = lexName cont TKname (c:cs)
- | isUpper c = lexName cont TKcname (c:cs)
- | isDigit c || (c == '-') = lexNum cont (c:cs)
-lexer cont ('%':cs) = lexKeyword cont cs
-lexer cont ('\'':cs) = lexChar cont cs
-lexer cont ('\"':cs) = lexString [] cont cs
-lexer cont ('#':cs) = cont TKhash cs
-lexer cont ('(':cs) = cont TKoparen cs
-lexer cont (')':cs) = cont TKcparen cs
-lexer cont ('{':cs) = cont TKobrace cs
-lexer cont ('}':cs) = cont TKcbrace cs
-lexer cont ('=':cs) = cont TKeq cs
-lexer cont (':':':':cs) = cont TKcoloncolon cs
-lexer cont ('*':cs) = cont TKstar cs
-lexer cont ('.':cs) = cont TKdot cs
-lexer cont ('\\':cs) = cont TKlambda cs
-lexer cont ('/':'\\':cs) = cont TKbiglambda cs
-lexer cont ('@':cs) = cont TKat cs
-lexer cont ('?':cs) = cont TKquestion cs
-lexer cont (';':cs) = cont TKsemicolon cs
-lexer cont (c:cs) = failP "invalid character" [c]
-
-lexChar cont ('\\':'x':h1:h0:'\'':cs)
- | isHexEscape [h1,h0] = cont (TKchar (hexToChar h1 h0)) cs
-lexChar cont ('\\':cs) = failP "invalid char character" ('\\':(take 10 cs))
-lexChar cont ('\'':cs) = failP "invalid char character" ['\'']
-lexChar cont ('\"':cs) = failP "invalid char character" ['\"']
-lexChar cont (c:'\'':cs) = cont (TKchar c) cs
-
-lexString s cont ('\\':'x':h1:h0:cs)
- | isHexEscape [h1,h0] = lexString (s++[hexToChar h1 h0]) cont cs
-lexString s cont ('\\':cs) = failP "invalid string character" ['\\']
-lexString s cont ('\'':cs) = failP "invalid string character" ['\'']
-lexString s cont ('\"':cs) = cont (TKstring s) cs
-lexString s cont (c:cs) = lexString (s++[c]) cont cs
-
-isHexEscape = all (\c -> isHexDigit c && (isDigit c || isLower c))
-
-hexToChar h1 h0 =
- chr(
- (digitToInt h1) * 16 +
- (digitToInt h0))
-
-
-lexNum cont cs =
- case cs of
- ('-':cs) -> f (-1) cs
- _ -> f 1 cs
- where f sgn cs =
- case span isDigit cs of
- (digits,'.':c:rest) | isDigit c ->
- cont (TKrational (numer % denom)) rest'
- where (fpart,rest') = span isDigit (c:rest)
- denom = 10^(length fpart)
- numer = sgn * ((read digits) * denom + (read fpart))
- (digits,rest) -> cont (TKinteger (sgn * (read digits))) rest
-
-lexName cont cstr cs = cont (cstr name) rest
- where (name,rest) = span isNameChar cs
-
-lexKeyword cont cs =
- case span isKeywordChar cs of
- ("module",rest) -> cont TKmodule rest
- ("data",rest) -> cont TKdata rest
- ("newtype",rest) -> cont TKnewtype rest
- ("forall",rest) -> cont TKforall rest
- ("rec",rest) -> cont TKrec rest
- ("let",rest) -> cont TKlet rest
- ("in",rest) -> cont TKin rest
- ("case",rest) -> cont TKcase rest
- ("of",rest) -> cont TKof rest
- ("coerce",rest) -> cont TKcoerce rest
- ("note",rest) -> cont TKnote rest
- ("external",rest) -> cont TKexternal rest
- ("_",rest) -> cont TKwild rest
- _ -> failP "invalid keyword" ('%':cs)
-
diff --git a/ghc/utils/ext-core/ParseGlue.hs b/ghc/utils/ext-core/ParseGlue.hs
deleted file mode 100644
index 3dde0c3d75..0000000000
--- a/ghc/utils/ext-core/ParseGlue.hs
+++ /dev/null
@@ -1,65 +0,0 @@
-module ParseGlue where
-
-data ParseResult a = OkP a | FailP String
-type P a = String -> Int -> ParseResult a
-
-thenP :: P a -> (a -> P b) -> P b
-m `thenP` k = \ s l ->
- case m s l of
- OkP a -> k a s l
- FailP s -> FailP s
-
-returnP :: a -> P a
-returnP m _ _ = OkP m
-
-failP :: String -> P a
-failP s s' _ = FailP (s ++ ":" ++ s')
-
-data Token =
- TKmodule
- | TKdata
- | TKnewtype
- | TKforall
- | TKrec
- | TKlet
- | TKin
- | TKcase
- | TKof
- | TKcoerce
- | TKnote
- | TKexternal
- | TKwild
- | TKoparen
- | TKcparen
- | TKobrace
- | TKcbrace
- | TKhash
- | TKeq
- | TKcoloncolon
- | TKstar
- | TKrarrow
- | TKlambda
- | TKbiglambda
- | TKat
- | TKdot
- | TKquestion
- | TKsemicolon
- | TKname String
- | TKcname String
- | TKinteger Integer
- | TKrational Rational
- | TKstring String
- | TKchar Char
- | TKEOF
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/ghc/utils/ext-core/Parser.y b/ghc/utils/ext-core/Parser.y
deleted file mode 100644
index 1e1c6a3592..0000000000
--- a/ghc/utils/ext-core/Parser.y
+++ /dev/null
@@ -1,230 +0,0 @@
-{
-module Parser ( parse ) where
-
-import Core
-import ParseGlue
-import Lex
-
-}
-
-%name parse
-%tokentype { Token }
-
-%token
- '%module' { TKmodule }
- '%data' { TKdata }
- '%newtype' { TKnewtype }
- '%forall' { TKforall }
- '%rec' { TKrec }
- '%let' { TKlet }
- '%in' { TKin }
- '%case' { TKcase }
- '%of' { TKof }
- '%coerce' { TKcoerce }
- '%note' { TKnote }
- '%external' { TKexternal }
- '%_' { TKwild }
- '(' { TKoparen }
- ')' { TKcparen }
- '{' { TKobrace }
- '}' { TKcbrace }
- '#' { TKhash}
- '=' { TKeq }
- '::' { TKcoloncolon }
- '*' { TKstar }
- '->' { TKrarrow }
- '\\' { TKlambda}
- '@' { TKat }
- '.' { TKdot }
- '?' { TKquestion}
- ';' { TKsemicolon }
- NAME { TKname $$ }
- CNAME { TKcname $$ }
- INTEGER { TKinteger $$ }
- RATIONAL { TKrational $$ }
- STRING { TKstring $$ }
- CHAR { TKchar $$ }
-
-%monad { P } { thenP } { returnP }
-%lexer { lexer } { TKEOF }
-
-%%
-
-module :: { Module }
- : '%module' mname tdefs vdefgs
- { Module $2 $3 $4 }
-
-tdefs :: { [Tdef] }
- : {- empty -} {[]}
- | tdef ';' tdefs {$1:$3}
-
-tdef :: { Tdef }
- : '%data' qcname tbinds '=' '{' cons1 '}'
- { Data $2 $3 $6 }
- | '%newtype' qcname tbinds trep
- { Newtype $2 $3 $4 }
-
-trep :: { Maybe Ty }
- : {- empty -} {Nothing}
- | '=' ty { Just $2 }
-
-tbind :: { Tbind }
- : name { ($1,Klifted) }
- | '(' name '::' akind ')'
- { ($2,$4) }
-
-tbinds :: { [Tbind] }
- : {- empty -} { [] }
- | tbind tbinds { $1:$2 }
-
-
-vbind :: { Vbind }
- : '(' name '::' ty')' { ($2,$4) }
-
-vbinds :: { [Vbind] }
- : {-empty -} { [] }
- | vbind vbinds { $1:$2 }
-
-bind :: { Bind }
- : '@' tbind { Tb $2 }
- | vbind { Vb $1 }
-
-binds1 :: { [Bind] }
- : bind { [$1] }
- | bind binds1 { $1:$2 }
-
-attbinds :: { [Tbind] }
- : {- empty -} { [] }
- | '@' tbind attbinds
- { $2:$3 }
-
-akind :: { Kind }
- : '*' {Klifted}
- | '#' {Kunlifted}
- | '?' {Kopen}
- | '(' kind ')' { $2 }
-
-kind :: { Kind }
- : akind { $1 }
- | akind '->' kind
- { Karrow $1 $3 }
-
-cons1 :: { [Cdef] }
- : con { [$1] }
- | con ';' cons1 { $1:$3 }
-
-con :: { Cdef }
- : qcname attbinds atys
- { Constr $1 $2 $3 }
-
-atys :: { [Ty] }
- : {- empty -} { [] }
- | aty atys { $1:$2 }
-
-aty :: { Ty }
- : name { Tvar $1 }
- | qcname { Tcon $1 }
- | '(' ty ')' { $2 }
-
-
-bty :: { Ty }
- : aty { $1 }
- | bty aty { Tapp $1 $2 }
-
-ty :: { Ty }
- : bty {$1}
- | bty '->' ty
- { tArrow $1 $3 }
- | '%forall' tbinds '.' ty
- { foldr Tforall $4 $2 }
-
-vdefgs :: { [Vdefg] }
- : {- empty -} { [] }
- | vdefg ';' vdefgs {$1:$3 }
-
-vdefg :: { Vdefg }
- : '%rec' '{' vdefs1 '}'
- { Rec $3 }
- | vdef { Nonrec $1}
-
-vdefs1 :: { [Vdef] }
- : vdef { [$1] }
- | vdef ';' vdefs1 { $1:$3 }
-
-vdef :: { Vdef }
- : qname '::' ty '=' exp
- { Vdef ($1,$3,$5) }
-
-aexp :: { Exp }
- : qname { Var $1 }
- | qcname { Dcon $1 }
- | lit { Lit $1 }
- | '(' exp ')' { $2 }
-
-fexp :: { Exp }
- : fexp aexp { App $1 $2 }
- | fexp '@' aty { Appt $1 $3 }
- | aexp { $1 }
-
-exp :: { Exp }
- : fexp { $1 }
- | '\\' binds1 '->' exp
- { foldr Lam $4 $2 }
- | '%let' vdefg '%in' exp
- { Let $2 $4 }
- | '%case' aexp '%of' vbind '{' alts1 '}'
- { Case $2 $4 $6 }
- | '%coerce' aty exp
- { Coerce $2 $3 }
- | '%note' STRING exp
- { Note $2 $3 }
- | '%external' STRING aty
- { External $2 $3 }
-
-alts1 :: { [Alt] }
- : alt { [$1] }
- | alt ';' alts1 { $1:$3 }
-
-alt :: { Alt }
- : qcname attbinds vbinds '->' exp
- { Acon $1 $2 $3 $5 }
- | lit '->' exp
- { Alit $1 $3 }
- | '%_' '->' exp
- { Adefault $3 }
-
-lit :: { Lit }
- : '(' INTEGER '::' aty ')'
- { Lint $2 $4 }
- | '(' RATIONAL '::' aty ')'
- { Lrational $2 $4 }
- | '(' CHAR '::' aty ')'
- { Lchar $2 $4 }
- | '(' STRING '::' aty ')'
- { Lstring $2 $4 }
-
-name :: { Id }
- : NAME { $1 }
-
-cname :: { Id }
- : CNAME { $1 }
-
-mname :: { Id }
- : CNAME { $1 }
-
-qname :: { (Id,Id) }
- : name { ("",$1) }
- | mname '.' name
- { ($1,$3) }
-
-qcname :: { (Id,Id) }
- : mname '.' cname
- { ($1,$3) }
-
-
-{
-
-happyError :: P a
-happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l
-
-}
diff --git a/ghc/utils/ext-core/Prep.hs b/ghc/utils/ext-core/Prep.hs
deleted file mode 100644
index ee65eaaba2..0000000000
--- a/ghc/utils/ext-core/Prep.hs
+++ /dev/null
@@ -1,151 +0,0 @@
-{-
-Preprocess a module to normalize it in the following ways:
- (1) Saturate all constructor and primop applications.
- (2) Arrange that any non-trivial expression of unlifted kind ('#')
- is turned into the scrutinee of a Case.
-After these preprocessing steps, Core can be interpreted (or given an operational semantics)
- ignoring type information almost completely.
--}
-
-
-module Prep where
-
-import Prims
-import Core
-import Printer
-import Env
-import Check
-
-primArgTys :: Env Var [Ty]
-primArgTys = efromlist (map f Prims.primVals)
- where f (v,t) = (v,atys)
- where (_,atys,_) = splitTy t
-
-prepModule :: Menv -> Module -> Module
-prepModule globalEnv (Module mn tdefs vdefgs) =
- Module mn tdefs vdefgs'
- where
- (_,vdefgs') = foldl prepTopVdefg (eempty,[]) vdefgs
-
- prepTopVdefg (venv,vdefgs) vdefg = (venv',vdefgs ++ [vdefg'])
- where (venv',vdefg') = prepVdefg (venv,eempty) vdefg
-
- prepVdefg (env@(venv,_)) (Nonrec(Vdef(("",x),t,e))) =
- (eextend venv (x,t), Nonrec(Vdef(("",x),t,prepExp env e)))
- prepVdefg (env@(venv,_)) (Nonrec(Vdef(qx,t,e))) =
- (venv, Nonrec(Vdef(qx,t,prepExp env e)))
- prepVdefg (venv,tvenv) (Rec vdefs) =
- (venv',Rec [Vdef(qx,t,prepExp (venv',tvenv) e) | Vdef(qx,t,e) <- vdefs])
- where venv' = foldl eextend venv [(x,t) | Vdef(("",x),t,_) <- vdefs]
-
- prepExp env (Var qv) = Var qv
- prepExp env (Dcon qdc) = Dcon qdc
- prepExp env (Lit l) = Lit l
- prepExp env e@(App _ _) = unwindApp env e []
- prepExp env e@(Appt _ _) = unwindApp env e []
- prepExp (venv,tvenv) (Lam (Vb vb) e) = Lam (Vb vb) (prepExp (eextend venv vb,tvenv) e)
- prepExp (venv,tvenv) (Lam (Tb tb) e) = Lam (Tb tb) (prepExp (venv,eextend tvenv tb) e)
- prepExp env@(venv,tvenv) (Let (Nonrec(Vdef(("",x),t,b))) e) | kindof tvenv t == Kunlifted && suspends b =
- Case (prepExp env b) (x,t) [Adefault (prepExp (eextend venv (x,t),tvenv) e)]
- prepExp (venv,tvenv) (Let vdefg e) = Let vdefg' (prepExp (venv',tvenv) e)
- where (venv',vdefg') = prepVdefg (venv,tvenv) vdefg
- prepExp env@(venv,tvenv) (Case e vb alts) = Case (prepExp env e) vb (map (prepAlt (eextend venv vb,tvenv)) alts)
- prepExp env (Coerce t e) = Coerce t (prepExp env e)
- prepExp env (Note s e) = Note s (prepExp env e)
- prepExp env (External s t) = External s t
-
- prepAlt (venv,tvenv) (Acon qdc tbs vbs e) = Acon qdc tbs vbs (prepExp (foldl eextend venv vbs,foldl eextend tvenv tbs) e)
- prepAlt env (Alit l e) = Alit l (prepExp env e)
- prepAlt env (Adefault e) = Adefault (prepExp env e)
-
-
- unwindApp env (App e1 e2) as = unwindApp env e1 (Left e2:as)
- unwindApp env (Appt e t) as = unwindApp env e (Right t:as)
- unwindApp env (op@(Dcon qdc)) as =
- etaExpand (drop n atys) (rewindApp env op as)
- where (tbs,atys0,_) = splitTy (qlookup cenv_ eempty qdc)
- atys = map (substl (map fst tbs) ts) atys0
- ts = [t | Right t <- as]
- n = length [e | Left e <- as]
- unwindApp env (op@(Var(m,p))) as | m == primMname =
- etaExpand (drop n atys) (rewindApp env op as)
- where Just atys = elookup primArgTys p
- n = length [e | Left e <- as]
- unwindApp env op as = rewindApp env op as
-
-
- etaExpand ts e = foldl g e [('$':(show i),t) | (i,t) <- zip [1..] ts]
- where g e (v,t) = Lam (Vb(v,t)) (App e (Var ("",v)))
-
- rewindApp env e [] = e
- rewindApp env@(venv,tvenv) e1 (Left e2:as) | kindof tvenv t == Kunlifted && suspends e2 =
- Case (prepExp env' e2) (v,t)
- [Adefault (rewindApp env' (App e1 (Var ("",v))) as)]
- where v = freshVar venv
- t = typeofExp env e2
- env' = (eextend venv (v,t),tvenv)
- rewindApp env e1 (Left e2:as) = rewindApp env (App e1 (prepExp env e2)) as
- rewindApp env e (Right t:as) = rewindApp env (Appt e t) as
-
- freshVar venv = maximum ("":edomain venv) ++ "x" -- one simple way!
-
- typeofExp :: (Venv,Tvenv) -> Exp -> Ty
- typeofExp (venv,_) (Var qv) = qlookup venv_ venv qv
- typeofExp env (Dcon qdc) = qlookup cenv_ eempty qdc
- typeofExp env (Lit l) = typeofLit l
- where typeofLit (Lint _ t) = t
- typeofLit (Lrational _ t) = t
- typeofLit (Lchar _ t) = t
- typeofLit (Lstring _ t) = t
- typeofExp env (App e1 e2) = t
- where (Tapp(Tapp _ t0) t) = typeofExp env e1
- typeofExp env (Appt e t) = substl [tv] [t] t'
- where (Tforall (tv,_) t') = typeofExp env e
- typeofExp (venv,tvenv) (Lam (Vb(v,t)) e) = tArrow t (typeofExp (eextend venv (v,t),tvenv) e)
- typeofExp (venv,tvenv) (Lam (Tb tb) e) = Tforall tb (typeofExp (venv,eextend tvenv tb) e)
- typeofExp (venv,tvenv) (Let vdefg e) = typeofExp (venv',tvenv) e
- where venv' = case vdefg of
- Nonrec (Vdef((_,x),t,_)) -> eextend venv (x,t)
- Rec vdefs -> foldl eextend venv [(x,t) | Vdef((_,x),t,_) <- vdefs]
- typeofExp (venv,tvenv) (Case _ vb (alt:_)) = typeofAlt (eextend venv vb,tvenv) alt
- where typeofAlt (venv,tvenv) (Acon _ tbs vbs e) = typeofExp (foldl eextend venv vbs,foldl eextend tvenv tbs) e
- typeofAlt env (Alit _ e) = typeofExp env e
- typeofAlt env (Adefault e) = typeofExp env e
- typeofExp env (Coerce t _) = t
- typeofExp env (Note _ e) = typeofExp env e
- typeofExp env (External _ t) = t
-
- {- Return false for those expressions for which Interp.suspendExp buidds a thunk. -}
- suspends (Var _) = False
- suspends (Lit _) = False
- suspends (Lam (Vb _) _) = False
- suspends (Lam _ e) = suspends e
- suspends (Appt e _) = suspends e
- suspends (Coerce _ e) = suspends e
- suspends (Note _ e) = suspends e
- suspends (External _ _) = False
- suspends _ = True
-
- kindof :: Tvenv -> Ty -> Kind
- kindof tvenv (Tvar tv) =
- case elookup tvenv tv of
- Just k -> k
- Nothing -> error ("impossible Tyvar " ++ show tv)
- kindof tvenv (Tcon qtc) = qlookup tcenv_ eempty qtc
- kindof tvenv (Tapp t1 t2) = k2
- where Karrow _ k2 = kindof tvenv t1
- kindof tvenv (Tforall _ t) = kindof tvenv t
-
- mlookup :: (Envs -> Env a b) -> Env a b -> Mname -> Env a b
- mlookup _ local_env "" = local_env
- mlookup selector _ m =
- case elookup globalEnv m of
- Just env -> selector env
- Nothing -> error ("undefined module name: " ++ m)
-
- qlookup :: (Ord a, Show a) => (Envs -> Env a b) -> Env a b -> (Mname,a) -> b
- qlookup selector local_env (m,k) =
- case elookup (mlookup selector local_env m) k of
- Just v -> v
- Nothing -> error ("undefined identifier: " ++ show k)
-
diff --git a/ghc/utils/ext-core/Prims.hs b/ghc/utils/ext-core/Prims.hs
deleted file mode 100644
index fd6e827c39..0000000000
--- a/ghc/utils/ext-core/Prims.hs
+++ /dev/null
@@ -1,834 +0,0 @@
-{- This module really should be auto-generated from the master primops.txt file.
- It is roughly correct (but may be slightly incomplete) wrt/ GHC5.02. -}
-
-module Prims where
-
-import Core
-import Env
-import Check
-
-initialEnv :: Menv
-initialEnv = efromlist [(primMname,primEnv),
- ("PrelErr",errorEnv)]
-
-primEnv :: Envs
-primEnv = Envs {tcenv_=efromlist primTcs,
- tsenv_=eempty,
- cenv_=efromlist primDcs,
- venv_=efromlist primVals}
-
-errorEnv :: Envs
-errorEnv = Envs {tcenv_=eempty,
- tsenv_=eempty,
- cenv_=eempty,
- venv_=efromlist errorVals}
-
-{- Components of static environment -}
-
-primTcs :: [(Tcon,Kind)]
-primTcs =
- map (\ ((m,tc),k) -> (tc,k))
- ([(tcArrow,ktArrow),
- (tcAddrzh,ktAddrzh),
- (tcCharzh,ktCharzh),
- (tcDoublezh,ktDoublezh),
- (tcFloatzh,ktFloatzh),
- (tcIntzh,ktIntzh),
- (tcInt32zh,ktInt32zh),
- (tcInt64zh,ktInt64zh),
- (tcWordzh,ktWordzh),
- (tcWord32zh,ktWord32zh),
- (tcWord64zh,ktWord64zh),
- (tcRealWorld, ktRealWorld),
- (tcStatezh, ktStatezh),
- (tcArrayzh,ktArrayzh),
- (tcByteArrayzh,ktByteArrayzh),
- (tcMutableArrayzh,ktMutableArrayzh),
- (tcMutableByteArrayzh,ktMutableByteArrayzh),
- (tcMutVarzh,ktMutVarzh),
- (tcMVarzh,ktMVarzh),
- (tcWeakzh,ktWeakzh),
- (tcForeignObjzh, ktForeignObjzh),
- (tcStablePtrzh, ktStablePtrzh),
- (tcThreadIdzh, ktThreadIdzh),
- (tcZCTCCallable, ktZCTCCallable),
- (tcZCTCReturnable, ktZCTCReturnable)]
- ++ [(tcUtuple n, ktUtuple n) | n <- [1..maxUtuple]])
-
-
-primDcs :: [(Dcon,Ty)]
-primDcs = map (\ ((m,c),t) -> (c,t))
- [(dcUtuple n, dcUtupleTy n) | n <- [1..maxUtuple]]
-
-primVals :: [(Var,Ty)]
-primVals =
- opsAddrzh ++
- opsCharzh ++
- opsDoublezh ++
- opsFloatzh ++
- opsIntzh ++
- opsInt32zh ++
- opsInt64zh ++
- opsIntegerzh ++
- opsWordzh ++
- opsWord32zh ++
- opsWord64zh ++
- opsSized ++
- opsArray ++
- opsMutVarzh ++
- opsState ++
- opsExn ++
- opsMVar ++
- opsWeak ++
- opsForeignObjzh ++
- opsStablePtrzh ++
- opsConc ++
- opsMisc
-
-
-dcUtuples :: [(Qual Dcon,Ty)]
-dcUtuples = map ( \n -> (dcUtuple n, typ n)) [1..100]
- where typ n = foldr ( \tv t -> Tforall (tv,Kopen) t)
- (foldr ( \tv t -> tArrow (Tvar tv) t)
- (tUtuple (map Tvar tvs)) tvs) tvs
- where tvs = map ( \i -> ("a" ++ (show i))) [1..n]
-
-
-{- Addrzh -}
-
-tcAddrzh = (primMname,"Addrzh")
-tAddrzh = Tcon tcAddrzh
-ktAddrzh = Kunlifted
-
-opsAddrzh = [
- ("gtAddrzh",tcompare tAddrzh),
- ("geAddrzh",tcompare tAddrzh),
- ("eqAddrzh",tcompare tAddrzh),
- ("neAddrzh",tcompare tAddrzh),
- ("ltAddrzh",tcompare tAddrzh),
- ("leAddrzh",tcompare tAddrzh),
- ("nullAddrzh", tAddrzh),
- ("plusAddrzh", tArrow tAddrzh (tArrow tIntzh tAddrzh)),
- ("minusAddrzh", tArrow tAddrzh (tArrow tAddrzh tIntzh)),
- ("remAddrzh", tArrow tAddrzh (tArrow tIntzh tIntzh))]
-
-{- Charzh -}
-
-tcCharzh = (primMname,"Charzh")
-tCharzh = Tcon tcCharzh
-ktCharzh = Kunlifted
-
-opsCharzh = [
- ("gtCharzh", tcompare tCharzh),
- ("geCharzh", tcompare tCharzh),
- ("eqCharzh", tcompare tCharzh),
- ("neCharzh", tcompare tCharzh),
- ("ltCharzh", tcompare tCharzh),
- ("leCharzh", tcompare tCharzh),
- ("ordzh", tArrow tCharzh tIntzh)]
-
-
-{- Doublezh -}
-
-tcDoublezh = (primMname, "Doublezh")
-tDoublezh = Tcon tcDoublezh
-ktDoublezh = Kunlifted
-
-opsDoublezh = [
- ("zgzhzh", tcompare tDoublezh),
- ("zgzezhzh", tcompare tDoublezh),
- ("zezezhzh", tcompare tDoublezh),
- ("zszezhzh", tcompare tDoublezh),
- ("zlzhzh", tcompare tDoublezh),
- ("zlzezhzh", tcompare tDoublezh),
- ("zpzhzh", tdyadic tDoublezh),
- ("zmzhzh", tdyadic tDoublezh),
- ("ztzhzh", tdyadic tDoublezh),
- ("zszhzh", tdyadic tDoublezh),
- ("negateDoublezh", tmonadic tDoublezh),
- ("double2Intzh", tArrow tDoublezh tIntzh),
- ("double2Floatzh", tArrow tDoublezh tFloatzh),
- ("expDoublezh", tmonadic tDoublezh),
- ("logDoublezh", tmonadic tDoublezh),
- ("sqrtDoublezh", tmonadic tDoublezh),
- ("sinDoublezh", tmonadic tDoublezh),
- ("cosDoublezh", tmonadic tDoublezh),
- ("tanDoublezh", tmonadic tDoublezh),
- ("asinDoublezh", tmonadic tDoublezh),
- ("acosDoublezh", tmonadic tDoublezh),
- ("atanDoublezh", tmonadic tDoublezh),
- ("sinhDoublezh", tmonadic tDoublezh),
- ("coshDoublezh", tmonadic tDoublezh),
- ("tanhDoublezh", tmonadic tDoublezh),
- ("ztztzhzh", tdyadic tDoublezh),
- ("decodeDoublezh", tArrow tDoublezh (tUtuple[tIntzh,tIntzh,tByteArrayzh]))]
-
-
-{- Floatzh -}
-
-tcFloatzh = (primMname, "Floatzh")
-tFloatzh = Tcon tcFloatzh
-ktFloatzh = Kunlifted
-
-opsFloatzh = [
- ("gtFloatzh", tcompare tFloatzh),
- ("geFloatzh", tcompare tFloatzh),
- ("eqFloatzh", tcompare tFloatzh),
- ("neFloatzh", tcompare tFloatzh),
- ("ltFloatzh", tcompare tFloatzh),
- ("leFloatzh", tcompare tFloatzh),
- ("plusFloatzh", tdyadic tFloatzh),
- ("minusFloatzh", tdyadic tFloatzh),
- ("timesFloatzh", tdyadic tFloatzh),
- ("divideFloatzh", tdyadic tFloatzh),
- ("negateFloatzh", tmonadic tFloatzh),
- ("float2Intzh", tArrow tFloatzh tIntzh),
- ("expFloatzh", tmonadic tFloatzh),
- ("logFloatzh", tmonadic tFloatzh),
- ("sqrtFloatzh", tmonadic tFloatzh),
- ("sinFloatzh", tmonadic tFloatzh),
- ("cosFloatzh", tmonadic tFloatzh),
- ("tanFloatzh", tmonadic tFloatzh),
- ("asinFloatzh", tmonadic tFloatzh),
- ("acosFloatzh", tmonadic tFloatzh),
- ("atanFloatzh", tmonadic tFloatzh),
- ("sinhFloatzh", tmonadic tFloatzh),
- ("coshFloatzh", tmonadic tFloatzh),
- ("tanhFloatzh", tmonadic tFloatzh),
- ("powerFloatzh", tdyadic tFloatzh),
- ("float2Doublezh", tArrow tFloatzh tDoublezh),
- ("decodeFloatzh", tArrow tFloatzh (tUtuple[tIntzh,tIntzh,tByteArrayzh]))]
-
-
-{- Intzh -}
-
-tcIntzh = (primMname,"Intzh")
-tIntzh = Tcon tcIntzh
-ktIntzh = Kunlifted
-
-opsIntzh = [
- ("zpzh", tdyadic tIntzh),
- ("zmzh", tdyadic tIntzh),
- ("ztzh", tdyadic tIntzh),
- ("quotIntzh", tdyadic tIntzh),
- ("remIntzh", tdyadic tIntzh),
- ("gcdIntzh", tdyadic tIntzh),
- ("negateIntzh", tmonadic tIntzh),
- ("addIntCzh", tArrow tIntzh (tArrow tIntzh (tUtuple [tIntzh, tIntzh]))),
- ("subIntCzh", tArrow tIntzh (tArrow tIntzh (tUtuple [tIntzh, tIntzh]))),
- ("mulIntCzh", tArrow tIntzh (tArrow tIntzh (tUtuple [tIntzh, tIntzh]))),
- ("zgzh", tcompare tIntzh),
- ("zgzezh", tcompare tIntzh),
- ("zezezh", tcompare tIntzh),
- ("zszezh", tcompare tIntzh),
- ("zlzh", tcompare tIntzh),
- ("zlzezh", tcompare tIntzh),
- ("chrzh", tArrow tIntzh tCharzh),
- ("int2Wordzh", tArrow tIntzh tWordzh),
- ("int2Floatzh", tArrow tIntzh tFloatzh),
- ("int2Doublezh", tArrow tIntzh tDoublezh),
- ("intToInt32zh", tArrow tIntzh tInt32zh),
- ("int2Integerzh", tArrow tIntzh tIntegerzhRes),
- ("iShiftLzh", tdyadic tIntzh),
- ("iShiftRAzh", tdyadic tIntzh),
- ("iShiftRLh", tdyadic tIntzh)]
-
-
-{- Int32zh -}
-
-tcInt32zh = (primMname,"Int32zh")
-tInt32zh = Tcon tcInt32zh
-ktInt32zh = Kunlifted
-
-opsInt32zh = [
- ("int32ToIntzh", tArrow tInt32zh tIntzh),
- ("int32ToIntegerzh", tArrow tInt32zh tIntegerzhRes)]
-
-
-{- Int64zh -}
-
-tcInt64zh = (primMname,"Int64zh")
-tInt64zh = Tcon tcInt64zh
-ktInt64zh = Kunlifted
-
-opsInt64zh = [
- ("int64ToIntegerzh", tArrow tInt64zh tIntegerzhRes)]
-
-{- Integerzh -}
-
--- not actuallly a primitive type
-tIntegerzhRes = tUtuple [tIntzh, tByteArrayzh]
-tIntegerzhTo t = tArrow tIntzh (tArrow tByteArrayzh t)
-tdyadicIntegerzh = tIntegerzhTo (tIntegerzhTo tIntegerzhRes)
-
-opsIntegerzh = [
- ("plusIntegerzh", tdyadicIntegerzh),
- ("minusIntegerzh", tdyadicIntegerzh),
- ("timesIntegerzh", tdyadicIntegerzh),
- ("gcdIntegerzh", tdyadicIntegerzh),
- ("gcdIntegerIntzh", tIntegerzhTo (tArrow tIntzh tIntzh)),
- ("divExactIntegerzh", tdyadicIntegerzh),
- ("quotIntegerzh", tdyadicIntegerzh),
- ("remIntegerzh", tdyadicIntegerzh),
- ("cmpIntegerzh", tIntegerzhTo (tIntegerzhTo tIntzh)),
- ("cmpIntegerIntzh", tIntegerzhTo (tArrow tIntzh tIntzh)),
- ("quotRemIntegerzh", tIntegerzhTo (tIntegerzhTo (tUtuple [tIntzh,tByteArrayzh,tIntzh,tByteArrayzh]))),
- ("divModIntegerzh", tIntegerzhTo (tIntegerzhTo (tUtuple [tIntzh,tByteArrayzh,tIntzh,tByteArrayzh]))),
- ("integer2Intzh", tIntegerzhTo tIntzh),
- ("integer2Wordzh", tIntegerzhTo tWordzh),
- ("integerToInt32zh", tIntegerzhTo tInt32zh),
- ("integerToWord32zh", tIntegerzhTo tWord32zh),
- ("integerToInt64zh", tIntegerzhTo tInt64zh),
- ("integerToWord64zh", tIntegerzhTo tWord64zh),
- ("andIntegerzh", tdyadicIntegerzh),
- ("orIntegerzh", tdyadicIntegerzh),
- ("xorIntegerzh", tdyadicIntegerzh),
- ("complementIntegerzh", tIntegerzhTo tIntegerzhRes)]
-
-
-
-{- Wordzh -}
-
-tcWordzh = (primMname,"Wordzh")
-tWordzh = Tcon tcWordzh
-ktWordzh = Kunlifted
-
-opsWordzh = [
- ("plusWordzh", tdyadic tWordzh),
- ("minusWordzh", tdyadic tWordzh),
- ("timesWordzh", tdyadic tWordzh),
- ("quotWordzh", tdyadic tWordzh),
- ("remWordzh", tdyadic tWordzh),
- ("andzh", tdyadic tWordzh),
- ("orzh", tdyadic tWordzh),
- ("xorzh", tdyadic tWordzh),
- ("notzh", tmonadic tWordzh),
- ("shiftLzh", tArrow tWordzh (tArrow tIntzh tWordzh)),
- ("shiftRLzh", tArrow tWordzh (tArrow tIntzh tWordzh)),
- ("word2Intzh", tArrow tWordzh tIntzh),
- ("wordToWord32zh", tArrow tWordzh tWord32zh),
- ("word2Integerzh", tArrow tWordzh tIntegerzhRes),
- ("gtWordzh", tcompare tWordzh),
- ("geWordzh", tcompare tWordzh),
- ("eqWordzh", tcompare tWordzh),
- ("neWordzh", tcompare tWordzh),
- ("ltWordzh", tcompare tWordzh),
- ("leWordzh", tcompare tWordzh)]
-
-{- Word32zh -}
-
-tcWord32zh = (primMname,"Word32zh")
-tWord32zh = Tcon tcWord32zh
-ktWord32zh = Kunlifted
-
-opsWord32zh = [
- ("word32ToWordzh", tArrow tWord32zh tWordzh),
- ("word32ToIntegerzh", tArrow tWord32zh tIntegerzhRes)]
-
-{- Word64zh -}
-
-tcWord64zh = (primMname,"Word64zh")
-tWord64zh = Tcon tcWord64zh
-ktWord64zh = Kunlifted
-
-opsWord64zh = [
- ("word64ToIntegerzh", tArrow tWord64zh tIntegerzhRes)]
-
-{- Explicitly sized Intzh and Wordzh -}
-
-opsSized = [
- ("narrow8Intzh", tmonadic tIntzh),
- ("narrow16Intzh", tmonadic tIntzh),
- ("narrow32Intzh", tmonadic tIntzh),
- ("narrow8Wordzh", tmonadic tWordzh),
- ("narrow16Wordzh", tmonadic tWordzh),
- ("narrow32Wordzh", tmonadic tWordzh)]
-
-{- Arrays -}
-
-tcArrayzh = (primMname,"Arrayzh")
-tArrayzh t = Tapp (Tcon tcArrayzh) t
-ktArrayzh = Karrow Klifted Kunlifted
-
-tcByteArrayzh = (primMname,"ByteArrayzh")
-tByteArrayzh = Tcon tcByteArrayzh
-ktByteArrayzh = Kunlifted
-
-tcMutableArrayzh = (primMname,"MutableArrayzh")
-tMutableArrayzh s t = Tapp (Tapp (Tcon tcMutableArrayzh) s) t
-ktMutableArrayzh = Karrow Klifted (Karrow Klifted Kunlifted)
-
-tcMutableByteArrayzh = (primMname,"MutableByteArrayzh")
-tMutableByteArrayzh s = Tapp (Tcon tcMutableByteArrayzh) s
-ktMutableByteArrayzh = Karrow Klifted Kunlifted
-
-opsArray = [
- ("newArrayzh", Tforall ("a",Klifted)
- (Tforall ("s",Klifted)
- (tArrow tIntzh
- (tArrow (Tvar "a")
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple [tStatezh (Tvar "s"),tMutableArrayzh (Tvar "s") (Tvar "a")])))))),
- ("newByteArrayzh", Tforall ("s",Klifted)
- (tArrow tIntzh
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple [tStatezh (Tvar "s"),tMutableByteArrayzh (Tvar "s")])))),
- ("newPinnedByteArrayzh", Tforall ("s",Klifted)
- (tArrow tIntzh
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple [tStatezh (Tvar "s"),tMutableByteArrayzh (Tvar "s")])))),
- ("byteArrayContentszh", tArrow tByteArrayzh tAddrzh),
- ("indexCharArrayzh", tArrow tByteArrayzh (tArrow tIntzh tCharzh)),
- ("indexWideCharArrayzh", tArrow tByteArrayzh (tArrow tIntzh tCharzh)),
- ("indexIntArrayzh", tArrow tByteArrayzh (tArrow tIntzh tIntzh)),
- ("indexWordArrayzh", tArrow tByteArrayzh (tArrow tIntzh tWordzh)),
- ("indexAddrArrayzh", tArrow tByteArrayzh (tArrow tIntzh tAddrzh)),
- ("indexFloatArrayzh", tArrow tByteArrayzh (tArrow tIntzh tFloatzh)),
- ("indexDoubleArrayzh", tArrow tByteArrayzh (tArrow tIntzh tDoublezh)),
- ("indexStablePtrArrayzh", Tforall ("a",Klifted) (tArrow tByteArrayzh (tArrow tIntzh (tStablePtrzh (Tvar "a"))))),
- ("indexInt8Arrayzh", tArrow tByteArrayzh (tArrow tIntzh tIntzh)),
- ("indexInt16Arrayzh", tArrow tByteArrayzh (tArrow tIntzh tIntzh)),
- ("indexInt32Arrayzh", tArrow tByteArrayzh (tArrow tIntzh tInt32zh)),
- ("indexInt64Arrayzh", tArrow tByteArrayzh (tArrow tIntzh tInt64zh)),
- ("indexWord8Arrayzh", tArrow tByteArrayzh (tArrow tIntzh tWordzh)),
- ("indexWord16Arrayzh", tArrow tByteArrayzh (tArrow tIntzh tWordzh)),
- ("indexWord32Arrayzh", tArrow tByteArrayzh (tArrow tIntzh tWord32zh)),
- ("indexWord64Arrayzh", tArrow tByteArrayzh (tArrow tIntzh tWord64zh)),
- ("readCharArrayzh", tReadMutableByteArrayzh tCharzh),
- ("readWideCharArrayzh", tReadMutableByteArrayzh tCharzh),
- ("readIntArrayzh", tReadMutableByteArrayzh tIntzh),
- ("readWordArrayzh", tReadMutableByteArrayzh tWordzh),
- ("readAddrArrayzh", tReadMutableByteArrayzh tAddrzh),
- ("readFloatArrayzh", tReadMutableByteArrayzh tFloatzh),
- ("readDoubleArrayzh", tReadMutableByteArrayzh tDoublezh),
- ("readStablePtrArrayzh", Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMutableByteArrayzh (Tvar "s"))
- (tArrow tIntzh
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple [tStatezh (Tvar "s"),tStablePtrzh (Tvar "a")])))))),
- ("readInt8Arrayzh", tReadMutableByteArrayzh tIntzh),
- ("readInt16Arrayzh", tReadMutableByteArrayzh tIntzh),
- ("readInt32Arrayzh", tReadMutableByteArrayzh tInt32zh),
- ("readInt64Arrayzh", tReadMutableByteArrayzh tInt64zh),
- ("readWord8Arrayzh", tReadMutableByteArrayzh tWordzh),
- ("readWord16Arrayzh", tReadMutableByteArrayzh tWordzh),
- ("readWord32Arrayzh", tReadMutableByteArrayzh tWord32zh),
- ("readWord64Arrayzh", tReadMutableByteArrayzh tWord64zh),
-
- ("writeCharArrayzh", tWriteMutableByteArrayzh tCharzh),
- ("writeWideCharArrayzh", tWriteMutableByteArrayzh tCharzh),
- ("writeIntArrayzh", tWriteMutableByteArrayzh tIntzh),
- ("writeWordArrayzh", tWriteMutableByteArrayzh tWordzh),
- ("writeAddrArrayzh", tWriteMutableByteArrayzh tAddrzh),
- ("writeFloatArrayzh", tWriteMutableByteArrayzh tFloatzh),
- ("writeDoubleArrayzh", tWriteMutableByteArrayzh tDoublezh),
- ("writeStablePtrArrayzh", Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMutableByteArrayzh (Tvar "s"))
- (tArrow tIntzh
- (tArrow (tStablePtrzh (Tvar "a"))
- (tArrow (tStatezh (Tvar "s"))
- (tStatezh (Tvar "s")))))))),
- ("writeInt8Arrayzh", tWriteMutableByteArrayzh tIntzh),
- ("writeInt16Arrayzh", tWriteMutableByteArrayzh tIntzh),
- ("writeInt32Arrayzh", tWriteMutableByteArrayzh tIntzh),
- ("writeInt64Arrayzh", tWriteMutableByteArrayzh tInt64zh),
- ("writeWord8Arrayzh", tWriteMutableByteArrayzh tWordzh),
- ("writeWord16Arrayzh", tWriteMutableByteArrayzh tWordzh),
- ("writeWord32Arrayzh", tWriteMutableByteArrayzh tWord32zh),
- ("writeWord64Arrayzh", tWriteMutableByteArrayzh tWord64zh),
-
- ("indexCharOffAddrzh", tArrow tAddrzh (tArrow tIntzh tCharzh)),
- ("indexWideCharOffAddrzh", tArrow tAddrzh (tArrow tIntzh tCharzh)),
- ("indexIntOffAddrzh", tArrow tAddrzh (tArrow tIntzh tIntzh)),
- ("indexWordOffAddrzh", tArrow tAddrzh (tArrow tIntzh tWordzh)),
- ("indexAddrOffAddrzh", tArrow tAddrzh (tArrow tIntzh tAddrzh)),
- ("indexFloatOffAddrzh", tArrow tAddrzh (tArrow tIntzh tFloatzh)),
- ("indexDoubleOffAddrzh", tArrow tAddrzh (tArrow tIntzh tDoublezh)),
- ("indexStablePtrOffAddrzh", Tforall ("a",Klifted) (tArrow tAddrzh (tArrow tIntzh (tStablePtrzh (Tvar "a"))))),
- ("indexInt8OffAddrzh", tArrow tAddrzh (tArrow tIntzh tIntzh)),
- ("indexInt16OffAddrzh", tArrow tAddrzh (tArrow tIntzh tIntzh)),
- ("indexInt32OffAddrzh", tArrow tAddrzh (tArrow tIntzh tInt32zh)),
- ("indexInt64OffAddrzh", tArrow tAddrzh (tArrow tIntzh tInt64zh)),
- ("indexWord8OffAddrzh", tArrow tAddrzh (tArrow tIntzh tWordzh)),
- ("indexWord16OffAddrzh", tArrow tAddrzh (tArrow tIntzh tWordzh)),
- ("indexWord32ffAddrzh", tArrow tAddrzh (tArrow tIntzh tWord32zh)),
- ("indexWord64OffAddrzh", tArrow tAddrzh (tArrow tIntzh tWord64zh)),
-
- ("indexCharOffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tCharzh)),
- ("indexWideCharOffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tCharzh)),
- ("indexIntOffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tIntzh)),
- ("indexWordOffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tWordzh)),
- ("indexAddrOffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tAddrzh)),
- ("indexFloatOffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tFloatzh)),
- ("indexDoubleOffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tDoublezh)),
- ("indexStablePtrOffForeignObjzh", Tforall ("a",Klifted) (tArrow tForeignObjzh (tArrow tIntzh (tStablePtrzh (Tvar "a"))))),
- ("indexInt8OffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tIntzh)),
- ("indexInt16OffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tIntzh)),
- ("indexInt32OffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tInt32zh)),
- ("indexInt64OffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tInt64zh)),
- ("indexWord8OffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tWordzh)),
- ("indexWord16OffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tWordzh)),
- ("indexWord32ffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tWord32zh)),
- ("indexWord64OffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tWord64zh)),
-
- ("readCharOffAddrzh", tReadOffAddrzh tCharzh),
- ("readWideCharOffAddrzh", tReadOffAddrzh tCharzh),
- ("readIntOffAddrzh", tReadOffAddrzh tIntzh),
- ("readWordOffAddrzh", tReadOffAddrzh tWordzh),
- ("readAddrOffAddrzh", tReadOffAddrzh tAddrzh),
- ("readFloatOffAddrzh", tReadOffAddrzh tFloatzh),
- ("readDoubleOffAddrzh", tReadOffAddrzh tDoublezh),
- ("readStablePtrOffAddrzh", Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow tAddrzh
- (tArrow tIntzh
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple [tStatezh (Tvar "s"),tStablePtrzh (Tvar "a")])))))),
- ("readInt8OffAddrzh", tReadOffAddrzh tIntzh),
- ("readInt16OffAddrzh", tReadOffAddrzh tIntzh),
- ("readInt32OffAddrzh", tReadOffAddrzh tInt32zh),
- ("readInt64OffAddrzh", tReadOffAddrzh tInt64zh),
- ("readWord8OffAddrzh", tReadOffAddrzh tWordzh),
- ("readWord16OffAddrzh", tReadOffAddrzh tWordzh),
- ("readWord32OffAddrzh", tReadOffAddrzh tWord32zh),
- ("readWord64OffAddrzh", tReadOffAddrzh tWord64zh),
-
- ("writeCharOffAddrzh", tWriteOffAddrzh tCharzh),
- ("writeWideCharOffAddrzh", tWriteOffAddrzh tCharzh),
- ("writeIntOffAddrzh", tWriteOffAddrzh tIntzh),
- ("writeWordOffAddrzh", tWriteOffAddrzh tWordzh),
- ("writeAddrOffAddrzh", tWriteOffAddrzh tAddrzh),
- ("writeFloatOffAddrzh", tWriteOffAddrzh tFloatzh),
- ("writeDoubleOffAddrzh", tWriteOffAddrzh tDoublezh),
- ("writeStablePtrOffAddrzh", Tforall ("a",Klifted) (tWriteOffAddrzh (tStablePtrzh (Tvar "a")))),
- ("writeInt8OffAddrzh", tWriteOffAddrzh tIntzh),
- ("writeInt16OffAddrzh", tWriteOffAddrzh tIntzh),
- ("writeInt32OffAddrzh", tWriteOffAddrzh tInt32zh),
- ("writeInt64OffAddrzh", tWriteOffAddrzh tInt64zh),
- ("writeWord8OffAddrzh", tWriteOffAddrzh tWordzh),
- ("writeWord16OffAddrzh", tWriteOffAddrzh tWordzh),
- ("writeWord32OffAddrzh", tWriteOffAddrzh tWord32zh),
- ("writeWord64OffAddrzh", tWriteOffAddrzh tWord64zh),
-
- ("sameMutableArrayzh", Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMutableArrayzh (Tvar "s") (Tvar "a"))
- (tArrow (tMutableArrayzh (Tvar "s") (Tvar "a"))
- tBool)))),
- ("sameMutableByteArrayzh", Tforall ("s",Klifted)
- (tArrow (tMutableByteArrayzh (Tvar "s"))
- (tArrow (tMutableByteArrayzh (Tvar "s"))
- tBool))),
- ("readArrayzh",Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMutableArrayzh (Tvar "s") (Tvar "a"))
- (tArrow tIntzh
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple[tStatezh (Tvar "s"), Tvar "a"])))))),
- ("writeArrayzh",Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMutableArrayzh (Tvar "s") (Tvar "a"))
- (tArrow tIntzh
- (tArrow (Tvar "a")
- (tArrow (tStatezh (Tvar "s"))
- (tStatezh (Tvar "s")))))))),
- ("indexArrayzh", Tforall ("a",Klifted)
- (tArrow (tArrayzh (Tvar "a"))
- (tArrow tIntzh
- (tUtuple[Tvar "a"])))),
- ("unsafeFreezzeArrayzh",Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMutableArrayzh (Tvar "s") (Tvar "a"))
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple[tStatezh (Tvar "s"),tArrayzh (Tvar "a")]))))),
- ("unsafeFreezzeByteArrayzh",Tforall ("s",Klifted)
- (tArrow (tMutableByteArrayzh (Tvar "s"))
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple[tStatezh (Tvar "s"),tByteArrayzh])))),
- ("unsafeThawArrayzh",Tforall ("a",Klifted)
- (Tforall ("s",Klifted)
- (tArrow (tArrayzh (Tvar "a"))
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple[tStatezh (Tvar "s"),tMutableArrayzh (Tvar "s") (Tvar "a")]))))),
- ("sizzeofByteArrayzh", tArrow tByteArrayzh tIntzh),
- ("sizzeofMutableByteArrayzh", Tforall ("s",Klifted) (tArrow (tMutableByteArrayzh (Tvar "s")) tIntzh))]
- where
- tReadMutableByteArrayzh t =
- Tforall ("s",Klifted)
- (tArrow (tMutableByteArrayzh (Tvar "s"))
- (tArrow tIntzh
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple [tStatezh (Tvar "s"),t]))))
-
- tWriteMutableByteArrayzh t =
- Tforall ("s",Klifted)
- (tArrow (tMutableByteArrayzh (Tvar "s"))
- (tArrow tIntzh
- (tArrow t
- (tArrow (tStatezh (Tvar "s"))
- (tStatezh (Tvar "s"))))))
-
- tReadOffAddrzh t =
- Tforall ("s",Klifted)
- (tArrow tAddrzh
- (tArrow tIntzh
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple [tStatezh (Tvar "s"),t]))))
-
-
- tWriteOffAddrzh t =
- Tforall ("s",Klifted)
- (tArrow tAddrzh
- (tArrow tIntzh
- (tArrow t
- (tArrow (tStatezh (Tvar "s"))
- (tStatezh (Tvar "s"))))))
-
-{- MutVars -}
-
-tcMutVarzh = (primMname,"MutVarzh")
-tMutVarzh s t = Tapp (Tapp (Tcon tcMutVarzh) s) t
-ktMutVarzh = Karrow Klifted (Karrow Klifted Kunlifted)
-
-opsMutVarzh = [
- ("newMutVarzh", Tforall ("a",Klifted)
- (Tforall ("s",Klifted)
- (tArrow (Tvar "a") (tArrow (tStatezh (Tvar "s"))
- (tUtuple [tStatezh (Tvar "s"),
- tMutVarzh (Tvar "s") (Tvar "a")]))))),
- ("readMutVarzh", Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMutVarzh (Tvar "s")(Tvar "a"))
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple [tStatezh (Tvar "s"), Tvar "a"]))))),
- ("writeMutVarzh", Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMutVarzh (Tvar "s") (Tvar "a"))
- (tArrow (Tvar "a")
- (tArrow (tStatezh (Tvar "s"))
- (tStatezh (Tvar "s"))))))),
- ("sameMutVarzh", Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMutVarzh (Tvar "s") (Tvar "a"))
- (tArrow (tMutVarzh (Tvar "s") (Tvar "a"))
- tBool))))]
-
-{- Real world and state. -}
-
-tcRealWorld = (primMname,"RealWorld")
-tRealWorld = Tcon tcRealWorld
-ktRealWorld = Klifted
-
-tcStatezh = (primMname, "Statezh")
-tStatezh t = Tapp (Tcon tcStatezh) t
-ktStatezh = Karrow Klifted Kunlifted
-
-tRWS = tStatezh tRealWorld
-
-opsState = [
- ("realWorldzh", tRWS)]
-
-{- Exceptions -}
-
--- no primitive type
-opsExn = [
- ("catchzh",
- let t' = tArrow tRWS (tUtuple [tRWS, Tvar "a"]) in
- Tforall ("a",Klifted)
- (Tforall ("b",Klifted)
- (tArrow t'
- (tArrow (tArrow (Tvar "b") t')
- t')))),
- ("raisezh", Tforall ("a",Klifted)
- (Tforall ("b",Klifted)
- (tArrow (Tvar "a") (Tvar "b")))),
- ("blockAsyncExceptionszh", Tforall ("a",Klifted)
- (tArrow (tArrow tRWS (tUtuple[tRWS,Tvar "a"]))
- (tArrow tRWS (tUtuple[tRWS,Tvar "a"])))),
- ("unblockAsyncExceptionszh", Tforall ("a",Klifted)
- (tArrow (tArrow tRWS (tUtuple[tRWS,Tvar "a"]))
- (tArrow tRWS (tUtuple[tRWS,Tvar "a"]))))]
-
-{- Mvars -}
-
-tcMVarzh = (primMname, "MVarzh")
-tMVarzh s t = Tapp (Tapp (Tcon tcMVarzh) s) t
-ktMVarzh = Karrow Klifted (Karrow Klifted Kunlifted)
-
-opsMVar = [
- ("newMVarzh", Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple[tStatezh (Tvar "s"),tMVarzh (Tvar "s") (Tvar "a")])))),
- ("takeMVarzh", Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMVarzh (Tvar "s") (Tvar "a"))
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple[tStatezh (Tvar "s"),Tvar "a"]))))),
- ("tryTakeMVarzh", Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMVarzh (Tvar "s") (Tvar "a"))
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple[tStatezh (Tvar "s"),tIntzh,Tvar "a"]))))),
- ("putMVarzh", Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMVarzh (Tvar "s") (Tvar "a"))
- (tArrow (Tvar "a")
- (tArrow (tStatezh (Tvar "s"))
- (tStatezh (Tvar "s"))))))),
- ("tryPutMVarzh", Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMVarzh (Tvar "s") (Tvar "a"))
- (tArrow (Tvar "a")
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple [tStatezh (Tvar "s"), tIntzh])))))),
- ("sameMVarzh", Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMVarzh (Tvar "s") (Tvar "a"))
- (tArrow (tMVarzh (Tvar "s") (Tvar "a"))
- tBool)))),
- ("isEmptyMVarzh", Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMVarzh (Tvar "s") (Tvar "a"))
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple[tStatezh (Tvar "s"),tIntzh])))))]
-
-
-{- Weak Objects -}
-
-tcWeakzh = (primMname, "Weakzh")
-tWeakzh t = Tapp (Tcon tcWeakzh) t
-ktWeakzh = Karrow Klifted Kunlifted
-
-opsWeak = [
- ("mkWeakzh", Tforall ("o",Kopen)
- (Tforall ("b",Klifted)
- (Tforall ("c",Klifted)
- (tArrow (Tvar "o")
- (tArrow (Tvar "b")
- (tArrow (Tvar "c")
- (tArrow tRWS (tUtuple[tRWS, tWeakzh (Tvar "b")])))))))),
- ("deRefWeakzh", Tforall ("a",Klifted)
- (tArrow (tWeakzh (Tvar "a"))
- (tArrow tRWS (tUtuple[tRWS, tIntzh, Tvar "a"])))),
- ("finalizeWeakzh", Tforall ("a",Klifted)
- (tArrow (tWeakzh (Tvar "a"))
- (tArrow tRWS
- (tUtuple[tRWS,tIntzh,
- tArrow tRWS (tUtuple[tRWS, tUnit])]))))]
-
-
-{- Foreign Objects -}
-
-tcForeignObjzh = (primMname, "ForeignObjzh")
-tForeignObjzh = Tcon tcForeignObjzh
-ktForeignObjzh = Kunlifted
-
-opsForeignObjzh = [
- ("mkForeignObjzh", tArrow tAddrzh
- (tArrow tRWS (tUtuple [tRWS,tForeignObjzh]))),
- ("writeForeignObjzh", Tforall ("s",Klifted)
- (tArrow tForeignObjzh
- (tArrow tAddrzh
- (tArrow (tStatezh (Tvar "s")) (tStatezh (Tvar "s")))))),
- ("foreignObjToAddrzh", tArrow tForeignObjzh tAddrzh),
- ("touchzh", Tforall ("o",Kopen)
- (tArrow (Tvar "o")
- (tArrow tRWS tRWS)))]
-
-
-{- Stable Pointers (but not names) -}
-
-tcStablePtrzh = (primMname, "StablePtrzh")
-tStablePtrzh t = Tapp (Tcon tcStablePtrzh) t
-ktStablePtrzh = Karrow Klifted Kunlifted
-
-opsStablePtrzh = [
- ("makeStablePtrzh", Tforall ("a",Klifted)
- (tArrow (Tvar "a")
- (tArrow tRWS (tUtuple[tRWS,tStablePtrzh (Tvar "a")])))),
- ("deRefStablePtrzh", Tforall ("a",Klifted)
- (tArrow (tStablePtrzh (Tvar "a"))
- (tArrow tRWS (tUtuple[tRWS,Tvar "a"])))),
- ("eqStablePtrzh", Tforall ("a",Klifted)
- (tArrow (tStablePtrzh (Tvar "a"))
- (tArrow (tStablePtrzh (Tvar "a")) tIntzh)))]
-
-{- Concurrency operations -}
-
-tcThreadIdzh = (primMname,"ThreadIdzh")
-tThreadIdzh = Tcon tcThreadIdzh
-ktThreadIdzh = Kunlifted
-
-opsConc = [
- ("seqzh", Tforall ("a",Klifted)
- (tArrow (Tvar "a") tIntzh)),
- ("parzh", Tforall ("a",Klifted)
- (tArrow (Tvar "a") tIntzh)),
- ("delayzh", Tforall ("s",Klifted)
- (tArrow tIntzh (tArrow (tStatezh (Tvar "s")) (tStatezh (Tvar "s"))))),
- ("waitReadzh", Tforall ("s",Klifted)
- (tArrow tIntzh (tArrow (tStatezh (Tvar "s")) (tStatezh (Tvar "s"))))),
- ("waitWritezh", Tforall ("s",Klifted)
- (tArrow tIntzh (tArrow (tStatezh (Tvar "s")) (tStatezh (Tvar "s"))))),
- ("forkzh", Tforall ("a",Klifted)
- (tArrow (Tvar "a")
- (tArrow tRWS (tUtuple[tRWS,tThreadIdzh])))),
- ("killThreadzh", Tforall ("a",Klifted)
- (tArrow tThreadIdzh
- (tArrow (Tvar "a")
- (tArrow tRWS tRWS)))),
- ("yieldzh", tArrow tRWS tRWS),
- ("myThreadIdzh", tArrow tRWS (tUtuple[tRWS, tThreadIdzh]))]
-
-{- Miscellaneous operations -}
-
-opsMisc = [
- ("dataToTagzh", Tforall ("a",Klifted)
- (tArrow (Tvar "a") tIntzh)),
- ("tagToEnumzh", Tforall ("a",Klifted)
- (tArrow tIntzh (Tvar "a"))),
- ("unsafeCoercezh", Tforall ("a",Kopen)
- (Tforall ("b",Kopen)
- (tArrow (Tvar "a") (Tvar "b")))) -- maybe unneeded
- ]
-
-{- CCallable and CReturnable.
- We just define the type constructors for the dictionaries
- corresponding to these pseudo-classes. -}
-
-tcZCTCCallable = (primMname,"ZCTCCallable")
-ktZCTCCallable = Karrow Kopen Klifted -- ??
-tcZCTCReturnable = (primMname,"ZCTCReturnable")
-ktZCTCReturnable = Karrow Kopen Klifted -- ??
-
-{- Non-primitive, but mentioned in the types of primitives. -}
-
-tcUnit = ("PrelBase","Unit")
-tUnit = Tcon tcUnit
-ktUnit = Klifted
-tcBool = ("PrelBase","Bool")
-tBool = Tcon tcBool
-ktBool = Klifted
-
-{- Properly defined in PrelError, but needed in many modules before that. -}
-errorVals = [
- ("error", Tforall ("a",Kopen) (tArrow tString (Tvar "a"))),
- ("irrefutPatError", Tforall ("a",Kopen) (tArrow tString (Tvar "a"))),
- ("patError", Tforall ("a",Kopen) (tArrow tString (Tvar "a")))]
-
-tcChar = ("PrelBase","Char")
-tChar = Tcon tcChar
-ktChar = Klifted
-tcList = ("PrelBase","ZMZN")
-tList t = Tapp (Tcon tcList) t
-ktList = Karrow Klifted Klifted
-tString = tList tChar
-
-{- Utilities for building types -}
-tmonadic t = tArrow t t
-tdyadic t = tArrow t (tArrow t t)
-tcompare t = tArrow t (tArrow t tBool)
-
diff --git a/ghc/utils/ext-core/Printer.hs b/ghc/utils/ext-core/Printer.hs
deleted file mode 100644
index ded48aadc2..0000000000
--- a/ghc/utils/ext-core/Printer.hs
+++ /dev/null
@@ -1,163 +0,0 @@
-module Printer where
-
-import Pretty
-import Core
-import Char
-import Numeric (fromRat)
-
-instance Show Module where
- showsPrec d m = shows (pmodule m)
-
-instance Show Tdef where
- showsPrec d t = shows (ptdef t)
-
-instance Show Cdef where
- showsPrec d c = shows (pcdef c)
-
-instance Show Vdefg where
- showsPrec d v = shows (pvdefg v)
-
-instance Show Vdef where
- showsPrec d v = shows (pvdef v)
-
-instance Show Exp where
- showsPrec d e = shows (pexp e)
-
-instance Show Alt where
- showsPrec d a = shows (palt a)
-
-instance Show Ty where
- showsPrec d t = shows (pty t)
-
-instance Show Kind where
- showsPrec d k = shows (pkind k)
-
-instance Show Lit where
- showsPrec d l = shows (plit l)
-
-
-indent = nest 2
-
-pmodule (Module mname tdefs vdefgs) =
- (text "%module" <+> text mname)
- $$ indent ((vcat (map ((<> char ';') . ptdef) tdefs))
- $$ (vcat (map ((<> char ';') . pvdefg) vdefgs)))
-
-ptdef (Data qtcon tbinds cdefs) =
- (text "%data" <+> pqname qtcon <+> (hsep (map ptbind tbinds)) <+> char '=')
- $$ indent (braces ((vcat (punctuate (char ';') (map pcdef cdefs)))))
-
-ptdef (Newtype qtcon tbinds tyopt ) =
- text "%newtype" <+> pqname qtcon <+> (hsep (map ptbind tbinds)) <+>
- (case tyopt of
- Just ty -> char '=' <+> pty ty
- Nothing -> empty)
-
-pcdef (Constr qdcon tbinds tys) =
- (pqname qdcon) <+> (sep [hsep (map pattbind tbinds),sep (map paty tys)])
-
-pname id = text id
-
-pqname ("",id) = pname id
-pqname (m,id) = pname m <> char '.' <> pname id
-
-ptbind (t,Klifted) = pname t
-ptbind (t,k) = parens (pname t <> text "::" <> pkind k)
-
-pattbind (t,k) = char '@' <> ptbind (t,k)
-
-pakind (Klifted) = char '*'
-pakind (Kunlifted) = char '#'
-pakind (Kopen) = char '?'
-pakind k = parens (pkind k)
-
-pkind (Karrow k1 k2) = parens (pakind k1 <> text "->" <> pkind k2)
-pkind k = pakind k
-
-paty (Tvar n) = pname n
-paty (Tcon c) = pqname c
-paty t = parens (pty t)
-
-pbty (Tapp(Tapp(Tcon tc) t1) t2) | tc == tcArrow = parens(fsep [pbty t1, text "->",pty t2])
-pbty (Tapp t1 t2) = pappty t1 [t2]
-pbty t = paty t
-
-pty (Tapp(Tapp(Tcon tc) t1) t2) | tc == tcArrow = fsep [pbty t1, text "->",pty t2]
-pty (Tforall tb t) = text "%forall" <+> pforall [tb] t
-pty t = pbty t
-
-pappty (Tapp t1 t2) ts = pappty t1 (t2:ts)
-pappty t ts = sep (map paty (t:ts))
-
-pforall tbs (Tforall tb t) = pforall (tbs ++ [tb]) t
-pforall tbs t = hsep (map ptbind tbs) <+> char '.' <+> pty t
-
-pvdefg (Rec vdefs) = text "%rec" $$ braces (indent (vcat (punctuate (char ';') (map pvdef vdefs))))
-pvdefg (Nonrec vdef) = pvdef vdef
-
-pvdef (Vdef (qv,t,e)) = sep [pqname qv <+> text "::" <+> pty t <+> char '=',
- indent (pexp e)]
-
-paexp (Var x) = pqname x
-paexp (Dcon x) = pqname x
-paexp (Lit l) = plit l
-paexp e = parens(pexp e)
-
-plamexp bs (Lam b e) = plamexp (bs ++ [b]) e
-plamexp bs e = sep [sep (map pbind bs) <+> text "->",
- indent (pexp e)]
-
-pbind (Tb tb) = char '@' <+> ptbind tb
-pbind (Vb vb) = pvbind vb
-
-pfexp (App e1 e2) = pappexp e1 [Left e2]
-pfexp (Appt e t) = pappexp e [Right t]
-pfexp e = paexp e
-
-pappexp (App e1 e2) as = pappexp e1 (Left e2:as)
-pappexp (Appt e t) as = pappexp e (Right t:as)
-pappexp e as = fsep (paexp e : map pa as)
- where pa (Left e) = paexp e
- pa (Right t) = char '@' <+> paty t
-
-pexp (Lam b e) = char '\\' <+> plamexp [b] e
-pexp (Let vd e) = (text "%let" <+> pvdefg vd) $$ (text "%in" <+> pexp e)
-pexp (Case e vb alts) = sep [text "%case" <+> paexp e,
- text "%of" <+> pvbind vb]
- $$ (indent (braces (vcat (punctuate (char ';') (map palt alts)))))
-pexp (Coerce t e) = (text "%coerce" <+> paty t) $$ pexp e
-pexp (Note s e) = (text "%note" <+> pstring s) $$ pexp e
-pexp (External n t) = (text "%extcall" <+> pstring n) $$ paty t
-pexp e = pfexp e
-
-
-pvbind (x,t) = parens(pname x <> text "::" <> pty t)
-
-palt (Acon c tbs vbs e) =
- sep [pqname c,
- sep (map pattbind tbs),
- sep (map pvbind vbs) <+> text "->"]
- $$ indent (pexp e)
-palt (Alit l e) =
- (plit l <+> text "->")
- $$ indent (pexp e)
-palt (Adefault e) =
- (text "%_ ->")
- $$ indent (pexp e)
-
-plit (Lint i t) = parens (integer i <> text "::" <> pty t)
-plit (Lrational r t) = parens (text (show (fromRat r)) <> text "::" <> pty t)
-plit (Lchar c t) = parens (text ("\'" ++ escape [c] ++ "\'") <> text "::" <> pty t)
-plit (Lstring s t) = parens (pstring s <> text "::" <> pty t)
-
-pstring s = doubleQuotes(text (escape s))
-
-escape s = foldr f [] (map ord s)
- where
- f cv rest | (cv < 0x20 || cv > 0x7e || cv == 0x22 || cv == 0x27 || cv == 0x5c) =
- '\\':'x':h1:h0:rest
- where (q1,r1) = quotRem cv 16
- h1 = intToDigit q1
- h0 = intToDigit r1
- f cv rest = (chr cv):rest
-
diff --git a/ghc/utils/ext-core/README b/ghc/utils/ext-core/README
deleted file mode 100644
index 7ec8adf09a..0000000000
--- a/ghc/utils/ext-core/README
+++ /dev/null
@@ -1,9 +0,0 @@
-A set of example programs for handling external core format.
-
-In particular, typechecker and interpreter give a precise semantics.
-
-All can be built using, e.g.,
-
-happy -o Parser.hs Parser.y
-ghc --make -package text -fglasgow-exts -o Driver Driver.hs
-
diff --git a/ghc/utils/genapply/GenApply.hs b/ghc/utils/genapply/GenApply.hs
deleted file mode 100644
index cdde66fa78..0000000000
--- a/ghc/utils/genapply/GenApply.hs
+++ /dev/null
@@ -1,769 +0,0 @@
-{-# OPTIONS -cpp #-}
-module Main(main) where
-
-#include "../../includes/ghcconfig.h"
-#include "../../includes/MachRegs.h"
-#include "../../includes/Constants.h"
-
-
-#if __GLASGOW_HASKELL__ >= 504
-import Text.PrettyPrint
-import Data.Word
-import Data.Bits
-import Data.List ( intersperse )
-import System.Exit
-import System.Environment
-import System.IO
-#else
-import System
-import IO
-import Bits
-import Word
-import Pretty
-import List ( intersperse )
-#endif
-
--- -----------------------------------------------------------------------------
--- Argument kinds (rougly equivalent to PrimRep)
-
-data ArgRep
- = N -- non-ptr
- | P -- ptr
- | V -- void
- | F -- float
- | D -- double
- | L -- long (64-bit)
-
--- size of a value in *words*
-argSize :: ArgRep -> Int
-argSize N = 1
-argSize P = 1
-argSize V = 0
-argSize F = 1
-argSize D = (SIZEOF_DOUBLE `quot` SIZEOF_VOID_P :: Int)
-argSize L = (8 `quot` SIZEOF_VOID_P :: Int)
-
-showArg :: ArgRep -> Char
-showArg N = 'n'
-showArg P = 'p'
-showArg V = 'v'
-showArg F = 'f'
-showArg D = 'd'
-showArg L = 'l'
-
--- is a value a pointer?
-isPtr :: ArgRep -> Bool
-isPtr P = True
-isPtr _ = False
-
--- -----------------------------------------------------------------------------
--- Registers
-
-data RegStatus = Registerised | Unregisterised
-
-type Reg = String
-
-availableRegs :: RegStatus -> ([Reg],[Reg],[Reg],[Reg])
-availableRegs Unregisterised = ([],[],[],[])
-availableRegs Registerised =
- ( vanillaRegs MAX_REAL_VANILLA_REG,
- floatRegs MAX_REAL_FLOAT_REG,
- doubleRegs MAX_REAL_DOUBLE_REG,
- longRegs MAX_REAL_LONG_REG
- )
-
-vanillaRegs, floatRegs, doubleRegs, longRegs :: Int -> [Reg]
-vanillaRegs n = [ "R" ++ show m | m <- [2..n] ] -- never use R1
-floatRegs n = [ "F" ++ show m | m <- [1..n] ]
-doubleRegs n = [ "D" ++ show m | m <- [1..n] ]
-longRegs n = [ "L" ++ show m | m <- [1..n] ]
-
--- -----------------------------------------------------------------------------
--- Loading/saving register arguments to the stack
-
-loadRegArgs :: RegStatus -> Int -> [ArgRep] -> (Doc,Int)
-loadRegArgs regstatus sp args
- = (loadRegOffs reg_locs, sp')
- where (reg_locs, _, sp') = assignRegs regstatus sp args
-
-loadRegOffs :: [(Reg,Int)] -> Doc
-loadRegOffs = vcat . map (uncurry assign_stk_to_reg)
-
-saveRegOffs :: [(Reg,Int)] -> Doc
-saveRegOffs = vcat . map (uncurry assign_reg_to_stk)
-
--- a bit like assignRegs in CgRetConv.lhs
-assignRegs
- :: RegStatus -- are we registerised?
- -> Int -- Sp of first arg
- -> [ArgRep] -- args
- -> ([(Reg,Int)], -- regs and offsets to load
- [ArgRep], -- left-over args
- Int) -- Sp of left-over args
-assignRegs regstatus sp args = assign sp args (availableRegs regstatus) []
-
-assign sp [] regs doc = (doc, [], sp)
-assign sp (V : args) regs doc = assign sp args regs doc
-assign sp (arg : args) regs doc
- = case findAvailableReg arg regs of
- Just (reg, regs') -> assign (sp + argSize arg) args regs'
- ((reg, sp) : doc)
- Nothing -> (doc, (arg:args), sp)
-
-findAvailableReg N (vreg:vregs, fregs, dregs, lregs) =
- Just (vreg, (vregs,fregs,dregs,lregs))
-findAvailableReg P (vreg:vregs, fregs, dregs, lregs) =
- Just (vreg, (vregs,fregs,dregs,lregs))
-findAvailableReg F (vregs, freg:fregs, dregs, lregs) =
- Just (freg, (vregs,fregs,dregs,lregs))
-findAvailableReg D (vregs, fregs, dreg:dregs, lregs) =
- Just (dreg, (vregs,fregs,dregs,lregs))
-findAvailableReg L (vregs, fregs, dregs, lreg:lregs) =
- Just (lreg, (vregs,fregs,dregs,lregs))
-findAvailableReg _ _ = Nothing
-
-assign_reg_to_stk reg sp
- = loadSpWordOff (regRep reg) sp <> text " = " <> text reg <> semi
-
-assign_stk_to_reg reg sp
- = text reg <> text " = " <> loadSpWordOff (regRep reg) sp <> semi
-
-regRep ('F':_) = "F_"
-regRep ('D':_) = "D_"
-regRep ('L':_) = "L_"
-regRep _ = "W_"
-
-loadSpWordOff :: String -> Int -> Doc
-loadSpWordOff rep off = text rep <> text "[Sp+WDS(" <> int off <> text ")]"
-
--- make a ptr/non-ptr bitmap from a list of argument types
-mkBitmap :: [ArgRep] -> Word32
-mkBitmap args = foldr f 0 args
- where f arg bm | isPtr arg = bm `shiftL` 1
- | otherwise = (bm `shiftL` size) .|. ((1 `shiftL` size) - 1)
- where size = argSize arg
-
--- -----------------------------------------------------------------------------
--- Generating the application functions
-
--- A SUBTLE POINT about stg_ap functions (can't think of a better
--- place to put this comment --SDM):
---
--- The entry convention to an stg_ap_ function is as follows: all the
--- arguments are on the stack (we might revisit this at some point,
--- but it doesn't make any difference on x86), and THERE IS AN EXTRA
--- EMPTY STACK SLOT at the top of the stack.
---
--- Why? Because in several cases, stg_ap_* will need an extra stack
--- slot, eg. to push a return address in the THUNK case, and this is a
--- way of pushing the stack check up into the caller which is probably
--- doing one anyway. Allocating the extra stack slot in the caller is
--- also probably free, because it will be adjusting Sp after pushing
--- the args anyway (this might not be true of register-rich machines
--- when we start passing args to stg_ap_* in regs).
-
-mkApplyName args
- = text "stg_ap_" <> text (map showArg args)
-
-mkApplyRetName args
- = mkApplyName args <> text "_ret"
-
-mkApplyFastName args
- = mkApplyName args <> text "_fast"
-
-mkApplyInfoName args
- = mkApplyName args <> text "_info"
-
-genMkPAP regstatus macro jump ticker disamb
- no_load_regs -- don't load argumnet regs before jumping
- args_in_regs -- arguments are already in regs
- is_pap args all_args_size fun_info_label
- = smaller_arity_cases
- $$ exact_arity_case
- $$ larger_arity_case
-
- where
- n_args = length args
-
- -- offset of arguments on the stack at slow apply calls.
- stk_args_slow_offset = 1
-
- stk_args_offset
- | args_in_regs = 0
- | otherwise = stk_args_slow_offset
-
--- The SMALLER ARITY cases:
--- if (arity == 1) {
--- 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 arity
- = text "if (arity == " <> int arity <> text ") {" $$
- nest 4 (vcat [
- text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_MANY();",
-
- -- load up regs for the call, if necessary
- load_regs,
-
- -- If we have more args in registers than are required
- -- for the call, then we must save some on the stack,
- -- and set up the stack for the follow-up call.
- -- 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,
-
- -- for a PAP, we have to arrange that the stack contains a
- -- return address in the even that stg_PAP_entry fails its
- -- heap check. See stg_PAP_entry in Apply.hc for details.
- if is_pap
- then text "R2 = " <> mkApplyInfoName this_call_args <> semi
-
- else empty,
- text "jump " <> text jump <> semi
- ]) $$
- 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 (map shuffle_down
- [sp_stk_args .. sp_stk_args+stack_args_size-1]) $$
- loadSpWordOff "W_" (sp_stk_args+stack_args_size-1)
- <> text " = "
- <> mkApplyInfoName rest_args <> semi $$
- text "Sp_adj(" <> int (sp_stk_args - 1) <> text ");"
-
- shuffle_down i =
- loadSpWordOff "W_" (i-1) <> text " = " <>
- loadSpWordOff "W_" i <> semi
-
--- The EXACT ARITY case
---
--- if (arity == 1) {
--- Sp++;
--- JMP_(GET_ENTRY(R1.cl));
-
- exact_arity_case
- = text "if (arity == " <> int n_args <> text ") {" $$
- let
- (reg_doc, sp')
- | no_load_regs || args_in_regs = (empty, stk_args_offset)
- | otherwise = loadRegArgs regstatus stk_args_offset args
- in
- nest 4 (vcat [
- text "TICK_SLOW_CALL_" <> text ticker <> text "_CORRECT();",
- reg_doc,
- text "Sp_adj(" <> int sp' <> text ");",
- if is_pap
- then text "R2 = " <> fun_info_label <> semi
- else empty,
- text "jump " <> text jump <> semi
- ])
-
--- The LARGER ARITY cases:
---
--- } else /* arity > 1 */ {
--- BUILD_PAP(1,0,(W_)&stg_ap_v_info);
--- }
-
- larger_arity_case =
- text "} else {" $$
- let
- save_regs
- | args_in_regs =
- text "Sp_adj(" <> int (-sp_offset) <> text ");" $$
- saveRegOffs reg_locs
- | otherwise =
- empty
- in
- nest 4 (vcat [
- text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_FEW();",
- save_regs,
- text macro <> char '(' <> int n_args <> comma <>
- int all_args_size <>
- text "," <> fun_info_label <>
- text "," <> text 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
-
--- -----------------------------------------------------------------------------
--- generate an apply function
-
--- args is a list of 'p', 'n', 'f', 'd' or 'l'
-
-genApply regstatus args =
- let
- fun_ret_label = mkApplyRetName args
- fun_info_label = mkApplyInfoName args
- all_args_size = sum (map argSize args)
- in
- vcat [
- text "INFO_TABLE_RET(" <> mkApplyName args <> text ", " <>
- int all_args_size <> text "/*framsize*/," <>
- int (fromIntegral (mkBitmap args)) <> text "/*bitmap*/, " <>
- text "RET_SMALL)\n{",
- nest 4 (vcat [
- text "W_ info;",
- text "W_ arity;",
-
--- if fast == 1:
--- print "static void *lbls[] ="
--- print " { [FUN] &&fun_lbl,"
--- print " [FUN_1_0] &&fun_lbl,"
--- print " [FUN_0_1] &&fun_lbl,"
--- print " [FUN_2_0] &&fun_lbl,"
--- print " [FUN_1_1] &&fun_lbl,"
--- print " [FUN_0_2] &&fun_lbl,"
--- print " [FUN_STATIC] &&fun_lbl,"
--- print " [PAP] &&pap_lbl,"
--- print " [THUNK] &&thunk_lbl,"
--- print " [THUNK_1_0] &&thunk_lbl,"
--- print " [THUNK_0_1] &&thunk_lbl,"
--- print " [THUNK_2_0] &&thunk_lbl,"
--- print " [THUNK_1_1] &&thunk_lbl,"
--- print " [THUNK_0_2] &&thunk_lbl,"
--- print " [THUNK_STATIC] &&thunk_lbl,"
--- print " [THUNK_SELECTOR] &&thunk_lbl,"
--- print " [IND] &&ind_lbl,"
--- print " [IND_OLDGEN] &&ind_lbl,"
--- print " [IND_STATIC] &&ind_lbl,"
--- print " [IND_PERM] &&ind_lbl,"
--- print " [IND_OLDGEN_PERM] &&ind_lbl"
--- print " };"
-
- text "",
- text "IF_DEBUG(apply,foreign \"C\" debugBelch(\"" <> fun_ret_label <>
- text "... \"); foreign \"C\" printClosure(R1 \"ptr\"));",
-
- text "IF_DEBUG(sanity,foreign \"C\" checkStackFrame(Sp+WDS(" <> int (1 + all_args_size)
- <> text ")\"ptr\"));",
-
--- text "IF_DEBUG(sanity,checkStackChunk(Sp+" <> int (1 + all_args_size) <>
--- text ", CurrentTSO->stack + CurrentTSO->stack_size));",
-
- text "TICK_SLOW_CALL(" <> int (length args) <> text ");",
-
- let do_assert [] _ = []
- do_assert (arg:args) offset
- | isPtr arg = this : rest
- | otherwise = rest
- where this = text "ASSERT(LOOKS_LIKE_CLOSURE_PTR(Sp("
- <> int offset <> text ")));"
- rest = do_assert args (offset + argSize arg)
- in
- vcat (do_assert args 1),
-
- text "again:",
- text "info = %INFO_PTR(R1);",
-
--- if fast == 1:
--- print " goto *lbls[info->type];";
--- else:
- text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (%INFO_TYPE(%STD_INFO(info))) {",
- nest 4 (vcat [
-
--- if fast == 1:
--- print " bco_lbl:"
--- else:
- text "case BCO: {",
- nest 4 (vcat [
- text "arity = TO_W_(StgBCO_arity(R1));",
- text "ASSERT(arity > 0);",
- genMkPAP regstatus "BUILD_PAP" "ENTRY_LBL(stg_BCO)" "FUN" "BCO"
- True{-stack apply-} False{-args on stack-} False{-not a PAP-}
- args all_args_size fun_info_label
- ]),
- text "}",
-
--- if fast == 1:
--- print " fun_lbl:"
--- else:
- text "case FUN,",
- text " FUN_1_0,",
- text " FUN_0_1,",
- text " FUN_2_0,",
- text " FUN_1_1,",
- text " FUN_0_2,",
- text " FUN_STATIC: {",
- nest 4 (vcat [
- text "arity = TO_W_(StgFunInfoExtra_arity(%FUN_INFO(info)));",
- text "ASSERT(arity > 0);",
- genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(R1)" "FUN" "FUN"
- False{-reg apply-} False{-args on stack-} False{-not a PAP-}
- args all_args_size fun_info_label
- ]),
- text "}",
-
--- if fast == 1:
--- print " pap_lbl:"
--- else:
-
- text "case PAP: {",
- nest 4 (vcat [
- text "arity = TO_W_(StgPAP_arity(R1));",
- text "ASSERT(arity > 0);",
- genMkPAP regstatus "NEW_PAP" "stg_PAP_apply" "PAP" "PAP"
- True{-stack apply-} False{-args on stack-} True{-is a PAP-}
- args all_args_size fun_info_label
- ]),
- text "}",
-
- text "",
-
--- if fast == 1:
--- print " thunk_lbl:"
--- else:
- text "case AP,",
- text " AP_STACK,",
- text " CAF_BLACKHOLE,",
- text " BLACKHOLE,",
- text " SE_BLACKHOLE,",
- text " SE_CAF_BLACKHOLE,",
- text " THUNK,",
- text " THUNK_1_0,",
- text " THUNK_0_1,",
- text " THUNK_2_0,",
- text " THUNK_1_1,",
- text " THUNK_0_2,",
- text " THUNK_STATIC,",
- text " THUNK_SELECTOR: {",
- nest 4 (vcat [
- text "TICK_SLOW_CALL_UNEVALD(" <> int (length args) <> text ");",
- text "Sp(0) = " <> fun_info_label <> text ";",
- -- CAREFUL! in SMP mode, the info table may already have been
- -- overwritten by an indirection, so we must enter the original
- -- info pointer we read, don't read it again, because it might
- -- not be enterable any more.
- text "jump %ENTRY_CODE(info);",
- text ""
- ]),
- text "}",
-
--- if fast == 1:
--- print " ind_lbl:"
--- else:
- text "case IND,",
- text " IND_OLDGEN,",
- text " IND_STATIC,",
- text " IND_PERM,",
- text " IND_OLDGEN_PERM: {",
- nest 4 (vcat [
- text "R1 = StgInd_indirectee(R1);",
- text "goto again;"
- ]),
- text "}",
- text "",
-
--- if fast == 0:
-
- text "default: {",
- nest 4 (
- text "foreign \"C\" barf(\"" <> fun_ret_label <> text "\");"
- ),
- text "}"
-
- ]),
- text "}"
- ]),
- text "}"
- ]
-
--- -----------------------------------------------------------------------------
--- Making a fast unknown application, args are in regs
-
-genApplyFast regstatus args =
- let
- fun_fast_label = mkApplyFastName args
- fun_ret_label = text "RET_LBL" <> parens (mkApplyName args)
- fun_info_label = mkApplyInfoName args
- all_args_size = sum (map argSize args)
- in
- vcat [
- fun_fast_label,
- char '{',
- nest 4 (vcat [
- text "W_ info;",
- text "W_ arity;",
- text "info = %GET_STD_INFO(R1);",
- text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (%INFO_TYPE(info)) {",
- nest 4 (vcat [
- text "case FUN,",
- text " FUN_1_0,",
- text " FUN_0_1,",
- text " FUN_2_0,",
- text " FUN_1_1,",
- text " FUN_0_2,",
- text " FUN_STATIC: {",
- nest 4 (vcat [
- text "arity = TO_W_(StgFunInfoExtra_arity(%GET_FUN_INFO(R1)));",
- text "ASSERT(arity > 0);",
- genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(R1)" "FUN" "FUN"
- False{-reg apply-} True{-args in regs-} False{-not a PAP-}
- args all_args_size fun_info_label
- ]),
- 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,
- text "jump" <+> fun_ret_label <> semi
- ]),
- char '}'
- ]),
- char '}'
- ]),
- char '}'
- ]
-
--- -----------------------------------------------------------------------------
--- Making a stack apply
-
--- These little functions are like slow entry points. They provide
--- the layer between the PAP entry code and the function's fast entry
--- point: namely they load arguments off the stack into registers (if
--- available) and jump to the function's entry code.
---
--- On entry: R1 points to the function closure
--- arguments are on the stack starting at Sp
---
--- Invariant: the list of arguments never contains void. Since we're only
--- interested in loading arguments off the stack here, we can ignore
--- void arguments.
-
-mkStackApplyEntryLabel:: [ArgRep] -> Doc
-mkStackApplyEntryLabel args = text "stg_ap_stk_" <> text (map showArg args)
-
-genStackApply :: RegStatus -> [ArgRep] -> Doc
-genStackApply regstatus args =
- let fn_entry_label = mkStackApplyEntryLabel args in
- vcat [
- fn_entry_label,
- text "{", nest 4 body, text "}"
- ]
- where
- (assign_regs, sp') = loadRegArgs regstatus 0 args
- body = vcat [assign_regs,
- text "Sp_adj" <> parens (int sp') <> semi,
- text "jump %GET_ENTRY(R1);"
- ]
-
--- -----------------------------------------------------------------------------
--- Stack save entry points.
---
--- These code fragments are used to save registers on the stack at a heap
--- check failure in the entry code for a function. We also have to save R1
--- and the return address (stg_gc_fun_info) on the stack. See stg_gc_fun_gen
--- in HeapStackCheck.hc for more details.
-
-mkStackSaveEntryLabel :: [ArgRep] -> Doc
-mkStackSaveEntryLabel args = text "stg_stk_save_" <> text (map showArg args)
-
-genStackSave :: RegStatus -> [ArgRep] -> Doc
-genStackSave regstatus args =
- let fn_entry_label= mkStackSaveEntryLabel args in
- vcat [
- fn_entry_label,
- text "{", nest 4 body, text "}"
- ]
- where
- body = vcat [text "Sp_adj" <> parens (int (-sp_offset)) <> semi,
- saveRegOffs reg_locs,
- text "Sp(2) = R1;",
- text "Sp(1) =" <+> int stk_args <> semi,
- text "Sp(0) = stg_gc_fun_info;",
- text "jump stg_gc_noregs;"
- ]
-
- std_frame_size = 3 -- the std bits of the frame. See StgRetFun in Closures.h,
- -- and the comment on stg_fun_gc_gen in HeapStackCheck.hc.
- (reg_locs, leftovers, sp_offset) = assignRegs regstatus std_frame_size args
-
- -- number of words of arguments on the stack.
- stk_args = sum (map argSize leftovers) + sp_offset - std_frame_size
-
--- -----------------------------------------------------------------------------
--- The prologue...
-
-main = do
- args <- getArgs
- regstatus <- case args of
- [] -> return Registerised
- ["-u"] -> return Unregisterised
- _other -> do hPutStrLn stderr "syntax: genapply [-u]"
- exitWith (ExitFailure 1)
- let the_code = vcat [
- text "// DO NOT EDIT!",
- text "// Automatically generated by GenApply.hs",
- text "",
- text "#include \"Cmm.h\"",
- text "#include \"AutoApply.h\"",
- text "",
-
- vcat (intersperse (text "") $
- map (genApply regstatus) applyTypes),
- vcat (intersperse (text "") $
- map (genStackFns regstatus) stackApplyTypes),
-
- vcat (intersperse (text "") $
- map (genApplyFast regstatus) applyTypes),
-
- genStackApplyArray stackApplyTypes,
- genStackSaveArray stackApplyTypes,
- genBitmapArray stackApplyTypes,
-
- text "" -- add a newline at the end of the file
- ]
- -- in
- putStr (render the_code)
-
--- These have been shown to cover about 99% of cases in practice...
-applyTypes = [
- [V],
- [F],
- [D],
- [L],
- [N],
- [P],
- [P,V],
- [P,P],
- [P,P,V],
- [P,P,P],
- [P,P,P,V],
- [P,P,P,P],
- [P,P,P,P,P],
- [P,P,P,P,P,P]
- ]
-
--- No need for V args in the stack apply cases.
--- ToDo: the stack apply and stack save code doesn't make a distinction
--- between N and P (they both live in the same register), only the bitmap
--- changes, so we could share the apply/save code between lots of cases.
-stackApplyTypes = [
- [],
- [N],
- [P],
- [F],
- [D],
- [L],
- [N,N],
- [N,P],
- [P,N],
- [P,P],
- [N,N,N],
- [N,N,P],
- [N,P,N],
- [N,P,P],
- [P,N,N],
- [P,N,P],
- [P,P,N],
- [P,P,P],
- [P,P,P,P],
- [P,P,P,P,P],
- [P,P,P,P,P,P],
- [P,P,P,P,P,P,P],
- [P,P,P,P,P,P,P,P]
- ]
-
-genStackFns regstatus args
- = genStackApply regstatus args
- $$ genStackSave regstatus args
-
-
-genStackApplyArray types =
- vcat [
- text "section \"rodata\" {",
- text "stg_ap_stack_entries:",
- text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
- vcat (map arr_ent types),
- text "}"
- ]
- where
- arr_ent ty = text "W_" <+> mkStackApplyEntryLabel ty <> semi
-
-genStackSaveArray types =
- vcat [
- text "section \"rodata\" {",
- text "stg_stack_save_entries:",
- text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
- vcat (map arr_ent types),
- text "}"
- ]
- where
- arr_ent ty = text "W_" <+> mkStackSaveEntryLabel ty <> semi
-
-genBitmapArray :: [[ArgRep]] -> Doc
-genBitmapArray types =
- vcat [
- text "section \"rodata\" {",
- text "stg_arg_bitmaps:",
- text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
- vcat (map gen_bitmap types),
- text "}"
- ]
- where
- gen_bitmap ty = text "W_" <+> int bitmap_val <> semi
- where bitmap_val =
- (fromIntegral (mkBitmap ty) `shiftL` BITMAP_BITS_SHIFT)
- .|. sum (map argSize ty)
-
diff --git a/ghc/utils/genapply/Makefile b/ghc/utils/genapply/Makefile
deleted file mode 100644
index 41084d6c5c..0000000000
--- a/ghc/utils/genapply/Makefile
+++ /dev/null
@@ -1,25 +0,0 @@
-TOP=../..
-include $(TOP)/mk/boilerplate.mk
-
-HS_PROG = $(GHC_GENAPPLY_PGM)
-
-# genapply is needed to boot in ghc/rts...
-ifneq "$(BootingFromHc)" "YES"
-boot :: all
-endif
-
-ifeq "$(ghc_ge_504)" "NO"
-SRC_HC_OPTS += -package lang -package util -package text
-endif
-
-ifeq "$(GhcUnregisterised)" "YES"
-SRC_HC_OPTS += -DNO_REGS
-endif
-
-# Try to get dependencies right...
-SRC_HC_OPTS += -no-recomp
-GenApply.o : $(GHC_INCLUDE_DIR)/ghcconfig.h
-GenApply.o : $(GHC_INCLUDE_DIR)/MachRegs.h
-GenApply.o : $(GHC_INCLUDE_DIR)/Constants.h
-
-include $(TOP)/mk/target.mk
diff --git a/ghc/utils/genprimopcode/Main.hs b/ghc/utils/genprimopcode/Main.hs
deleted file mode 100644
index f08b7d5602..0000000000
--- a/ghc/utils/genprimopcode/Main.hs
+++ /dev/null
@@ -1,787 +0,0 @@
-{-# OPTIONS -cpp #-}
-------------------------------------------------------------------
--- A primop-table mangling program --
-------------------------------------------------------------------
-
-module Main where
-
-#if __GLASGOW_HASKELL__ >= 504
-import Text.ParserCombinators.Parsec
-#else
-import Parsec
-#endif
-
-import Monad
-import Char
-import List
-import System ( getArgs )
-import Maybe ( catMaybes )
-
-main = getArgs >>= \args ->
- if length args /= 1 || head args `notElem` known_args
- then error ("usage: genprimopcode command < primops.txt > ...\n"
- ++ " where command is one of\n"
- ++ unlines (map (" "++) known_args)
- )
- else
- do s <- getContents
- let pres = parse pTop "" s
- case pres of
- Left err -> error ("parse error at " ++ (show err))
- Right p_o_specs
- -> myseq (sanityTop p_o_specs) (
- case head args of
-
- "--data-decl"
- -> putStr (gen_data_decl p_o_specs)
-
- "--has-side-effects"
- -> putStr (gen_switch_from_attribs
- "has_side_effects"
- "primOpHasSideEffects" p_o_specs)
-
- "--out-of-line"
- -> putStr (gen_switch_from_attribs
- "out_of_line"
- "primOpOutOfLine" p_o_specs)
-
- "--commutable"
- -> putStr (gen_switch_from_attribs
- "commutable"
- "commutableOp" p_o_specs)
-
- "--needs-wrapper"
- -> putStr (gen_switch_from_attribs
- "needs_wrapper"
- "primOpNeedsWrapper" p_o_specs)
-
- "--can-fail"
- -> putStr (gen_switch_from_attribs
- "can_fail"
- "primOpCanFail" p_o_specs)
-
- "--strictness"
- -> putStr (gen_switch_from_attribs
- "strictness"
- "primOpStrictness" p_o_specs)
-
- "--usage"
- -> putStr (gen_switch_from_attribs
- "usage"
- "primOpUsg" p_o_specs)
-
- "--primop-primop-info"
- -> putStr (gen_primop_info p_o_specs)
-
- "--primop-tag"
- -> putStr (gen_primop_tag p_o_specs)
-
- "--primop-list"
- -> putStr (gen_primop_list p_o_specs)
-
- "--make-haskell-wrappers"
- -> putStr (gen_wrappers p_o_specs)
-
- "--make-haskell-source"
- -> putStr (gen_hs_source p_o_specs)
-
- "--make-latex-doc"
- -> putStr (gen_latex_doc p_o_specs)
- )
-
-
-known_args
- = [ "--data-decl",
- "--has-side-effects",
- "--out-of-line",
- "--commutable",
- "--needs-wrapper",
- "--can-fail",
- "--strictness",
- "--usage",
- "--primop-primop-info",
- "--primop-tag",
- "--primop-list",
- "--make-haskell-wrappers",
- "--make-haskell-source",
- "--make-latex-doc"
- ]
-
-------------------------------------------------------------------
--- Code generators -----------------------------------------------
-------------------------------------------------------------------
-
-gen_hs_source (Info defaults entries)
- = "module GHC.Prim (\n"
- ++ unlines (map (("\t" ++) . hdr) entries)
- ++ ") where\n\n{-\n"
- ++ unlines (map opt defaults) ++ "-}\n"
- ++ unlines (map ent entries) ++ "\n\n\n"
- where opt (OptionFalse n) = n ++ " = False"
- opt (OptionTrue n) = n ++ " = True"
- opt (OptionString n v) = n ++ " = { " ++ v ++ "}"
-
- hdr s@(Section {}) = sec s
- hdr o@(PrimOpSpec {}) = wrap (name o) ++ ","
-
- ent s@(Section {}) = ""
- ent o@(PrimOpSpec {}) = spec o
-
- sec s = "\n-- * " ++ escape (title s) ++ "\n"
- ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ desc s) ++ "\n"
-
- spec o = comm ++ decl
- where decl = wrap (name o) ++ " :: " ++ pty (ty o)
- comm = case (desc o) of
- [] -> ""
- d -> "\n" ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ d)
-
- pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
- pty t = pbty t
-
- pbty (TyApp tc ts) = tc ++ (concat (map (' ':) (map paty ts)))
- pbty (TyUTup ts) = "(# " ++ (concat (intersperse "," (map pty ts))) ++ " #)"
- pbty t = paty t
-
- paty (TyVar tv) = tv
- paty t = "(" ++ pty t ++ ")"
-
- wrap nm | isLower (head nm) = nm
- | otherwise = "(" ++ nm ++ ")"
- unlatex s = case s of
- '\\':'t':'e':'x':'t':'t':'t':'{':cs -> markup "@" "@" cs
- '{':'\\':'t':'t':cs -> markup "@" "@" cs
- c : cs -> c : unlatex cs
- [] -> []
- markup s t cs = s ++ mk (dropWhile isSpace cs)
- where mk "" = t
- mk ('\n':cs) = ' ' : mk cs
- mk ('}':cs) = t ++ unlatex cs
- mk (c:cs) = c : mk cs
- escape = concatMap (\c -> if c `elem` special then '\\':c:[] else c:[])
- where special = "/'`\"@<"
-
-gen_latex_doc (Info defaults entries)
- = "\\primopdefaults{"
- ++ mk_options defaults
- ++ "}\n"
- ++ (concat (map mk_entry entries))
- where mk_entry (PrimOpSpec {cons=cons,name=name,ty=ty,cat=cat,desc=desc,opts=opts}) =
- "\\primopdesc{"
- ++ latex_encode cons ++ "}{"
- ++ latex_encode name ++ "}{"
- ++ latex_encode (zencode name) ++ "}{"
- ++ latex_encode (show cat) ++ "}{"
- ++ latex_encode (mk_source_ty ty) ++ "}{"
- ++ latex_encode (mk_core_ty ty) ++ "}{"
- ++ desc ++ "}{"
- ++ mk_options opts
- ++ "}\n"
- mk_entry (Section {title=title,desc=desc}) =
- "\\primopsection{"
- ++ latex_encode title ++ "}{"
- ++ desc ++ "}\n"
- mk_source_ty t = pty t
- where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
- pty t = pbty t
- pbty (TyApp tc ts) = tc ++ (concat (map (' ':) (map paty ts)))
- pbty (TyUTup ts) = "(# " ++ (concat (intersperse "," (map pty ts))) ++ " #)"
- pbty t = paty t
- paty (TyVar tv) = tv
- paty t = "(" ++ pty t ++ ")"
-
- mk_core_ty t = foralls ++ (pty t)
- where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
- pty t = pbty t
- pbty (TyApp tc ts) = (zencode tc) ++ (concat (map (' ':) (map paty ts)))
- pbty (TyUTup ts) = (zencode (utuplenm (length ts))) ++ (concat ((map (' ':) (map paty ts))))
- pbty t = paty t
- paty (TyVar tv) = zencode tv
- paty (TyApp tc []) = zencode tc
- paty t = "(" ++ pty t ++ ")"
- utuplenm 1 = "(# #)"
- utuplenm n = "(#" ++ (replicate (n-1) ',') ++ "#)"
- foralls = if tvars == [] then "" else "%forall " ++ (tbinds tvars)
- tvars = tvars_of t
- tbinds [] = ". "
- tbinds ("o":tbs) = "(o::?) " ++ (tbinds tbs)
- tbinds (tv:tbs) = tv ++ " " ++ (tbinds tbs)
- tvars_of (TyF t1 t2) = tvars_of t1 `union` tvars_of t2
- tvars_of (TyApp tc ts) = foldl union [] (map tvars_of ts)
- tvars_of (TyUTup ts) = foldr union [] (map tvars_of ts)
- tvars_of (TyVar tv) = [tv]
-
- mk_options opts =
- "\\primoptions{"
- ++ mk_has_side_effects opts ++ "}{"
- ++ mk_out_of_line opts ++ "}{"
- ++ mk_commutable opts ++ "}{"
- ++ mk_needs_wrapper opts ++ "}{"
- ++ mk_can_fail opts ++ "}{"
- ++ latex_encode (mk_strictness opts) ++ "}{"
- ++ latex_encode (mk_usage opts)
- ++ "}"
-
- mk_has_side_effects opts = mk_bool_opt opts "has_side_effects" "Has side effects." "Has no side effects."
- mk_out_of_line opts = mk_bool_opt opts "out_of_line" "Implemented out of line." "Implemented in line."
- mk_commutable opts = mk_bool_opt opts "commutable" "Commutable." "Not commutable."
- mk_needs_wrapper opts = mk_bool_opt opts "needs_wrapper" "Needs wrapper." "Needs no wrapper."
- mk_can_fail opts = mk_bool_opt opts "can_fail" "Can fail." "Cannot fail."
-
- mk_bool_opt opts opt_name if_true if_false =
- case lookup_attrib opt_name opts of
- Just (OptionTrue _) -> if_true
- Just (OptionFalse _) -> if_false
- Nothing -> ""
-
- mk_strictness opts =
- case lookup_attrib "strictness" opts of
- Just (OptionString _ s) -> s -- for now
- Nothing -> ""
-
- mk_usage opts =
- case lookup_attrib "usage" opts of
- Just (OptionString _ s) -> s -- for now
- Nothing -> ""
-
- zencode cs =
- case maybe_tuple cs of
- Just n -> n -- Tuples go to Z2T etc
- Nothing -> concat (map encode_ch cs)
- where
- maybe_tuple "(# #)" = Just("Z1H")
- maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of
- (n, '#' : ')' : cs) -> Just ('Z' : shows (n+1) "H")
- other -> Nothing
- maybe_tuple "()" = Just("Z0T")
- maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of
- (n, ')' : cs) -> Just ('Z' : shows (n+1) "T")
- other -> Nothing
- maybe_tuple other = Nothing
-
- count_commas :: Int -> String -> (Int, String)
- count_commas n (',' : cs) = count_commas (n+1) cs
- count_commas n cs = (n,cs)
-
- unencodedChar :: Char -> Bool -- True for chars that don't need encoding
- unencodedChar 'Z' = False
- unencodedChar 'z' = False
- unencodedChar c = isAlphaNum c
-
- encode_ch :: Char -> String
- encode_ch c | unencodedChar c = [c] -- Common case first
-
- -- Constructors
- encode_ch '(' = "ZL" -- Needed for things like (,), and (->)
- encode_ch ')' = "ZR" -- For symmetry with (
- encode_ch '[' = "ZM"
- encode_ch ']' = "ZN"
- encode_ch ':' = "ZC"
- encode_ch 'Z' = "ZZ"
-
- -- Variables
- encode_ch 'z' = "zz"
- encode_ch '&' = "za"
- encode_ch '|' = "zb"
- encode_ch '^' = "zc"
- encode_ch '$' = "zd"
- encode_ch '=' = "ze"
- encode_ch '>' = "zg"
- encode_ch '#' = "zh"
- encode_ch '.' = "zi"
- encode_ch '<' = "zl"
- encode_ch '-' = "zm"
- encode_ch '!' = "zn"
- encode_ch '+' = "zp"
- encode_ch '\'' = "zq"
- encode_ch '\\' = "zr"
- encode_ch '/' = "zs"
- encode_ch '*' = "zt"
- encode_ch '_' = "zu"
- encode_ch '%' = "zv"
- encode_ch c = 'z' : shows (ord c) "U"
-
- latex_encode [] = []
- latex_encode (c:cs) | c `elem` "#$%&_^{}" = "\\" ++ c:(latex_encode cs)
- latex_encode ('~':cs) = "\\verb!~!" ++ (latex_encode cs)
- latex_encode ('\\':cs) = "$\\backslash$" ++ (latex_encode cs)
- latex_encode (c:cs) = c:(latex_encode cs)
-
-gen_wrappers (Info defaults entries)
- = "{-# OPTIONS -fno-implicit-prelude #-}\n"
- -- Dependencies on Prelude must be explicit in libraries/base, but we
- -- don't need the Prelude here so we add -fno-implicit-prelude.
- ++ "module GHC.PrimopWrappers where\n"
- ++ "import qualified GHC.Prim\n"
- ++ unlines (map f (filter (not.dodgy) (filter is_primop entries)))
- where
- f spec = let args = map (\n -> "a" ++ show n) [1 .. arity (ty spec)]
- src_name = wrap (name spec)
- in "{-# NOINLINE " ++ src_name ++ " #-}\n" ++
- src_name ++ " " ++ unwords args
- ++ " = (GHC.Prim." ++ name spec ++ ") " ++ unwords args
- wrap nm | isLower (head nm) = nm
- | otherwise = "(" ++ nm ++ ")"
-
- dodgy spec
- = name spec `elem`
- [-- C code generator can't handle these
- "seq#",
- "tagToEnum#",
- -- not interested in parallel support
- "par#", "parGlobal#", "parLocal#", "parAt#",
- "parAtAbs#", "parAtRel#", "parAtForNow#"
- ]
-
-
-gen_primop_list (Info defaults entries)
- = unlines (
- [ " [" ++ cons first ]
- ++
- map (\pi -> " , " ++ cons pi) rest
- ++
- [ " ]" ]
- ) where (first:rest) = filter is_primop entries
-
-gen_primop_tag (Info defaults entries)
- = unlines (max_def : zipWith f primop_entries [1..])
- where
- primop_entries = filter is_primop entries
- f i n = "tagOf_PrimOp " ++ cons i
- ++ " = _ILIT(" ++ show n ++ ") :: FastInt"
- max_def = "maxPrimOpTag = " ++ show (length primop_entries) ++ " :: Int"
-
-gen_data_decl (Info defaults entries)
- = let conss = map cons (filter is_primop entries)
- in "data PrimOp\n = " ++ head conss ++ "\n"
- ++ unlines (map (" | "++) (tail conss))
-
-gen_switch_from_attribs :: String -> String -> Info -> String
-gen_switch_from_attribs attrib_name fn_name (Info defaults entries)
- = let defv = lookup_attrib attrib_name defaults
- alts = catMaybes (map mkAlt (filter is_primop entries))
-
- getAltRhs (OptionFalse _) = "False"
- getAltRhs (OptionTrue _) = "True"
- getAltRhs (OptionString _ s) = s
-
- mkAlt po
- = case lookup_attrib attrib_name (opts po) of
- Nothing -> Nothing
- Just xx -> Just (fn_name ++ " " ++ cons po ++ " = " ++ getAltRhs xx)
-
- in
- case defv of
- Nothing -> error ("gen_switch_from: " ++ attrib_name)
- Just xx
- -> unlines alts
- ++ fn_name ++ " other = " ++ getAltRhs xx ++ "\n"
-
-------------------------------------------------------------------
--- Create PrimOpInfo text from PrimOpSpecs -----------------------
-------------------------------------------------------------------
-
-
-gen_primop_info (Info defaults entries)
- = unlines (map mkPOItext (filter is_primop entries))
-
-mkPOItext i = mkPOI_LHS_text i ++ mkPOI_RHS_text i
-
-mkPOI_LHS_text i
- = "primOpInfo " ++ cons i ++ " = "
-
-mkPOI_RHS_text i
- = case cat i of
- Compare
- -> case ty i of
- TyF t1 (TyF t2 td)
- -> "mkCompare " ++ sl_name i ++ ppType t1
- Monadic
- -> case ty i of
- TyF t1 td
- -> "mkMonadic " ++ sl_name i ++ ppType t1
- Dyadic
- -> case ty i of
- TyF t1 (TyF t2 td)
- -> "mkDyadic " ++ sl_name i ++ ppType t1
- GenPrimOp
- -> let (argTys, resTy) = flatTys (ty i)
- tvs = nub (tvsIn (ty i))
- in
- "mkGenPrimOp " ++ sl_name i ++ " "
- ++ listify (map ppTyVar tvs) ++ " "
- ++ listify (map ppType argTys) ++ " "
- ++ "(" ++ ppType resTy ++ ")"
-
-sl_name i = "FSLIT(\"" ++ name i ++ "\") "
-
-ppTyVar "a" = "alphaTyVar"
-ppTyVar "b" = "betaTyVar"
-ppTyVar "c" = "gammaTyVar"
-ppTyVar "s" = "deltaTyVar"
-ppTyVar "o" = "openAlphaTyVar"
-
-
-ppType (TyApp "Bool" []) = "boolTy"
-
-ppType (TyApp "Int#" []) = "intPrimTy"
-ppType (TyApp "Int32#" []) = "int32PrimTy"
-ppType (TyApp "Int64#" []) = "int64PrimTy"
-ppType (TyApp "Char#" []) = "charPrimTy"
-ppType (TyApp "Word#" []) = "wordPrimTy"
-ppType (TyApp "Word32#" []) = "word32PrimTy"
-ppType (TyApp "Word64#" []) = "word64PrimTy"
-ppType (TyApp "Addr#" []) = "addrPrimTy"
-ppType (TyApp "Float#" []) = "floatPrimTy"
-ppType (TyApp "Double#" []) = "doublePrimTy"
-ppType (TyApp "ByteArr#" []) = "byteArrayPrimTy"
-ppType (TyApp "RealWorld" []) = "realWorldTy"
-ppType (TyApp "ThreadId#" []) = "threadIdPrimTy"
-ppType (TyApp "ForeignObj#" []) = "foreignObjPrimTy"
-ppType (TyApp "BCO#" []) = "bcoPrimTy"
-ppType (TyApp "()" []) = "unitTy" -- unitTy is TysWiredIn's name for ()
-
-
-ppType (TyVar "a") = "alphaTy"
-ppType (TyVar "b") = "betaTy"
-ppType (TyVar "c") = "gammaTy"
-ppType (TyVar "s") = "deltaTy"
-ppType (TyVar "o") = "openAlphaTy"
-ppType (TyApp "State#" [x]) = "mkStatePrimTy " ++ ppType x
-ppType (TyApp "MutVar#" [x,y]) = "mkMutVarPrimTy " ++ ppType x
- ++ " " ++ ppType y
-ppType (TyApp "MutArr#" [x,y]) = "mkMutableArrayPrimTy " ++ ppType x
- ++ " " ++ ppType y
-
-ppType (TyApp "MutByteArr#" [x]) = "mkMutableByteArrayPrimTy "
- ++ ppType x
-
-ppType (TyApp "Array#" [x]) = "mkArrayPrimTy " ++ ppType x
-
-
-ppType (TyApp "Weak#" [x]) = "mkWeakPrimTy " ++ ppType x
-ppType (TyApp "StablePtr#" [x]) = "mkStablePtrPrimTy " ++ ppType x
-ppType (TyApp "StableName#" [x]) = "mkStableNamePrimTy " ++ ppType x
-
-ppType (TyApp "MVar#" [x,y]) = "mkMVarPrimTy " ++ ppType x
- ++ " " ++ ppType y
-ppType (TyApp "TVar#" [x,y]) = "mkTVarPrimTy " ++ ppType x
- ++ " " ++ ppType y
-ppType (TyUTup ts) = "(mkTupleTy Unboxed " ++ show (length ts)
- ++ " "
- ++ listify (map ppType ts) ++ ")"
-
-ppType (TyF s d) = "(mkFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))"
-
-ppType other
- = error ("ppType: can't handle: " ++ show other ++ "\n")
-
-listify :: [String] -> String
-listify ss = "[" ++ concat (intersperse ", " ss) ++ "]"
-
-flatTys (TyF t1 t2) = case flatTys t2 of (ts,t) -> (t1:ts,t)
-flatTys other = ([],other)
-
-tvsIn (TyF t1 t2) = tvsIn t1 ++ tvsIn t2
-tvsIn (TyApp tc tys) = concatMap tvsIn tys
-tvsIn (TyVar tv) = [tv]
-tvsIn (TyUTup tys) = concatMap tvsIn tys
-
-arity = length . fst . flatTys
-
-
-------------------------------------------------------------------
--- Abstract syntax -----------------------------------------------
-------------------------------------------------------------------
-
--- info for all primops; the totality of the info in primops.txt(.pp)
-data Info
- = Info [Option] [Entry] -- defaults, primops
- deriving Show
-
--- info for one primop
-data Entry
- = PrimOpSpec { cons :: String, -- PrimOp name
- name :: String, -- name in prog text
- ty :: Ty, -- type
- cat :: Category, -- category
- desc :: String, -- description
- opts :: [Option] } -- default overrides
- | Section { title :: String, -- section title
- desc :: String } -- description
- deriving Show
-
-is_primop (PrimOpSpec _ _ _ _ _ _) = True
-is_primop _ = False
-
--- a binding of property to value
-data Option
- = OptionFalse String -- name = False
- | OptionTrue String -- name = True
- | OptionString String String -- name = { ... unparsed stuff ... }
- deriving Show
-
--- categorises primops
-data Category
- = Dyadic | Monadic | Compare | GenPrimOp
- deriving Show
-
--- types
-data Ty
- = TyF Ty Ty
- | TyApp TyCon [Ty]
- | TyVar TyVar
- | TyUTup [Ty] -- unboxed tuples; just a TyCon really,
- -- but convenient like this
- deriving (Eq,Show)
-
-type TyVar = String
-type TyCon = String
-
-
-------------------------------------------------------------------
--- Sanity checking -----------------------------------------------
-------------------------------------------------------------------
-
-{- Do some simple sanity checks:
- * all the default field names are unique
- * for each PrimOpSpec, all override field names are unique
- * for each PrimOpSpec, all overriden field names
- have a corresponding default value
- * that primop types correspond in certain ways to the
- Category: eg if Comparison, the type must be of the form
- T -> T -> Bool.
- Dies with "error" if there's a problem, else returns ().
--}
-myseq () x = x
-myseqAll (():ys) x = myseqAll ys x
-myseqAll [] x = x
-
-sanityTop :: Info -> ()
-sanityTop (Info defs entries)
- = let opt_names = map get_attrib_name defs
- primops = filter is_primop entries
- in
- if length opt_names /= length (nub opt_names)
- then error ("non-unique default attribute names: " ++ show opt_names ++ "\n")
- else myseqAll (map (sanityPrimOp opt_names) primops) ()
-
-sanityPrimOp def_names p
- = let p_names = map get_attrib_name (opts p)
- p_names_ok
- = length p_names == length (nub p_names)
- && all (`elem` def_names) p_names
- ty_ok = sane_ty (cat p) (ty p)
- in
- if not p_names_ok
- then error ("attribute names are non-unique or have no default in\n" ++
- "info for primop " ++ cons p ++ "\n")
- else
- if not ty_ok
- then error ("type of primop " ++ cons p ++ " doesn't make sense w.r.t" ++
- " category " ++ show (cat p) ++ "\n")
- else ()
-
-sane_ty Compare (TyF t1 (TyF t2 td))
- | t1 == t2 && td == TyApp "Bool" [] = True
-sane_ty Monadic (TyF t1 td)
- | t1 == td = True
-sane_ty Dyadic (TyF t1 (TyF t2 td))
- | t1 == t2 && t2 == t2 = True
-sane_ty GenPrimOp any_old_thing
- = True
-sane_ty _ _
- = False
-
-get_attrib_name (OptionFalse nm) = nm
-get_attrib_name (OptionTrue nm) = nm
-get_attrib_name (OptionString nm _) = nm
-
-lookup_attrib nm [] = Nothing
-lookup_attrib nm (a:as)
- = if get_attrib_name a == nm then Just a else lookup_attrib nm as
-
-------------------------------------------------------------------
--- The parser ----------------------------------------------------
-------------------------------------------------------------------
-
--- Due to lack of proper lexing facilities, a hack to zap any
--- leading comments
-pTop :: Parser Info
-pTop = then4 (\_ ds es _ -> Info ds es)
- pCommentAndWhitespace pDefaults (many pEntry)
- (lit "thats_all_folks")
-
-pEntry :: Parser Entry
-pEntry
- = alts [pPrimOpSpec, pSection]
-
-pSection :: Parser Entry
-pSection = then3 (\_ n d -> Section {title = n, desc = d})
- (lit "section") stringLiteral pDesc
-
-pDefaults :: Parser [Option]
-pDefaults = then2 sel22 (lit "defaults") (many pOption)
-
-pOption :: Parser Option
-pOption
- = alts [
- then3 (\nm eq ff -> OptionFalse nm) pName (lit "=") (lit "False"),
- then3 (\nm eq tt -> OptionTrue nm) pName (lit "=") (lit "True"),
- then3 (\nm eq zz -> OptionString nm zz)
- pName (lit "=") pStuffBetweenBraces
- ]
-
-pPrimOpSpec :: Parser Entry
-pPrimOpSpec
- = then7 (\_ c n k t d o -> PrimOpSpec { cons = c, name = n, ty = t,
- cat = k, desc = d, opts = o } )
- (lit "primop") pConstructor stringLiteral
- pCategory pType pDesc pOptions
-
-pOptions :: Parser [Option]
-pOptions = optdef [] (then2 sel22 (lit "with") (many pOption))
-
-pCategory :: Parser Category
-pCategory
- = alts [
- apply (const Dyadic) (lit "Dyadic"),
- apply (const Monadic) (lit "Monadic"),
- apply (const Compare) (lit "Compare"),
- apply (const GenPrimOp) (lit "GenPrimOp")
- ]
-
-pDesc :: Parser String
-pDesc = optdef "" pStuffBetweenBraces
-
-pStuffBetweenBraces :: Parser String
-pStuffBetweenBraces
- = lexeme (
- do char '{'
- ass <- many pInsides
- char '}'
- return (concat ass) )
-
-pInsides :: Parser String
-pInsides
- = (do char '{'
- stuff <- many pInsides
- char '}'
- return ("{" ++ (concat stuff) ++ "}"))
- <|>
- (do c <- satisfy (/= '}')
- return [c])
-
-
-
--------------------
--- Parsing types --
--------------------
-
-pType :: Parser Ty
-pType = then2 (\t maybe_tt -> case maybe_tt of
- Just tt -> TyF t tt
- Nothing -> t)
- paT
- (opt (then2 sel22 (lit "->") pType))
-
--- Atomic types
-paT = alts [ then2 TyApp pTycon (many ppT),
- pUnboxedTupleTy,
- then3 sel23 (lit "(") pType (lit ")"),
- ppT
- ]
-
--- the magic bit in the middle is: T (,T)* so to speak
-pUnboxedTupleTy
- = then3 (\ _ ts _ -> TyUTup ts)
- (lit "(#")
- (then2 (:) pType (many (then2 sel22 (lit ",") pType)))
- (lit "#)")
-
--- Primitive types
-ppT = alts [apply TyVar pTyvar,
- apply (\tc -> TyApp tc []) pTycon
- ]
-
-pTyvar = sat (`notElem` ["section","primop","with"]) pName
-pTycon = alts [pConstructor, lexeme (string "()")]
-pName = lexeme (then2 (:) lower (many isIdChar))
-pConstructor = lexeme (then2 (:) upper (many isIdChar))
-
-isIdChar = satisfy (`elem` idChars)
-idChars = ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ "#_"
-
-sat pred p
- = do x <- try p
- if pred x
- then return x
- else pzero
-
-------------------------------------------------------------------
--- Helpful additions to Daan's parser stuff ----------------------
-------------------------------------------------------------------
-
-alts [p1] = try p1
-alts (p1:p2:ps) = (try p1) <|> alts (p2:ps)
-
-then2 f p1 p2
- = do x1 <- p1 ; x2 <- p2 ; return (f x1 x2)
-then3 f p1 p2 p3
- = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; return (f x1 x2 x3)
-then4 f p1 p2 p3 p4
- = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; x4 <- p4 ; return (f x1 x2 x3 x4)
-then5 f p1 p2 p3 p4 p5
- = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; x4 <- p4 ; x5 <- p5
- return (f x1 x2 x3 x4 x5)
-then6 f p1 p2 p3 p4 p5 p6
- = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; x4 <- p4 ; x5 <- p5 ; x6 <- p6
- return (f x1 x2 x3 x4 x5 x6)
-then7 f p1 p2 p3 p4 p5 p6 p7
- = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; x4 <- p4 ; x5 <- p5 ; x6 <- p6 ; x7 <- p7
- return (f x1 x2 x3 x4 x5 x6 x7)
-opt p
- = (do x <- p; return (Just x)) <|> return Nothing
-optdef d p
- = (do x <- p; return x) <|> return d
-
-sel12 a b = a
-sel22 a b = b
-sel23 a b c = b
-apply f p = liftM f p
-
--- Hacks for zapping whitespace and comments, unfortunately needed
--- because Daan won't let us have a lexer before the parser :-(
-lexeme :: Parser p -> Parser p
-lexeme p = then2 sel12 p pCommentAndWhitespace
-
-lit :: String -> Parser ()
-lit s = apply (const ()) (lexeme (string s))
-
-pCommentAndWhitespace :: Parser ()
-pCommentAndWhitespace
- = apply (const ()) (many (alts [pLineComment,
- apply (const ()) (satisfy isSpace)]))
- <|>
- return ()
-
-pLineComment :: Parser ()
-pLineComment
- = try (then3 (\_ _ _ -> ()) (string "--") (many (satisfy (/= '\n'))) (char '\n'))
-
-stringLiteral :: Parser String
-stringLiteral = lexeme (
- do { between (char '"')
- (char '"' <?> "end of string")
- (many (noneOf "\""))
- }
- <?> "literal string")
-
-
-
-------------------------------------------------------------------
--- end --
-------------------------------------------------------------------
-
-
-
diff --git a/ghc/utils/genprimopcode/Makefile b/ghc/utils/genprimopcode/Makefile
deleted file mode 100644
index dbd69f6d42..0000000000
--- a/ghc/utils/genprimopcode/Makefile
+++ /dev/null
@@ -1,19 +0,0 @@
-TOP=../..
-include $(TOP)/mk/boilerplate.mk
-
-HS_PROG = genprimopcode
-
-ifeq "$(ghc_ge_504)" "NO"
-SRC_HC_OPTS += -package text
-endif
-
-ifeq "$(ghc_ge_602)" "YES"
-SRC_HC_OPTS += -package parsec
-endif
-
-# genprimopcode is needed to boot in ghc/compiler...
-ifneq "$(BootingFromHc)" "YES"
-boot :: all
-endif
-
-include $(TOP)/mk/target.mk
diff --git a/ghc/utils/ghc-pkg/Main.hs b/ghc/utils/ghc-pkg/Main.hs
deleted file mode 100644
index fb3ef07c3f..0000000000
--- a/ghc/utils/ghc-pkg/Main.hs
+++ /dev/null
@@ -1,1184 +0,0 @@
-{-# OPTIONS -fglasgow-exts #-}
------------------------------------------------------------------------------
---
--- (c) The University of Glasgow 2004.
---
--- Package management tool
---
------------------------------------------------------------------------------
-
--- TODO:
--- - validate modules
--- - expanding of variables in new-style package conf
--- - version manipulation (checking whether old version exists,
--- hiding old version?)
-
-module Main (main) where
-
-import Version ( version, targetOS, targetARCH )
-import Distribution.InstalledPackageInfo
-import Distribution.Compat.ReadP
-import Distribution.ParseUtils ( showError )
-import Distribution.Package
-import Distribution.Version
-import Compat.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
-import Compat.RawSystem ( rawSystem )
-
-import Prelude
-
-#include "../../includes/ghcconfig.h"
-
-#if __GLASGOW_HASKELL__ >= 504
-import System.Console.GetOpt
-import Text.PrettyPrint
-import qualified Control.Exception as Exception
-import Data.Maybe
-#else
-import GetOpt
-import Pretty
-import qualified Exception
-import Maybe
-#endif
-
-import Data.Char ( isSpace )
-import Monad
-import Directory
-import System ( getArgs, getProgName, getEnv,
- exitWith, ExitCode(..)
- )
-import System.IO
-#if __GLASGOW_HASKELL__ >= 600
-import System.IO.Error (try)
-#else
-import System.IO (try)
-#endif
-import Data.List ( isPrefixOf, isSuffixOf, intersperse, groupBy, sortBy )
-
-#ifdef mingw32_HOST_OS
-import Foreign
-
-#if __GLASGOW_HASKELL__ >= 504
-import Foreign.C.String
-#else
-import CString
-#endif
-#endif
-
--- -----------------------------------------------------------------------------
--- Entry point
-
-main :: IO ()
-main = do
- args <- getArgs
-
- case getOpt Permute flags args of
- (cli,_,[]) | FlagHelp `elem` cli -> do
- prog <- getProgramName
- bye (usageInfo (usageHeader prog) flags)
- (cli,_,[]) | FlagVersion `elem` cli ->
- bye ourCopyright
- (cli,nonopts,[]) ->
- runit cli nonopts
- (_,_,errors) -> tryOldCmdLine errors args
-
--- If the new command-line syntax fails, then we try the old. If that
--- fails too, then we output the original errors and the new syntax
--- (so the old syntax is still available, but hidden).
-tryOldCmdLine :: [String] -> [String] -> IO ()
-tryOldCmdLine errors args = do
- case getOpt Permute oldFlags args of
- (cli@(_:_),[],[]) ->
- oldRunit cli
- _failed -> do
- prog <- getProgramName
- die (concat errors ++ usageInfo (usageHeader prog) flags)
-
--- -----------------------------------------------------------------------------
--- Command-line syntax
-
-data Flag
- = FlagUser
- | FlagGlobal
- | FlagHelp
- | FlagVersion
- | FlagConfig FilePath
- | FlagGlobalConfig FilePath
- | FlagForce
- | FlagAutoGHCiLibs
- | FlagDefinedName String String
- | FlagSimpleOutput
- deriving Eq
-
-flags :: [OptDescr Flag]
-flags = [
- Option [] ["user"] (NoArg FlagUser)
- "use the current user's package database",
- Option [] ["global"] (NoArg FlagGlobal)
- "(default) use the global package database",
- Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE")
- "act upon specified package config file (only)",
- Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE")
- "location of the global package config",
- Option [] ["force"] (NoArg FlagForce)
- "ignore missing dependencies, directories, and libraries",
- Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
- "automatically build libs for GHCi (with register)",
- Option ['?'] ["help"] (NoArg FlagHelp)
- "display this help and exit",
- Option ['D'] ["define-name"] (ReqArg toDefined "NAME=VALUE")
- "define NAME as VALUE",
- Option ['V'] ["version"] (NoArg FlagVersion)
- "output version information and exit",
- Option [] ["simple-output"] (NoArg FlagSimpleOutput)
- "print output in easy-to-parse format when running command 'list'"
- ]
- where
- toDefined str =
- case break (=='=') str of
- (nm,[]) -> FlagDefinedName nm []
- (nm,_:val) -> FlagDefinedName nm val
-
-ourCopyright :: String
-ourCopyright = "GHC package manager version " ++ version ++ "\n"
-
-usageHeader :: String -> String
-usageHeader prog = substProg prog $
- "Usage:\n" ++
- " $p register {filename | -}\n" ++
- " Register the package using the specified installed package\n" ++
- " description. The syntax for the latter is given in the $p\n" ++
- " documentation.\n" ++
- "\n" ++
- " $p update {filename | -}\n" ++
- " Register the package, overwriting any other package with the\n" ++
- " same name.\n" ++
- "\n" ++
- " $p unregister {pkg-id}\n" ++
- " Unregister the specified package.\n" ++
- "\n" ++
- " $p expose {pkg-id}\n" ++
- " Expose the specified package.\n" ++
- "\n" ++
- " $p hide {pkg-id}\n" ++
- " Hide the specified package.\n" ++
- "\n" ++
- " $p list [pkg]\n" ++
- " List registered packages in the global database, and also the\n" ++
- " user database if --user is given. If a package name is given\n" ++
- " all the registered versions will be listed in ascending order.\n" ++
- "\n" ++
- " $p latest pkg\n" ++
- " Prints the highest registered version of a package.\n" ++
- "\n" ++
- " $p describe {pkg-id}\n" ++
- " Give the registered description for the specified package. The\n" ++
- " description is returned in precisely the syntax required by $p\n" ++
- " register.\n" ++
- "\n" ++
- " $p field {pkg-id} {field}\n" ++
- " Extract the specified field of the package description for the\n" ++
- " specified package.\n" ++
- "\n" ++
- " The following optional flags are also accepted:\n"
-
-substProg :: String -> String -> String
-substProg _ [] = []
-substProg prog ('$':'p':xs) = prog ++ substProg prog xs
-substProg prog (c:xs) = c : substProg prog xs
-
--- -----------------------------------------------------------------------------
--- Do the business
-
-runit :: [Flag] -> [String] -> IO ()
-runit cli nonopts = do
- prog <- getProgramName
- let
- force = FlagForce `elem` cli
- auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
- defines = [ (nm,val) | FlagDefinedName nm val <- cli ]
- --
- -- first, parse the command
- case nonopts of
- ["register", filename] ->
- registerPackage filename defines cli auto_ghci_libs False force
- ["update", filename] ->
- registerPackage filename defines cli auto_ghci_libs True force
- ["unregister", pkgid_str] -> do
- pkgid <- readGlobPkgId pkgid_str
- unregisterPackage pkgid cli
- ["expose", pkgid_str] -> do
- pkgid <- readGlobPkgId pkgid_str
- exposePackage pkgid cli
- ["hide", pkgid_str] -> do
- pkgid <- readGlobPkgId pkgid_str
- hidePackage pkgid cli
- ["list"] -> do
- listPackages cli Nothing
- ["list", pkgid_str] -> do
- pkgid <- readGlobPkgId pkgid_str
- listPackages cli (Just pkgid)
- ["latest", pkgid_str] -> do
- pkgid <- readGlobPkgId pkgid_str
- latestPackage cli pkgid
- ["describe", pkgid_str] -> do
- pkgid <- readGlobPkgId pkgid_str
- describePackage cli pkgid
- ["field", pkgid_str, field] -> do
- pkgid <- readGlobPkgId pkgid_str
- describeField cli pkgid field
- [] -> do
- die ("missing command\n" ++
- usageInfo (usageHeader prog) flags)
- (_cmd:_) -> do
- die ("command-line syntax error\n" ++
- usageInfo (usageHeader prog) flags)
-
-parseCheck :: ReadP a a -> String -> String -> IO a
-parseCheck parser str what =
- case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
- [x] -> return x
- _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
-
-readPkgId :: String -> IO PackageIdentifier
-readPkgId str = parseCheck parsePackageId str "package identifier"
-
-readGlobPkgId :: String -> IO PackageIdentifier
-readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"
-
-parseGlobPackageId :: ReadP r PackageIdentifier
-parseGlobPackageId =
- parsePackageId
- +++
- (do n <- parsePackageName; string "-*"
- return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
-
--- globVersion means "all versions"
-globVersion :: Version
-globVersion = Version{ versionBranch=[], versionTags=["*"] }
-
--- -----------------------------------------------------------------------------
--- Package databases
-
--- Some commands operate on a single database:
--- register, unregister, expose, hide
--- however these commands also check the union of the available databases
--- in order to check consistency. For example, register will check that
--- dependencies exist before registering a package.
---
--- Some commands operate on multiple databases, with overlapping semantics:
--- list, describe, field
-
-type PackageDBName = FilePath
-type PackageDB = [InstalledPackageInfo]
-
-type PackageDBStack = [(PackageDBName,PackageDB)]
- -- A stack of package databases. Convention: head is the topmost
- -- in the stack. Earlier entries override later one.
-
-getPkgDatabases :: Bool -> [Flag] -> IO PackageDBStack
-getPkgDatabases modify 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
- -- wrapper script.
- let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
- global_conf <-
- case [ f | FlagGlobalConfig f <- flags ] of
- [] -> do mb_dir <- getExecDir "/bin/ghc-pkg.exe"
- case mb_dir of
- Nothing -> die err_msg
- Just dir -> return (dir `joinFileName` "package.conf")
- fs -> return (last fs)
-
- let global_conf_dir = global_conf ++ ".d"
- global_conf_dir_exists <- doesDirectoryExist global_conf_dir
- global_confs <-
- if global_conf_dir_exists
- then do files <- getDirectoryContents global_conf_dir
- return [ global_conf_dir ++ '/' : file
- | file <- files
- , isSuffixOf ".conf" file]
- else return []
-
- -- get the location of the user package database, and create it if necessary
- appdir <- getAppUserDataDirectory "ghc"
-
- let
- subdir = targetARCH ++ '-':targetOS ++ '-':version
- archdir = appdir `joinFileName` subdir
- user_conf = archdir `joinFileName` "package.conf"
- user_exists <- doesFileExist user_conf
-
- -- If the user database doesn't exist, and this command isn't a
- -- "modify" command, then we won't attempt to create or use it.
- let sys_databases
- | modify || user_exists = user_conf : global_confs ++ [global_conf]
- | otherwise = global_confs ++ [global_conf]
-
- e_pkg_path <- try (getEnv "GHC_PACKAGE_PATH")
- let env_stack =
- case e_pkg_path of
- Left _ -> sys_databases
- Right path
- | last cs == "" -> init cs ++ sys_databases
- | otherwise -> cs
- where cs = parseSearchPath path
-
- -- The "global" database is always the one at the bottom of the stack.
- -- This is the database we modify by default.
- virt_global_conf = last env_stack
-
- -- -f flags on the command line add to the database stack, unless any
- -- of them are present in the stack already.
- let flag_stack = filter (`notElem` env_stack)
- [ f | FlagConfig f <- reverse flags ] ++ env_stack
-
- -- Now we have the full stack of databases. Next, if the current
- -- command is a "modify" type command, then we truncate the stack
- -- so that the topmost element is the database being modified.
- final_stack <-
- if not modify
- then return flag_stack
- else let
- go (FlagUser : fs) = modifying user_conf
- go (FlagGlobal : fs) = modifying virt_global_conf
- go (FlagConfig f : fs) = modifying f
- go (_ : fs) = go fs
- go [] = modifying virt_global_conf
-
- modifying f
- | f `elem` flag_stack = return (dropWhile (/= f) flag_stack)
- | otherwise = die ("requesting modification of database:\n\t" ++ f ++ "\n\twhich is not in the database stack.")
- in
- go flags
-
- -- we create the user database iff (a) we're modifying, and (b) the
- -- user asked to use it by giving the --user flag.
- when (not user_exists && user_conf `elem` final_stack) $ do
- putStrLn ("Creating user package database in " ++ user_conf)
- createDirectoryIfMissing True archdir
- writeFile user_conf emptyPackageConfig
-
- db_stack <- mapM readParseDatabase final_stack
- return db_stack
-
-readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB)
-readParseDatabase filename = do
- str <- readFile filename
- let packages = read str
- Exception.evaluate packages
- `Exception.catch` \_ ->
- die (filename ++ ": parse error in package config file")
- return (filename,packages)
-
-emptyPackageConfig :: String
-emptyPackageConfig = "[]"
-
--- -----------------------------------------------------------------------------
--- Registering
-
-registerPackage :: FilePath
- -> [(String,String)] -- defines
- -> [Flag]
- -> Bool -- auto_ghci_libs
- -> Bool -- update
- -> Bool -- force
- -> IO ()
-registerPackage input defines flags auto_ghci_libs update force = do
- db_stack <- getPkgDatabases True flags
- let
- db_to_operate_on = my_head "db" db_stack
- db_filename = fst db_to_operate_on
- --
- checkConfigAccess db_filename
-
- s <-
- case input of
- "-" -> do
- putStr "Reading package info from stdin ... "
- getContents
- f -> do
- putStr ("Reading package info from " ++ show f ++ " ... ")
- readFile f
-
- expanded <- expandEnvVars s defines force
-
- pkg0 <- parsePackageInfo expanded defines force
- putStrLn "done."
-
- let pkg = resolveDeps db_stack pkg0
- overlaps <- validatePackageConfig pkg db_stack auto_ghci_libs update force
- new_details <- updatePackageDB db_stack overlaps (snd db_to_operate_on) pkg
- savePackageConfig db_filename
- maybeRestoreOldConfig db_filename $
- writeNewConfig db_filename new_details
-
-parsePackageInfo
- :: String
- -> [(String,String)]
- -> Bool
- -> IO InstalledPackageInfo
-parsePackageInfo str defines force =
- case parseInstalledPackageInfo str of
- ParseOk _warns ok -> return ok
- ParseFailed err -> die (showError err)
-
--- -----------------------------------------------------------------------------
--- Exposing, Hiding, Unregistering are all similar
-
-exposePackage :: PackageIdentifier -> [Flag] -> IO ()
-exposePackage = modifyPackage (\p -> [p{exposed=True}])
-
-hidePackage :: PackageIdentifier -> [Flag] -> IO ()
-hidePackage = modifyPackage (\p -> [p{exposed=False}])
-
-unregisterPackage :: PackageIdentifier -> [Flag] -> IO ()
-unregisterPackage = modifyPackage (\p -> [])
-
-modifyPackage
- :: (InstalledPackageInfo -> [InstalledPackageInfo])
- -> PackageIdentifier
- -> [Flag]
- -> IO ()
-modifyPackage fn pkgid flags = do
- db_stack <- getPkgDatabases True{-modify-} flags
- let ((db_name, pkgs) : _) = db_stack
- checkConfigAccess db_name
- ps <- findPackages [(db_name,pkgs)] pkgid
- let pids = map package ps
- savePackageConfig db_name
- let new_config = concat (map modify pkgs)
- modify pkg
- | package pkg `elem` pids = fn pkg
- | otherwise = [pkg]
- maybeRestoreOldConfig db_name $
- writeNewConfig db_name new_config
-
--- -----------------------------------------------------------------------------
--- Listing packages
-
-listPackages :: [Flag] -> Maybe PackageIdentifier -> IO ()
-listPackages flags mPackageName = do
- let simple_output = FlagSimpleOutput `elem` flags
- db_stack <- getPkgDatabases False flags
- let db_stack_filtered -- if a package is given, filter out all other packages
- | Just this <- mPackageName =
- map (\(conf,pkgs) -> (conf, filter (this `matchesPkg`) pkgs))
- db_stack
- | otherwise = db_stack
-
- db_stack_sorted
- = [ (db, sort_pkgs pkgs) | (db,pkgs) <- db_stack_filtered ]
- where sort_pkgs = sortBy cmpPkgIds
- cmpPkgIds pkg1 pkg2 =
- case pkgName p1 `compare` pkgName p2 of
- LT -> LT
- GT -> GT
- EQ -> pkgVersion p1 `compare` pkgVersion p2
- where (p1,p2) = (package pkg1, package pkg2)
-
- show_func = if simple_output then show_easy else mapM_ show_regular
-
- show_func (reverse db_stack_sorted)
-
- where show_regular (db_name,pkg_confs) =
- hPutStrLn stdout (render $
- text (db_name ++ ":") $$ nest 4 packages
- )
- where packages = fsep (punctuate comma (map pp_pkg pkg_confs))
- pp_pkg p
- | exposed p = doc
- | otherwise = parens doc
- where doc = text (showPackageId (package p))
-
- show_easy db_stack = do
- let pkgs = map showPackageId $ sortBy compPkgIdVer $
- map package (concatMap snd db_stack)
- when (null pkgs) $ die "no matches"
- hPutStrLn stdout $ concat $ intersperse " " pkgs
-
--- -----------------------------------------------------------------------------
--- Prints the highest (hidden or exposed) version of a package
-
-latestPackage :: [Flag] -> PackageIdentifier -> IO ()
-latestPackage flags pkgid = do
- db_stack <- getPkgDatabases False flags
- ps <- findPackages db_stack pkgid
- show_pkg (sortBy compPkgIdVer (map package ps))
- where
- show_pkg [] = die "no matches"
- show_pkg pids = hPutStrLn stdout (showPackageId (last pids))
-
--- -----------------------------------------------------------------------------
--- Describe
-
-describePackage :: [Flag] -> PackageIdentifier -> IO ()
-describePackage flags pkgid = do
- db_stack <- getPkgDatabases False flags
- ps <- findPackages db_stack pkgid
- mapM_ (putStrLn . showInstalledPackageInfo) ps
-
--- PackageId is can have globVersion for the version
-findPackages :: PackageDBStack -> PackageIdentifier -> IO [InstalledPackageInfo]
-findPackages db_stack pkgid
- = case [ p | p <- all_pkgs, pkgid `matchesPkg` p ] of
- [] -> die ("cannot find package " ++ showPackageId pkgid)
- ps -> return ps
- where
- all_pkgs = concat (map snd db_stack)
-
-matches :: PackageIdentifier -> PackageIdentifier -> Bool
-pid `matches` pid'
- = (pkgName pid == pkgName pid')
- && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
-
-matchesPkg :: PackageIdentifier -> InstalledPackageInfo -> Bool
-pid `matchesPkg` pkg = pid `matches` package pkg
-
-compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
-compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
-
--- -----------------------------------------------------------------------------
--- Field
-
-describeField :: [Flag] -> PackageIdentifier -> String -> IO ()
-describeField flags pkgid field = do
- db_stack <- getPkgDatabases False flags
- case toField field of
- Nothing -> die ("unknown field: " ++ field)
- Just fn -> do
- ps <- findPackages db_stack pkgid
- mapM_ (putStrLn.fn) ps
-
-toField :: String -> Maybe (InstalledPackageInfo -> String)
--- backwards compatibility:
-toField "import_dirs" = Just $ strList . importDirs
-toField "source_dirs" = Just $ strList . importDirs
-toField "library_dirs" = Just $ strList . libraryDirs
-toField "hs_libraries" = Just $ strList . hsLibraries
-toField "extra_libraries" = Just $ strList . extraLibraries
-toField "include_dirs" = Just $ strList . includeDirs
-toField "c_includes" = Just $ strList . includes
-toField "package_deps" = Just $ strList . map showPackageId. depends
-toField "extra_cc_opts" = Just $ strList . ccOptions
-toField "extra_ld_opts" = Just $ strList . ldOptions
-toField "framework_dirs" = Just $ strList . frameworkDirs
-toField "extra_frameworks"= Just $ strList . frameworks
-toField s = showInstalledPackageInfoField s
-
-strList :: [String] -> String
-strList = show
-
--- -----------------------------------------------------------------------------
--- Manipulating package.conf files
-
-checkConfigAccess :: FilePath -> IO ()
-checkConfigAccess filename = do
- access <- getPermissions filename
- when (not (writable access))
- (die (filename ++ ": you don't have permission to modify this file"))
-
-maybeRestoreOldConfig :: FilePath -> IO () -> IO ()
-maybeRestoreOldConfig filename io
- = io `catch` \e -> do
- hPutStrLn stderr (show e)
- hPutStr stdout ("\nWARNING: an error was encountered while the new \n"++
- "configuration was being written. Attempting to \n"++
- "restore the old configuration... ")
- renameFile (filename ++ ".old") filename
- hPutStrLn stdout "done."
- ioError e
-
-writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO ()
-writeNewConfig filename packages = do
- hPutStr stdout "Writing new package config file... "
- h <- openFile filename WriteMode
- hPutStrLn h (show packages)
- hClose h
- hPutStrLn stdout "done."
-
-savePackageConfig :: FilePath -> IO ()
-savePackageConfig filename = do
- hPutStr stdout "Saving old package config file... "
- -- mv rather than cp because we've already done an hGetContents
- -- on this file so we won't be able to open it for writing
- -- unless we move the old one out of the way...
- let oldFile = filename ++ ".old"
- doesExist <- doesFileExist oldFile `catch` (\ _ -> return False)
- when doesExist (removeFile oldFile `catch` (const $ return ()))
- catch (renameFile filename oldFile)
- (\ err -> do
- hPutStrLn stderr (unwords [ "Unable to rename "
- , show filename
- , " to "
- , show oldFile
- ])
- ioError err)
- hPutStrLn stdout "done."
-
------------------------------------------------------------------------------
--- Sanity-check a new package config, and automatically build GHCi libs
--- if requested.
-
-validatePackageConfig :: InstalledPackageInfo
- -> PackageDBStack
- -> Bool -- auto-ghc-libs
- -> Bool -- update
- -> Bool -- force
- -> IO [PackageIdentifier]
-validatePackageConfig pkg db_stack auto_ghci_libs update force = do
- checkPackageId pkg
- overlaps <- checkDuplicates db_stack pkg update force
- mapM_ (checkDep db_stack force) (depends pkg)
- mapM_ (checkDir force) (importDirs pkg)
- mapM_ (checkDir force) (libraryDirs pkg)
- mapM_ (checkDir force) (includeDirs pkg)
- mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs force) (hsLibraries pkg)
- return overlaps
- -- ToDo: check these somehow?
- -- extra_libraries :: [String],
- -- c_includes :: [String],
-
--- When the package name and version are put together, sometimes we can
--- end up with a package id that cannot be parsed. This will lead to
--- difficulties when the user wants to refer to the package later, so
--- we check that the package id can be parsed properly here.
-checkPackageId :: InstalledPackageInfo -> IO ()
-checkPackageId ipi =
- let str = showPackageId (package ipi) in
- case [ x | (x,ys) <- readP_to_S parsePackageId str, all isSpace ys ] of
- [_] -> return ()
- [] -> die ("invalid package identifier: " ++ str)
- _ -> die ("ambiguous package identifier: " ++ str)
-
-resolveDeps :: PackageDBStack -> InstalledPackageInfo -> InstalledPackageInfo
-resolveDeps db_stack p = updateDeps p
- where
- -- The input package spec is allowed to give a package dependency
- -- without a version number; e.g.
- -- depends: base
- -- Here, we update these dependencies without version numbers to
- -- match the actual versions of the relevant packages installed.
- updateDeps p = p{depends = map resolveDep (depends p)}
-
- resolveDep dep_pkgid
- | realVersion dep_pkgid = dep_pkgid
- | otherwise = lookupDep dep_pkgid
-
- lookupDep dep_pkgid
- = let
- name = pkgName dep_pkgid
- in
- case [ pid | p <- concat (map snd db_stack),
- let pid = package p,
- pkgName pid == name ] of
- (pid:_) -> pid -- Found installed package,
- -- replete with its version
- [] -> dep_pkgid -- No installed package; use
- -- the version-less one
-
-checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Bool
- -> IO [PackageIdentifier]
-checkDuplicates db_stack pkg update force = do
- let
- pkgid = package pkg
- (_top_db_name, pkgs) : _ = db_stack
- --
- -- Check whether this package id already exists in this DB
- --
- when (not update && (pkgid `elem` map package pkgs)) $
- die ("package " ++ showPackageId pkgid ++ " is already installed")
-
- --
- -- Check whether any of the dependencies of the current package
- -- conflict with each other.
- --
- let
- all_pkgs = concat (map snd db_stack)
-
- allModules p = exposedModules p ++ hiddenModules p
-
- our_dependencies = closePackageDeps all_pkgs [pkg]
- all_dep_modules = concat (map (\p -> zip (allModules p) (repeat p))
- our_dependencies)
-
- overlaps = [ (m, map snd group)
- | group@((m,_):_) <- groupBy eqfst (sortBy cmpfst all_dep_modules),
- length group > 1 ]
- where eqfst (a,_) (b,_) = a == b
- cmpfst (a,_) (b,_) = a `compare` b
-
- when (not (null overlaps)) $
- diePrettyOrForce force $ vcat [
- text "package" <+> text (showPackageId (package pkg)) <+>
- text "has conflicting dependencies:",
- let complain_about (mod,ps) =
- text mod <+> text "is in the following packages:" <+>
- sep (map (text.showPackageId.package) ps)
- in
- nest 3 (vcat (map complain_about overlaps))
- ]
-
- --
- -- Now check whether exposing this package will result in conflicts, and
- -- Figure out which packages we need to hide to resolve the conflicts.
- --
- let
- closure_exposed_pkgs = closePackageDeps pkgs (filter exposed pkgs)
-
- new_dep_modules = concat $ map allModules $
- filter (\p -> package p `notElem`
- map package closure_exposed_pkgs) $
- our_dependencies
-
- pkgs_with_overlapping_modules =
- [ (p, overlapping_mods)
- | p <- closure_exposed_pkgs,
- let overlapping_mods =
- filter (`elem` new_dep_modules) (allModules p),
- (_:_) <- [overlapping_mods] --trick to get the non-empty ones
- ]
-
- to_hide = map package
- $ filter exposed
- $ closePackageDepsUpward pkgs
- $ map fst pkgs_with_overlapping_modules
-
- when (not update && exposed pkg && not (null pkgs_with_overlapping_modules)) $ do
- diePretty $ vcat [
- text "package" <+> text (showPackageId (package pkg)) <+>
- text "conflicts with the following packages, which are",
- text "either exposed or a dependency (direct or indirect) of an exposed package:",
- let complain_about (p, mods)
- = text (showPackageId (package p)) <+> text "contains modules" <+>
- sep (punctuate comma (map text mods)) in
- nest 3 (vcat (map complain_about pkgs_with_overlapping_modules)),
- text "Using 'update' instead of 'register' will cause the following packages",
- text "to be hidden, which will eliminate the conflict:",
- nest 3 (sep (map (text.showPackageId) to_hide))
- ]
-
- when (not (null to_hide)) $ do
- hPutStrLn stderr $ render $
- sep [text "Warning: hiding the following packages to avoid conflict: ",
- nest 2 (sep (map (text.showPackageId) to_hide))]
-
- return to_hide
-
-
-closure :: (a->[a]->Bool) -> (a -> [a]) -> [a] -> [a] -> [a]
-closure pred more [] res = res
-closure pred more (p:ps) res
- | p `pred` res = closure pred more ps res
- | otherwise = closure pred more (more p ++ ps) (p:res)
-
-closePackageDeps :: [InstalledPackageInfo] -> [InstalledPackageInfo]
- -> [InstalledPackageInfo]
-closePackageDeps db start
- = closure (\p ps -> package p `elem` map package ps) getDepends start []
- where
- getDepends p = [ pkg | dep <- depends p, pkg <- lookupPkg dep ]
- lookupPkg p = [ q | q <- db, p == package q ]
-
-closePackageDepsUpward :: [InstalledPackageInfo] -> [InstalledPackageInfo]
- -> [InstalledPackageInfo]
-closePackageDepsUpward db start
- = closure (\p ps -> package p `elem` map package ps) getUpwardDepends start []
- where
- getUpwardDepends p = [ pkg | pkg <- db, package p `elem` depends pkg ]
-
-
-checkDir :: Bool -> String -> IO ()
-checkDir force d
- | "$topdir" `isPrefixOf` d = return ()
- -- can't check this, because we don't know what $topdir is
- | otherwise = do
- there <- doesDirectoryExist d
- when (not there)
- (dieOrForce force (d ++ " doesn't exist or isn't a directory"))
-
-checkDep :: PackageDBStack -> Bool -> PackageIdentifier -> IO ()
-checkDep db_stack force pkgid
- | not real_version || pkgid `elem` pkgids = return ()
- | otherwise = dieOrForce force ("dependency " ++ showPackageId pkgid
- ++ " doesn't exist")
- where
- -- for backwards compat, we treat 0.0 as a special version,
- -- and don't check that it actually exists.
- real_version = realVersion pkgid
-
- all_pkgs = concat (map snd db_stack)
- pkgids = map package all_pkgs
-
-realVersion :: PackageIdentifier -> Bool
-realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
-
-checkHSLib :: [String] -> Bool -> Bool -> String -> IO ()
-checkHSLib dirs auto_ghci_libs force lib = do
- let batch_lib_file = "lib" ++ lib ++ ".a"
- bs <- mapM (doesLibExistIn batch_lib_file) dirs
- case [ dir | (exists,dir) <- zip bs dirs, exists ] of
- [] -> dieOrForce force ("cannot find " ++ batch_lib_file ++
- " on library path")
- (dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
-
-doesLibExistIn :: String -> String -> IO Bool
-doesLibExistIn lib d
- | "$topdir" `isPrefixOf` d = return True
- | otherwise = doesFileExist (d ++ '/':lib)
-
-checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
-checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build
- | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
- | otherwise = do
- bs <- mapM (doesLibExistIn ghci_lib_file) dirs
- case [dir | (exists,dir) <- zip bs dirs, exists] of
- [] -> hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file)
- (_:_) -> return ()
- where
- ghci_lib_file = lib ++ ".o"
-
--- automatically build the GHCi version of a batch lib,
--- using ld --whole-archive.
-
-autoBuildGHCiLib :: String -> String -> String -> IO ()
-autoBuildGHCiLib dir batch_file ghci_file = do
- let ghci_lib_file = dir ++ '/':ghci_file
- batch_lib_file = dir ++ '/':batch_file
- hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")
-#if defined(darwin_HOST_OS)
- r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
-#elif defined(mingw32_HOST_OS)
- execDir <- getExecDir "/bin/ghc-pkg.exe"
- r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
-#else
- r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
-#endif
- when (r /= ExitSuccess) $ exitWith r
- hPutStrLn stderr (" done.")
-
--- -----------------------------------------------------------------------------
--- Updating the DB with the new package.
-
-updatePackageDB
- :: PackageDBStack -- the full stack
- -> [PackageIdentifier] -- packages to hide
- -> [InstalledPackageInfo] -- packages in *this* DB
- -> InstalledPackageInfo -- the new package
- -> IO [InstalledPackageInfo]
-updatePackageDB db_stack to_hide pkgs new_pkg = do
- let
- pkgid = package new_pkg
-
- pkgs' = [ maybe_hide p | p <- pkgs, package p /= pkgid ]
-
- -- When update is on, and we're exposing the new package,
- -- we hide any packages which conflict (see checkDuplicates)
- -- in the current DB.
- maybe_hide p
- | exposed new_pkg && package p `elem` to_hide = p{ exposed = False }
- | otherwise = p
- --
- return (pkgs'++ [new_pkg])
-
--- -----------------------------------------------------------------------------
--- Searching for modules
-
-#if not_yet
-
-findModules :: [FilePath] -> IO [String]
-findModules paths =
- mms <- mapM searchDir paths
- return (concat mms)
-
-searchDir path prefix = do
- fs <- getDirectoryEntries path `catch` \_ -> return []
- searchEntries path prefix fs
-
-searchEntries path prefix [] = return []
-searchEntries path prefix (f:fs)
- | looks_like_a_module = do
- ms <- searchEntries path prefix fs
- return (prefix `joinModule` f : ms)
- | looks_like_a_component = do
- ms <- searchDir (path `joinFilename` f) (prefix `joinModule` f)
- ms' <- searchEntries path prefix fs
- return (ms ++ ms')
- | otherwise
- searchEntries path prefix fs
-
- where
- (base,suffix) = splitFileExt f
- looks_like_a_module =
- suffix `elem` haskell_suffixes &&
- all okInModuleName base
- looks_like_a_component =
- null suffix && all okInModuleName base
-
-okInModuleName c
-
-#endif
-
--- -----------------------------------------------------------------------------
--- The old command-line syntax, supported for backwards compatibility
-
-data OldFlag
- = OF_Config FilePath
- | OF_Input FilePath
- | OF_List
- | OF_ListLocal
- | OF_Add Bool {- True => replace existing info -}
- | OF_Remove String | OF_Show String
- | OF_Field String | OF_AutoGHCiLibs | OF_Force
- | OF_DefinedName String String
- | OF_GlobalConfig FilePath
- deriving (Eq)
-
-isAction :: OldFlag -> Bool
-isAction OF_Config{} = False
-isAction OF_Field{} = False
-isAction OF_Input{} = False
-isAction OF_AutoGHCiLibs{} = False
-isAction OF_Force{} = False
-isAction OF_DefinedName{} = False
-isAction OF_GlobalConfig{} = False
-isAction _ = True
-
-oldFlags :: [OptDescr OldFlag]
-oldFlags = [
- Option ['f'] ["config-file"] (ReqArg OF_Config "FILE")
- "use the specified package config file",
- Option ['l'] ["list-packages"] (NoArg OF_List)
- "list packages in all config files",
- Option ['L'] ["list-local-packages"] (NoArg OF_ListLocal)
- "list packages in the specified config file",
- Option ['a'] ["add-package"] (NoArg (OF_Add False))
- "add a new package",
- Option ['u'] ["update-package"] (NoArg (OF_Add True))
- "update package with new configuration",
- Option ['i'] ["input-file"] (ReqArg OF_Input "FILE")
- "read new package info from specified file",
- Option ['s'] ["show-package"] (ReqArg OF_Show "NAME")
- "show the configuration for package NAME",
- Option [] ["field"] (ReqArg OF_Field "FIELD")
- "(with --show-package) Show field FIELD only",
- Option [] ["force"] (NoArg OF_Force)
- "ignore missing directories/libraries",
- Option ['r'] ["remove-package"] (ReqArg OF_Remove "NAME")
- "remove an installed package",
- Option ['g'] ["auto-ghci-libs"] (NoArg OF_AutoGHCiLibs)
- "automatically build libs for GHCi (with -a)",
- Option ['D'] ["define-name"] (ReqArg toDefined "NAME=VALUE")
- "define NAME as VALUE",
- Option [] ["global-conf"] (ReqArg OF_GlobalConfig "FILE")
- "location of the global package config"
- ]
- where
- toDefined str =
- case break (=='=') str of
- (nm,[]) -> OF_DefinedName nm []
- (nm,_:val) -> OF_DefinedName nm val
-
-oldRunit :: [OldFlag] -> IO ()
-oldRunit clis = do
- let new_flags = [ f | Just f <- map conv clis ]
-
- conv (OF_GlobalConfig f) = Just (FlagGlobalConfig f)
- conv (OF_Config f) = Just (FlagConfig f)
- conv _ = Nothing
-
-
-
- let fields = [ f | OF_Field f <- clis ]
-
- let auto_ghci_libs = any isAuto clis
- where isAuto OF_AutoGHCiLibs = True; isAuto _ = False
- input_file = my_head "inp" ([ f | (OF_Input f) <- clis] ++ ["-"])
-
- force = OF_Force `elem` clis
-
- defines = [ (nm,val) | OF_DefinedName nm val <- clis ]
-
- case [ c | c <- clis, isAction c ] of
- [ OF_List ] -> listPackages new_flags Nothing
- [ OF_ListLocal ] -> listPackages new_flags Nothing
- [ OF_Add upd ] ->
- registerPackage input_file defines new_flags auto_ghci_libs upd force
- [ OF_Remove pkgid_str ] -> do
- pkgid <- readPkgId pkgid_str
- unregisterPackage pkgid new_flags
- [ OF_Show pkgid_str ]
- | null fields -> do
- pkgid <- readPkgId pkgid_str
- describePackage new_flags pkgid
- | otherwise -> do
- pkgid <- readPkgId pkgid_str
- mapM_ (describeField new_flags pkgid) fields
- _ -> do
- prog <- getProgramName
- die (usageInfo (usageHeader prog) flags)
-
-my_head :: String -> [a] -> a
-my_head s [] = error s
-my_head s (x:xs) = x
-
--- ---------------------------------------------------------------------------
--- expanding environment variables in the package configuration
-
-expandEnvVars :: String -> [(String, String)] -> Bool -> IO String
-expandEnvVars str defines force = go str ""
- where
- go "" acc = return $! reverse acc
- go ('$':'{':str) acc | (var, '}':rest) <- break close str
- = do value <- lookupEnvVar var
- go rest (reverse value ++ acc)
- where close c = c == '}' || c == '\n' -- don't span newlines
- go (c:str) acc
- = go str (c:acc)
-
- lookupEnvVar :: String -> IO String
- lookupEnvVar nm =
- case lookup nm defines of
- Just x | not (null x) -> return x
- _ ->
- catch (System.getEnv nm)
- (\ _ -> do dieOrForce force ("Unable to expand variable " ++
- show nm)
- return "")
-
------------------------------------------------------------------------------
-
-getProgramName :: IO String
-getProgramName = liftM (`withoutSuffix` ".bin") getProgName
- where str `withoutSuffix` suff
- | suff `isSuffixOf` str = take (length str - length suff) str
- | otherwise = str
-
-bye :: String -> IO a
-bye s = putStr s >> exitWith ExitSuccess
-
-die :: String -> IO a
-die s = do
- hFlush stdout
- prog <- getProgramName
- hPutStrLn stderr (prog ++ ": " ++ s)
- exitWith (ExitFailure 1)
-
-dieOrForce :: Bool -> String -> IO ()
-dieOrForce force s
- | force = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)")
- | otherwise = die (s ++ " (use --force to override)")
-
-diePretty :: Doc -> IO ()
-diePretty doc = do
- hFlush stdout
- prog <- getProgramName
- hPutStrLn stderr $ render $ (text prog <> colon $$ nest 2 doc)
- exitWith (ExitFailure 1)
-
-diePrettyOrForce :: Bool -> Doc -> IO ()
-diePrettyOrForce force doc
- | force = do hFlush stdout; hPutStrLn stderr (render (doc $$ text "(ignoring)"))
- | otherwise = diePretty (doc $$ text "(use --force to override)")
-
------------------------------------------
--- Cut and pasted from ghc/compiler/SysTools
-
-#if defined(mingw32_HOST_OS)
-subst a b ls = map (\ x -> if x == a then b else x) ls
-unDosifyPath xs = subst '\\' '/' xs
-
-getExecDir :: String -> IO (Maybe String)
--- (getExecDir cmd) returns the directory in which the current
--- executable, which should be called 'cmd', is running
--- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
--- you'll get "/a/b/c" back as the result
-getExecDir cmd
- = allocaArray len $ \buf -> do
- ret <- getModuleFileName nullPtr buf len
- if ret == 0 then return Nothing
- else do s <- peekCString buf
- return (Just (reverse (drop (length cmd)
- (reverse (unDosifyPath s)))))
- where
- len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32.
-
-foreign import stdcall unsafe "GetModuleFileNameA"
- getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
-#else
-getExecDir :: String -> IO (Maybe String)
-getExecDir _ = return Nothing
-#endif
-
--- -----------------------------------------------------------------------------
--- FilePath utils
-
--- | The 'joinFileName' function is the opposite of 'splitFileName'.
--- It joins directory and file names to form a complete file path.
---
--- The general rule is:
---
--- > dir `joinFileName` basename == path
--- > where
--- > (dir,basename) = splitFileName path
---
--- There might be an exceptions to the rule but in any case the
--- reconstructed path will refer to the same object (file or directory).
--- An example exception is that on Windows some slashes might be converted
--- to backslashes.
-joinFileName :: String -> String -> FilePath
-joinFileName "" fname = fname
-joinFileName "." fname = fname
-joinFileName dir "" = dir
-joinFileName dir fname
- | isPathSeparator (last dir) = dir++fname
- | otherwise = dir++pathSeparator:fname
-
--- | Checks whether the character is a valid path separator for the host
--- platform. The valid character is a 'pathSeparator' but since the Windows
--- operating system also accepts a slash (\"\/\") since DOS 2, the function
--- checks for it on this platform, too.
-isPathSeparator :: Char -> Bool
-isPathSeparator ch = ch == pathSeparator || ch == '/'
-
--- | Provides a platform-specific character used to separate directory levels in
--- a path string that reflects a hierarchical file system organization. The
--- separator is a slash (@\"\/\"@) on Unix and Macintosh, and a backslash
--- (@\"\\\"@) on the Windows operating system.
-pathSeparator :: Char
-#ifdef mingw32_HOST_OS
-pathSeparator = '\\'
-#else
-pathSeparator = '/'
-#endif
-
--- | The function splits the given string to substrings
--- using the 'searchPathSeparator'.
-parseSearchPath :: String -> [FilePath]
-parseSearchPath path = split path
- where
- split :: String -> [String]
- split s =
- case rest' of
- [] -> [chunk]
- _:rest -> chunk : split rest
- where
- chunk =
- case chunk' of
-#ifdef mingw32_HOST_OS
- ('\"':xs@(_:_)) | last xs == '\"' -> init xs
-#endif
- _ -> chunk'
-
- (chunk', rest') = break (==searchPathSeparator) s
-
--- | A platform-specific character used to separate search path strings in
--- environment variables. The separator is a colon (\":\") on Unix and Macintosh,
--- and a semicolon (\";\") on the Windows operating system.
-searchPathSeparator :: Char
-#if mingw32_HOST_OS || mingw32_TARGET_OS
-searchPathSeparator = ';'
-#else
-searchPathSeparator = ':'
-#endif
-
diff --git a/ghc/utils/ghc-pkg/Makefile b/ghc/utils/ghc-pkg/Makefile
deleted file mode 100644
index d513a91b1c..0000000000
--- a/ghc/utils/ghc-pkg/Makefile
+++ /dev/null
@@ -1,113 +0,0 @@
-# -----------------------------------------------------------------------------
-
-TOP=../..
-include $(TOP)/mk/boilerplate.mk
-
-# hack for ghci-inplace script, see below
-INSTALLING=1
-
-# -----------------------------------------------------------------------------
-# ghc-pkg.bin
-
-SRC_HC_OPTS += -cpp -Wall -fno-warn-name-shadowing -fno-warn-unused-matches
-
-# This causes libghccompat.a to be used:
-include $(GHC_LIB_COMPAT_DIR)/compat.mk
-
-# This is required because libghccompat.a must be built with
-# $(GhcHcOpts) because it is linked to the compiler, and hence
-# we must also build with $(GhcHcOpts) here:
-SRC_HC_OPTS += $(GhcHcOpts)
-
-ifeq "$(ghc_ge_504)" "NO"
-SRC_HC_OPTS += -package lang -package util -package text
-endif
-
-# On Windows, ghc-pkg is a standalone program
-# ($bindir/ghc-pkg.exe), whereas on Unix it needs a wrapper script
-# to pass the appropriate flag to the real binary
-# ($libexecdir/ghc-pkg.bin) so that it can find package.conf.
-ifeq "$(HOSTPLATFORM)" "i386-unknown-mingw32"
-HS_PROG = ghc-pkg.exe
-INSTALL_PROGS += $(HS_PROG)
-else
-HS_PROG = ghc-pkg.bin
-INSTALL_LIBEXECS += $(HS_PROG)
-endif
-
-# -----------------------------------------------------------------------------=
-# Create the Version.hs file
-
-VERSION_HS = Version.hs
-EXTRA_SRCS += $(VERSION_HS)
-
-boot :: $(VERSION_HS)
-
-Version.hs : Makefile $(TOP)/mk/version.mk
- @$(RM) -f $(VERSION_HS)
- @echo "Creating $(VERSION_HS) ... "
- @echo "module Version where" >>$(VERSION_HS)
- @echo "version, targetOS, targetARCH :: String" >>$(VERSION_HS)
- @echo "version = \"$(ProjectVersion)\"" >> $(VERSION_HS)
- @echo "targetOS = \"$(TargetOS_CPP)\"" >> $(VERSION_HS)
- @echo "targetARCH = \"$(TargetArch_CPP)\"" >> $(VERSION_HS)
-
-DIST_CLEAN_FILES += $(VERSION_HS)
-
-# -----------------------------------------------------------------------------
-# ghc-pkg script
-
-ifeq "$(INSTALLING)" "1"
-ifeq "$(BIN_DIST)" "1"
-GHCPKGBIN=$$\"\"libexecdir/$(HS_PROG)
-PKGCONF=$$\"\"libdir/package.conf
-else
-GHCPKGBIN=$(libexecdir)/$(HS_PROG)
-PKGCONF=$(libdir)/package.conf
-endif # BIN_DIST
-else
-GHCPKGBIN=$(FPTOOLS_TOP_ABS)/ghc/utils/ghc-pkg/$(HS_PROG)
-PKGCONF=$(FPTOOLS_TOP_ABS_PLATFORM)/ghc/driver/package.conf.inplace
-endif
-
-ifneq "$(HOSTPLATFORM)" "i386-unknown-mingw32"
-INSTALLED_SCRIPT_PROG = ghc-pkg-$(ProjectVersion)
-endif
-INPLACE_SCRIPT_PROG = ghc-pkg-inplace
-
-SCRIPT_OBJS = ghc-pkg.sh
-INTERP = $(SHELL)
-SCRIPT_SUBST_VARS = GHCPKGBIN PKGCONFOPT
-ifneq "$(HOSTPLATFORM)" "i386-unknown-mingw32"
-INSTALL_SCRIPTS += $(SCRIPT_PROG)
-endif
-PKGCONFOPT = --global-conf $(PKGCONF)
-
-ifeq "$(INSTALLING)" "1"
-SCRIPT_PROG = $(INSTALLED_SCRIPT_PROG)
-ifneq "$(HOSTPLATFORM)" "i386-unknown-mingw32"
-LINK = ghc-pkg
-endif
-else
-SCRIPT_PROG = $(INPLACE_SCRIPT_PROG)
-endif
-
-# -----------------------------------------------------------------------------
-# don't recurse on 'make install'
-#
-ifeq "$(INSTALLING)" "1"
-all :: $(HS_PROG)
- $(MAKE) INSTALLING=0 BIN_DIST=0 $(MFLAGS) $@
-clean distclean maintainer-clean ::
- $(MAKE) INSTALLING=0 BIN_DIST=0 $(MFLAGS) $@
-endif
-
-# ghc-pkg is needed to boot in ghc/rts and library dirs
-# Do a recursive 'make all' after generating dependencies, because this
-# will work with 'make -j'.
-ifneq "$(BootingFromHc)" "YES"
-boot :: depend
- $(MAKE) all
-endif
-
-include $(TOP)/mk/target.mk
diff --git a/ghc/utils/ghc-pkg/ghc-pkg.sh b/ghc/utils/ghc-pkg/ghc-pkg.sh
deleted file mode 100644
index d482fc094e..0000000000
--- a/ghc/utils/ghc-pkg/ghc-pkg.sh
+++ /dev/null
@@ -1,2 +0,0 @@
-# Mini-driver for ghc-pkg
-exec $GHCPKGBIN $PKGCONFOPT ${1+"$@"}
diff --git a/ghc/utils/hasktags/HaskTags.hs b/ghc/utils/hasktags/HaskTags.hs
deleted file mode 100644
index f1840332d2..0000000000
--- a/ghc/utils/hasktags/HaskTags.hs
+++ /dev/null
@@ -1,232 +0,0 @@
-module Main where
-import System
-import Char
-import List
-import IO
-import System.Environment
-import System.Console.GetOpt
-import System.Exit
-
-
--- search for definitions of things
--- we do this by looking for the following patterns:
--- data XXX = ... giving a datatype location
--- newtype XXX = ... giving a newtype location
--- bla :: ... giving a function location
---
--- by doing it this way, we avoid picking up local definitions
--- (whether this is good or not is a matter for debate)
---
-
--- We generate both CTAGS and ETAGS format tags files
--- The former is for use in most sensible editors, while EMACS uses ETAGS
-
-
-main :: IO ()
-main = do
- progName <- getProgName
- args <- getArgs
- let usageString = "Usage: " ++ progName ++ " [OPTION...] [files...]"
- let (modes, filenames, errs) = getOpt Permute options args
- if errs /= [] || elem Help modes || filenames == []
- then do
- putStr $ unlines errs
- putStr $ usageInfo usageString options
- exitWith (ExitFailure 1)
- else return ()
- let mode = getMode modes
- filedata <- mapM findthings filenames
- if mode == BothTags || mode == CTags
- then do
- ctagsfile <- openFile "tags" WriteMode
- writectagsfile ctagsfile filedata
- hClose ctagsfile
- else return ()
- if mode == BothTags || mode == ETags
- then do
- etagsfile <- openFile "TAGS" WriteMode
- writeetagsfile etagsfile filedata
- hClose etagsfile
- else return ()
-
--- | getMode takes a list of modes and extract the mode with the
--- highest precedence. These are as follows: Both, CTags, ETags
--- The default case is Both.
-getMode :: [Mode] -> Mode
-getMode [] = BothTags
-getMode [x] = x
-getMode (x:xs) = max x (getMode xs)
-
-
-data Mode = ETags | CTags | BothTags | Help deriving (Ord, Eq, Show)
-
-options :: [OptDescr Mode]
-options = [ Option "c" ["ctags"]
- (NoArg CTags) "generate CTAGS file (ctags)"
- , Option "e" ["etags"]
- (NoArg ETags) "generate ETAGS file (etags)"
- , Option "b" ["both"]
- (NoArg BothTags) ("generate both CTAGS and ETAGS")
- , Option "h" ["help"] (NoArg Help) "This help"
- ]
-
-type FileName = String
-
-type ThingName = String
-
--- The position of a token or definition
-data Pos = Pos
- FileName -- file name
- Int -- line number
- Int -- token number
- String -- string that makes up that line
- deriving Show
-
--- A definition we have found
-data FoundThing = FoundThing ThingName Pos
- deriving Show
-
--- Data we have obtained from a file
-data FileData = FileData FileName [FoundThing]
-
-data Token = Token String Pos
- deriving Show
-
-
--- stuff for dealing with ctags output format
-
-writectagsfile :: Handle -> [FileData] -> IO ()
-writectagsfile ctagsfile filedata = do
- let things = concat $ map getfoundthings filedata
- mapM_ (\x -> hPutStrLn ctagsfile $ dumpthing x) things
-
-getfoundthings :: FileData -> [FoundThing]
-getfoundthings (FileData filename things) = things
-
-dumpthing :: FoundThing -> String
-dumpthing (FoundThing name (Pos filename line _ _)) =
- name ++ "\t" ++ filename ++ "\t" ++ (show $ line + 1)
-
-
--- stuff for dealing with etags output format
-
-writeetagsfile :: Handle -> [FileData] -> IO ()
-writeetagsfile etagsfile filedata = do
- mapM_ (\x -> hPutStr etagsfile $ e_dumpfiledata x) filedata
-
-e_dumpfiledata :: FileData -> String
-e_dumpfiledata (FileData filename things) =
- "\x0c\n" ++ filename ++ "," ++ (show thingslength) ++ "\n" ++ thingsdump
- where
- thingsdump = concat $ map e_dumpthing things
- thingslength = length thingsdump
-
-e_dumpthing :: FoundThing -> String
-e_dumpthing (FoundThing name (Pos filename line token fullline)) =
- (concat $ take (token + 1) $ spacedwords fullline)
- ++ "\x7f" ++ (show line) ++ "," ++ (show $ line+1) ++ "\n"
-
-
--- like "words", but keeping the whitespace, and so letting us build
--- accurate prefixes
-
-spacedwords :: String -> [String]
-spacedwords [] = []
-spacedwords xs = (blanks ++ wordchars):(spacedwords rest2)
- where
- (blanks,rest) = span Char.isSpace xs
- (wordchars,rest2) = span (\x -> not $ Char.isSpace x) rest
-
-
--- Find the definitions in a file
-
-findthings :: FileName -> IO FileData
-findthings filename = do
- text <- readFile filename
- evaluate text -- forces evaluation of text
- -- too many files were being opened otherwise since
- -- readFile is lazy
- let aslines = lines text
- let wordlines = map words aslines
- let noslcoms = map stripslcomments wordlines
- let tokens = concat $ zipWith3 (withline filename) noslcoms
- aslines [0 ..]
- let nocoms = stripblockcomments tokens
- return $ FileData filename $ findstuff nocoms
- where evaluate [] = return ()
- evaluate (c:cs) = c `seq` evaluate cs
-
--- Create tokens from words, by recording their line number
--- and which token they are through that line
-
-withline :: FileName -> [String] -> String -> Int -> [Token]
-withline filename words fullline i =
- zipWith (\w t -> Token w (Pos filename i t fullline)) words $ [0 ..]
-
--- comments stripping
-
-stripslcomments :: [String] -> [String]
-stripslcomments ("--":xs) = []
-stripslcomments (x:xs) = x : stripslcomments xs
-stripslcomments [] = []
-
-stripblockcomments :: [Token] -> [Token]
-stripblockcomments ((Token "\\end{code}" _):xs) = afterlitend xs
-stripblockcomments ((Token "{-" _):xs) = afterblockcomend xs
-stripblockcomments (x:xs) = x:stripblockcomments xs
-stripblockcomments [] = []
-
-afterlitend2 :: [Token] -> [Token]
-afterlitend2 (x:xs) = afterlitend xs
-afterlitend2 [] = []
-
-afterlitend :: [Token] -> [Token]
-afterlitend ((Token "\\begin{code}" _):xs) = xs
-afterlitend (x:xs) = afterlitend xs
-afterlitend [] = []
-
-afterblockcomend :: [Token] -> [Token]
-afterblockcomend ((Token token _):xs) | contains "-}" token = xs
- | otherwise = afterblockcomend xs
-afterblockcomend [] = []
-
-
--- does one string contain another string
-
-contains :: Eq a => [a] -> [a] -> Bool
-contains sub full = any (isPrefixOf sub) $ tails full
-
-ints :: Int -> [Int]
-ints i = i:(ints $ i+1)
-
-
--- actually pick up definitions
-
-findstuff :: [Token] -> [FoundThing]
-findstuff ((Token "data" _):(Token name pos):xs) =
- FoundThing name pos : (getcons xs) ++ (findstuff xs)
-findstuff ((Token "newtype" _):(Token name pos):xs) =
- FoundThing name pos : findstuff xs
-findstuff ((Token "type" _):(Token name pos):xs) =
- FoundThing name pos : findstuff xs
-findstuff ((Token name pos):(Token "::" _):xs) =
- FoundThing name pos : findstuff xs
-findstuff (x:xs) = findstuff xs
-findstuff [] = []
-
-
--- get the constructor definitions, knowing that a datatype has just started
-
-getcons :: [Token] -> [FoundThing]
-getcons ((Token "=" _):(Token name pos):xs) =
- FoundThing name pos : getcons2 xs
-getcons (x:xs) = getcons xs
-getcons [] = []
-
-
-getcons2 ((Token "=" _):xs) = []
-getcons2 ((Token "|" _):(Token name pos):xs) =
- FoundThing name pos : getcons2 xs
-getcons2 (x:xs) = getcons2 xs
-getcons2 [] = []
-
diff --git a/ghc/utils/hasktags/Makefile b/ghc/utils/hasktags/Makefile
deleted file mode 100644
index 59a03d8abd..0000000000
--- a/ghc/utils/hasktags/Makefile
+++ /dev/null
@@ -1,14 +0,0 @@
-
-TOP=../..
-
-include $(TOP)/mk/boilerplate.mk
-
-CURRENT_DIR=ghc/utils/hasktags
-
-HS_PROG = hasktags
-
-CLEAN_FILES += Main.hi
-
-INSTALL_PROGS += $(HS_PROG)
-
-include $(TOP)/mk/target.mk
diff --git a/ghc/utils/hasktags/README b/ghc/utils/hasktags/README
deleted file mode 100644
index 77bac8881a..0000000000
--- a/ghc/utils/hasktags/README
+++ /dev/null
@@ -1,33 +0,0 @@
-
-"hasktags" is a very simple Haskell program that produces ctags "tags" and etags "TAGS" files for Haskell programs.
-
-As such, it does essentially the same job that hstags and fptags used to do, but, both of those seem to no longer be maintained, and it seemed to be easier to write my own version rather than to get one of them to work.
-
-Example usage:
-
-find -name \*.\*hs | xargs hasktags
-
-
-This will create "tags" and "TAGS" files in the current directory describing all Haskell files in the current directory or below.
-
-
-
-Features
- * Includes top level functions, provided a type signature is given
- * Includes data declarations, and constructors
- * Includes newtypes
-
- - But sometimes gets things wrong or misses things out
- It's only a simple program
-
-
-Using with your editor:
-
-With NEdit
- Load the "tags" file using File/Load Tags File.
- Use "Ctrl-D" to search for a tag.
-
-With XEmacs/Emacs
- Load the "TAGS" file using "visit-tags-table"
- Use "M-." to search for a tag.
-
diff --git a/ghc/utils/heap-view/Graph.lhs b/ghc/utils/heap-view/Graph.lhs
deleted file mode 100644
index b8e08dbb9b..0000000000
--- a/ghc/utils/heap-view/Graph.lhs
+++ /dev/null
@@ -1,165 +0,0 @@
-Started 29/11/93:
-
-> module Main where
-> import PreludeGlaST
-> import LibSystem
-
-Program to draw a graph of last @n@ pieces of data from standard input
-continuously.
-
-> n :: Int
-> n = 40
-
-> max_sample :: Int
-> max_sample = 100
-
-> screen_size :: Int
-> screen_size = 200
-
-Version of grapher that can handle the output of ghc's @+RTS -Sstderr@
-option.
-
-Nice variant would be to take a list of numbers from the commandline
-and display several graphs at once.
-
-> main :: IO ()
-> main =
-> getArgs >>= \ r ->
-> case r of
-> [select] ->
-> let selection = read select
-> in
-> xInitialise [] screen_size screen_size >>
-> hGetContents stdin >>= \ input ->
-> graphloop2 (parseGCData selection input) []
-> _ ->
-> error "usage: graph <number in range 0..17>\n"
-
-The format of glhc18's stderr stuff is:
-
--- start of example (view in 120 column window)
-graph +RTS -Sstderr -H500
-
-Collector: APPEL HeapSize: 500 (bytes)
-
- Alloc Collect Live Resid GC GC TOT TOT Page Flts No of Roots Caf Mut- Old Collec Resid
- bytes bytes bytes ency user elap user elap GC MUT Astk Bstk Reg No able Gen tion %heap
- 248 248 60 24.2% 0.00 0.04 0.05 0.23 1 1 1 0 0 1 0 0 Minor
--- end of example
- 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17
-
-That is: 6 header lines followed by 17-18 columns of integers,
-percentages, floats and text.
-
-The scaling in the following is largely based on guesses about likely
-values - needs tuned.
-
-@gcParsers@ is a list of functions which parse the corresponding
-column and attempts to scale the numbers into the range $0.0 .. 1.0$.
-(But may return a number avove $1.0$ which graphing part will scale to
-fit screen...)
-
-(Obvious optimisation - replace by list of scaling information!)
-
-(Obvious improvement - return (x,y) pair based on elapsed (or user) time.)
-
-> gcParsers :: [ String -> Float ]
-> gcParsers = [ heap, heap, heap, percent, time, time, time, time, flts, flts, stk, stk, reg, caf, caf, heap, text, percent ]
-> where
-> heap = scale 100000.0 . fromInt . check 0 . readDec
-> stk = scale 25000.0 . fromInt . check 0 . readDec
-> int = scale 1000.0 . fromInt . check 0 . readDec
-> reg = scale 10.0 . fromInt . check 0 . readDec
-> caf = scale 100.0 . fromInt . check 0 . readDec
-> flts = scale 100.0 . fromInt . check 0 . readDec
-> percent = scale 100.0 . check 0.0 . readFloat
-> time = scale 20.0 . check 0.0 . readFloat
-> text s = 0.0
-
-> check :: a -> [(a,String)] -> a
-> check error_value parses =
-> case parses of
-> [] -> error_value
-> ((a,s):_) -> a
-
-> scale :: Float -> Float -> Float
-> scale max n = n / max
-
-> parseGCData :: Int -> String -> [Float]
-> parseGCData column input =
-> map ((gcParsers !! column) . (!! column) . words) (drop 6 (lines input))
-
-Hmmm, how to add logarithmic scaling neatly? Do I still need to?
-
-Note: unpleasant as it is, the code cannot be simplified to something
-like the following. The problem is that the graph won't start to be
-drawn until the first @n@ values are available. (Is there also a
-danger of clearing the screen while waiting for the next input value?)
-A possible alternative solution is to keep count of how many values
-have actually been received.
-
-< graphloop2 :: [Float] -> [Float] -> IO ()
-< graphloop2 [] =
-< return ()
-< graphloop2 ys =
-< let ys' = take n ys
-< m = maximum ys'
-< y_scale = (floor m) + 1
-< y_scale' = fromInt y_scale
-< in
-< xCls >>
-< drawScales y_scale >>
-< draw x_coords [ x / y_scale' | x <- ys' ] >>
-< xHandleEvent >>
-< graphloop2 (tail ys)
-
-
-> graphloop2 :: [Float] -> [Float] -> IO ()
-> graphloop2 (y:ys) xs =
-> let xs' = take n (y:xs)
-> m = maximum xs'
-> y_scale = (floor m) + 1
-> y_scale' = fromInt y_scale
-> in
-> xCls >>
-> drawScales y_scale >>
-> draw x_coords [ x / y_scale' | x <- xs' ] >>
-> xHandleEvent >>
-> graphloop2 ys xs'
-> graphloop2 [] xs =
-> return ()
-
-> x_coords :: [Float]
-> x_coords = [ 0.0, 1 / (fromInt n) .. ]
-
-Draw lines specified by coordinates in range (0.0 .. 1.0) onto screen.
-
-> draw :: [Float] -> [Float] -> IO ()
-> draw xs ys = drawPoly (zip xs' (reverse ys'))
-> where
-> xs' = [ floor (x * sz) | x <- xs ]
-> ys' = [ floor ((1.0 - y) * sz) | y <- ys ]
-> sz = fromInt screen_size
-
-> drawPoly :: [(Int, Int)] -> IO ()
-> drawPoly ((x1,y1):(x2,y2):poly) =
-> xDrawLine x1 y1 x2 y2 >>
-> drawPoly ((x2,y2):poly)
-> drawPoly _ = return ()
-
-Draw horizontal line at major points on y-axis.
-
-> drawScales :: Int -> IO ()
-> drawScales y_scale =
-> sequence (map drawScale ys) >>
-> return ()
-> where
-> ys = [ (fromInt i) / (fromInt y_scale) | i <- [1 .. y_scale - 1] ]
-
-> drawScale :: Float -> IO ()
-> drawScale y =
-> let y' = floor ((1.0 - y) * (fromInt screen_size))
-> in
-> xDrawLine 0 y' screen_size y'
-
->#include "common-bits"
diff --git a/ghc/utils/heap-view/HaskXLib.c b/ghc/utils/heap-view/HaskXLib.c
deleted file mode 100644
index b6cf1f137c..0000000000
--- a/ghc/utils/heap-view/HaskXLib.c
+++ /dev/null
@@ -1,297 +0,0 @@
-/*----------------------------------------------------------------------*
- * X from Haskell (PicoX)
- *
- * (c) 1993 Andy Gill
- *
- *----------------------------------------------------------------------*/
-
-#include <X11/Xlib.h>
-#include <X11/Xutil.h>
-#include <X11/Xatom.h>
-#include <stdio.h>
-#include <strings.h>
-
-/*----------------------------------------------------------------------*/
-
-/* First the X Globals */
-
-Display *MyDisplay;
-int MyScreen;
-Window MyWindow;
-XEvent MyWinEvent;
-GC DrawGC;
-GC UnDrawGC;
-
-/* and the Haskell globals */
-
-typedef struct {
- int HaskButtons[5];
- int HaskPointerX,HaskPointerY;
- int PointMoved;
-} HaskGlobType;
-
-HaskGlobType HaskGlob;
-
-/*----------------------------------------------------------------------*/
-
-/*
- * Now the access functions into the haskell globals
- */
-
-int haskGetButtons(int n)
-{
- return(HaskGlob.HaskButtons[n]);
-}
-
-int haskGetPointerX(void)
-{
- return(HaskGlob.HaskPointerX);
-}
-
-int haskGetPointerY(void)
-{
- return(HaskGlob.HaskPointerY);
-}
-
-/*----------------------------------------------------------------------*/
-
-/*
- *The (rather messy) initiualisation
- */
-
-haskXBegin(int x,int y,int sty)
-{
- /*
- * later include these via interface hacks
- */
-
- /* (int argc, char **argv) */
- int argc = 0;
- char **argv = 0;
-
- XSizeHints XHints;
- int MyWinFG, MyWinBG,tmp;
-
- if ((MyDisplay = XOpenDisplay("")) == NULL) {
- fprintf(stderr, "Cannot connect to X server '%s'\n", XDisplayName(""));
- exit(1);
- }
-
- MyScreen = DefaultScreen(MyDisplay);
-
- MyWinBG = WhitePixel(MyDisplay, MyScreen);
- MyWinFG = BlackPixel(MyDisplay, MyScreen);
-
- XHints.x = x;
- XHints.y = y;
- XHints.width = x;
- XHints.height = y;
- XHints.flags = PPosition | PSize;
-
- MyWindow =
- XCreateSimpleWindow(
- MyDisplay,
- DefaultRootWindow(MyDisplay),
- x,y, x, y,
- 5,
- MyWinFG,
- MyWinBG
- );
-
- XSetStandardProperties(
- MyDisplay,
- MyWindow,
- "XLib for Glasgow Haskell",
- "XLib for Glasgow Haskell",
- None,
- argv,
- argc,
- &XHints
- );
-
- /* Create drawing and erasing GC */
-
- DrawGC = XCreateGC(MyDisplay,MyWindow,0, 0);
- XSetBackground(MyDisplay,DrawGC,MyWinBG);
- XSetForeground(MyDisplay,DrawGC,MyWinFG);
-
- UnDrawGC = XCreateGC(MyDisplay,MyWindow,0, 0);
- XSetBackground(MyDisplay,UnDrawGC,MyWinFG);
- XSetForeground(MyDisplay,UnDrawGC,MyWinBG);
-
- XSetGraphicsExposures(MyDisplay,DrawGC,False);
- XSetGraphicsExposures(MyDisplay,UnDrawGC,False);
- XMapRaised(MyDisplay,MyWindow);
-
- /* the user should be able to choose which are tested for
- */
-
- XSelectInput(
- MyDisplay,
- MyWindow,
- ButtonPressMask | ButtonReleaseMask | PointerMotionMask
- );
-
- /* later have more drawing styles
- */
-
- switch (sty)
- {
- case 0:
- /* Andy, this used to be GXor not much use for Undrawing so I
- changed it. (Not much use for colour either - see next
- comment */
- XSetFunction(MyDisplay,DrawGC,GXcopy);
- XSetFunction(MyDisplay,UnDrawGC,GXcopy);
- break;
- case 1:
- /* Andy, this can have totally bogus results on a colour screen */
- XSetFunction(MyDisplay,DrawGC,GXxor);
- XSetFunction(MyDisplay,UnDrawGC,GXxor);
- break;
- default:
- /* Andy, is this really a good error message? */
- printf(stderr,"Wrong Argument to XSet function\n");
- }
- /*
- * reset the (Haskell) globals
- */
-
- for(tmp=0;tmp<5;tmp++)
- {
- HaskGlob.HaskButtons[tmp] = 0;
- }
- HaskGlob.HaskPointerX = 0;
- HaskGlob.HaskPointerY = 0;
- HaskGlob.PointMoved = 0;
-
- XFlush(MyDisplay);
-
-}
-
-/*----------------------------------------------------------------------*/
-
-/* Boring X ``Do Something'' functions
- */
-
-haskXClose(void)
-{
- XFreeGC( MyDisplay, DrawGC);
- XFreeGC( MyDisplay, UnDrawGC);
- XDestroyWindow( MyDisplay, MyWindow);
- XCloseDisplay( MyDisplay);
- return(0);
-}
-
-haskXDraw(x,y,x1,y1)
-int x,y,x1,y1;
-{
- XDrawLine(MyDisplay,
- MyWindow,
- DrawGC,
- x,y,x1,y1);
- return(0);
-}
-
-
-haskXPlot(c,x,y)
-int c;
-int x,y;
-{
- XDrawPoint(MyDisplay,
- MyWindow,
- (c?DrawGC:UnDrawGC),
- x,y);
- return(0);
-}
-
-haskXFill(c,x,y,w,h)
-int c;
-int x, y;
-int w, h;
-{
- XFillRectangle(MyDisplay,
- MyWindow,
- (c?DrawGC:UnDrawGC),
- x, y, w, h);
- return(0);
-}
-
-/*----------------------------------------------------------------------*/
-
- /* This has to be called every time round the loop,
- * it flushed the buffer and handles input from the user
- */
-
-haskHandleEvent()
-{
- XFlush( MyDisplay);
- while (XEventsQueued( MyDisplay, QueuedAfterReading) != 0) {
- XNextEvent( MyDisplay, &MyWinEvent);
- switch (MyWinEvent.type) {
- case ButtonPress:
- switch (MyWinEvent.xbutton.button)
- {
- case Button1: HaskGlob.HaskButtons[0] = 1; break;
- case Button2: HaskGlob.HaskButtons[1] = 1; break;
- case Button3: HaskGlob.HaskButtons[2] = 1; break;
- case Button4: HaskGlob.HaskButtons[3] = 1; break;
- case Button5: HaskGlob.HaskButtons[4] = 1; break;
- }
- break;
- case ButtonRelease:
- switch (MyWinEvent.xbutton.button)
- {
- case Button1: HaskGlob.HaskButtons[0] = 0; break;
- case Button2: HaskGlob.HaskButtons[1] = 0; break;
- case Button3: HaskGlob.HaskButtons[2] = 0; break;
- case Button4: HaskGlob.HaskButtons[3] = 0; break;
- case Button5: HaskGlob.HaskButtons[4] = 0; break;
- }
- break;
- case MotionNotify:
- HaskGlob.HaskPointerX = MyWinEvent.xmotion.x;
- HaskGlob.HaskPointerY = MyWinEvent.xmotion.y;
- HaskGlob.PointMoved = 1;
- break;
- default:
- printf("UNKNOWN INTERUPT ???? (%d) \n",MyWinEvent.type);
- break;
- } /*switch*/
- } /*if*/
- return(0);
-}
-
-
-/*----------------------------------------------------------------------*/
-
- /* A function to clear the screen
- */
-
-haskXCls(void)
-{
- XClearWindow(MyDisplay,MyWindow);
-}
-
-/*----------------------------------------------------------------------*/
-
- /* A function to write a string
- */
-
-haskXDrawString(int x,int y,char *str)
-{
- return(0);
-/* printf("GOT HERE %s %d %d",str,x,y);
- XDrawString(MyDisplay,MyWindow,DrawGC,x,y,str,strlen(str));
-*/
-}
-
-/*----------------------------------------------------------------------*/
-
-extern int prog_argc;
-extern char **prog_argv;
-
-haskArgs()
-{
- return(prog_argc > 1 ? atoi(prog_argv[1]) : 0);
-}
diff --git a/ghc/utils/heap-view/HpView.lhs b/ghc/utils/heap-view/HpView.lhs
deleted file mode 100644
index a7b4cbb78e..0000000000
--- a/ghc/utils/heap-view/HpView.lhs
+++ /dev/null
@@ -1,296 +0,0 @@
-> module Main where
-> import PreludeGlaST
-> import LibSystem
-
-> import Parse
-
-Program to interpret a heap profile.
-
-Started 28/11/93: parsing of profile
-Tweaked 28/11/93: parsing fiddled till it worked and graphical backend added
-
-To be done:
-
-0) think about where I want to go with this
-1) further processing... sorting, filtering, ...
-2) get dynamic display
-3) maybe use widgets
-
-Here's an example heap profile
-
- JOB "a.out -p"
- DATE "Fri Apr 17 11:43:45 1992"
- SAMPLE_UNIT "seconds"
- VALUE_UNIT "bytes"
- BEGIN_SAMPLE 0.00
- SYSTEM 24
- END_SAMPLE 0.00
- BEGIN_SAMPLE 1.00
- elim 180
- insert 24
- intersect 12
- disin 60
- main 12
- reduce 20
- SYSTEM 12
- END_SAMPLE 1.00
- MARK 1.50
- MARK 1.75
- MARK 1.80
- BEGIN_SAMPLE 2.00
- elim 192
- insert 24
- intersect 12
- disin 84
- main 12
- SYSTEM 24
- END_SAMPLE 2.00
- BEGIN_SAMPLE 2.82
- END_SAMPLE 2.82
-
-By inspection, the format seems to be:
-
-profile :== header { sample }
-header :== job date { unit }
-job :== "JOB" command
-date :== "DATE" dte
-unit :== "SAMPLE_UNIT" string | "VALUE_UNIT" string
-
-sample :== samp | mark
-samp :== "BEGIN_SAMPLE" time {pairs} "END_SAMPLE" time
-pairs :== identifer count
-mark :== "MARK" time
-
-command :== string
-dte :== string
-time :== float
-count :== integer
-
-But, this doesn't indicate the line structure. The simplest way to do
-this is to treat each line as a single token --- for which the
-following parser is useful:
-
-Special purpose parser that recognises a string if it matches a given
-prefix and returns the remainder.
-
-> prefixP :: String -> P String String
-> prefixP p =
-> itemP `thenP` \ a ->
-> let (p',a') = splitAt (length p) a
-> in if p == p'
-> then unitP a'
-> else zeroP
-
-
-To begin with I want to parse a profile into a list of readings for
-each identifier at each time.
-
-> type Sample = (Float, [(String, Int)])
-
-> type Line = String
-
-
-> profile :: P Line [Sample]
-> profile =
-> header `thenP_`
-> zeroOrMoreP sample
-
-> header :: P Line ()
-> header =
-> job `thenP_`
-> date `thenP_`
-> zeroOrMoreP unit `thenP_`
-> unitP ()
-
-> job :: P Line String
-> job = prefixP "JOB "
-
-> date :: P Line String
-> date = prefixP "DATE "
-
-> unit :: P Line String
-> unit =
-> ( prefixP "SAMPLE_UNIT " )
-> `plusP`
-> ( prefixP "VALUE_UNIT " )
-
-> sample :: P Line Sample
-> sample =
-> samp `plusP` mark
-
-> mark :: P Line Sample
-> mark =
-> prefixP "MARK " `thenP` \ time ->
-> unitP (read time, [])
-
-ToDo: check that @time1 == time2@
-
-> samp :: P Line Sample
-> samp =
-> prefixP "BEGIN_SAMPLE " `thenP` \ time1 ->
-> zeroOrMoreP pair `thenP` \ pairs ->
-> prefixP "END_SAMPLE " `thenP` \ time2 ->
-> unitP (read time1, pairs)
-
-> pair :: P Line (String, Int)
-> pair =
-> prefixP " " `thenP` \ sample_line ->
-> let [identifier,count] = words sample_line
-> in unitP (identifier, read count)
-
-This test works fine
-
-> {-
-> test :: String -> String
-> test str = ppSamples (theP profile (lines str))
-
-> test1 = test example
-
-> test2 :: String -> Dialogue
-> test2 file =
-> readFile file exit
-> (\ hp -> appendChan stdout (test hp) exit
-> done)
-> -}
-
-Inefficient pretty-printer (uses ++ excessively)
-
-> ppSamples :: [ Sample ] -> String
-> ppSamples = unlines . map ppSample
-
-> ppSample :: Sample -> String
-> ppSample (time, samps) =
-> (show time) ++ unwords (map ppSamp samps)
-
-> ppSamp :: (String, Int) -> String
-> ppSamp (identifier, count) = identifier ++ ":" ++ show count
-
-To get the test1 to work in gofer, you need to fiddle with the input
-a bit to get over Gofer's lack of string-parsing code.
-
-> example =
-> "JOB \"a.out -p\"\n" ++
-> "DATE \"Fri Apr 17 11:43:45 1992\"\n" ++
-> "SAMPLE_UNIT \"seconds\"\n" ++
-> "VALUE_UNIT \"bytes\"\n" ++
-> "BEGIN_SAMPLE 0.00\n" ++
-> " SYSTEM 24\n" ++
-> "END_SAMPLE 0.00\n" ++
-> "BEGIN_SAMPLE 1.00\n" ++
-> " elim 180\n" ++
-> " insert 24\n" ++
-> " intersect 12\n" ++
-> " disin 60\n" ++
-> " main 12\n" ++
-> " reduce 20\n" ++
-> " SYSTEM 12\n" ++
-> "END_SAMPLE 1.00\n" ++
-> "MARK 1.50\n" ++
-> "MARK 1.75\n" ++
-> "MARK 1.80\n" ++
-> "BEGIN_SAMPLE 2.00\n" ++
-> " elim 192\n" ++
-> " insert 24\n" ++
-> " intersect 12\n" ++
-> " disin 84\n" ++
-> " main 12\n" ++
-> " SYSTEM 24\n" ++
-> "END_SAMPLE 2.00\n" ++
-> "BEGIN_SAMPLE 2.82\n" ++
-> "END_SAMPLE 2.82"
-
-
-
-
-Hack to let me test this code... Gofer doesn't have integer parsing built in.
-
-> {-
-> read :: String -> Int
-> read s = 0
-> -}
-
-> screen_size = 200
-
-ToDo:
-
-1) the efficiency of finding slices can probably be dramatically
- improved... if it matters.
-
-2) the scaling should probably depend on the slices used
-
-3) labelling graphs, colour, ...
-
-4) responding to resize events
-
-> main :: IO ()
-> main =
-> getArgs >>= \ r ->
-> case r of
-> filename:idents ->
-> readFile filename >>= \ hp ->
-> let samples = theP profile (lines hp)
->
-> times = [ t | (t,ss) <- samples ]
-> names = [ n | (t,ss) <- samples, (n,c) <- ss ]
-> counts = [ c | (t,ss) <- samples, (n,c) <- ss ]
->
-> time = maximum times
-> x_scale = (fromInt screen_size) / time
->
-> max_count = maximum counts
-> y_scale = (fromInt screen_size) / (fromInt max_count)
->
-> slices = map (slice samples) idents
-> in
-> xInitialise [] screen_size screen_size >>
-> -- drawHeap x_scale y_scale samples >>
-> sequence (map (drawSlice x_scale y_scale) slices) >>
-> freeze
-> _ -> error "usage: hpView filename identifiers\n"
-
-> freeze :: IO ()
-> freeze =
-> xHandleEvent >>
-> usleep 100 >>
-> freeze
-
-
-Slice drawing stuff... shows profile for each identifier
-
-> slice :: [Sample] -> String -> [(Float,Int)]
-> slice samples ident =
-> [ (t,c) | (t,ss) <- samples, c <- [lookupPairs ss ident 0] ]
-
-> lookupPairs :: Eq a => [(a, b)] -> a -> b -> b
-> lookupPairs ((a', b') : hs) a b =
-> if a == a' then b' else lookupPairs hs a b
-> lookupPairs [] a b = b
-
-> drawSlice :: Float -> Float -> [(Float,Int)] -> IO ()
-> drawSlice x_scale y_scale slc =
-> drawPoly
-> [ (round (x*x_scale), screen_size - (round ((fromInt y)*y_scale))) | (x,y) <- slc ]
-
-> drawPoly :: [(Int, Int)] -> IO ()
-> drawPoly ((x1,y1):(x2,y2):poly) =
-> xDrawLine x1 y1 x2 y2 >>
-> drawPoly ((x2,y2):poly)
-> drawPoly _ = return ()
-
-
-Very simple heap profiler... doesn't do a proper job at all. Good for
-testing.
-
-> drawHeap :: Float -> Float -> [Sample] -> IO ()
-> drawHeap x_scale y_scale samples =
-> sequence (map xBar
-> [ (t*x_scale, (fromInt c)*y_scale)
-> | (t,ss) <- samples, (n,c) <- ss ]) >>
-> return ()
-
-> xBar :: (Float, Float) -> IO ()
-> xBar (x, y) =
-> let {x' = round x; y' = round y}
-> in xDrawLine x' screen_size x' (screen_size - y')
-
->#include "common-bits"
diff --git a/ghc/utils/heap-view/HpView2.lhs b/ghc/utils/heap-view/HpView2.lhs
deleted file mode 100644
index fa8044b8b4..0000000000
--- a/ghc/utils/heap-view/HpView2.lhs
+++ /dev/null
@@ -1,225 +0,0 @@
-> module Main where
-> import PreludeGlaST
-> import LibSystem
-
-> import Parse
-
-Program to do continuous heap profile.
-
-Bad News:
-
- The ghc runtime system writes its heap profile information to a
- named file (<progname>.hp). The program merrily reads its input
- from a named file but has no way of synchronising with the program
- generating the file.
-
-Good News 0:
-
- You can save the heap profile to a file:
-
- <progname> <parameters> +RTS -h -i0.1 -RTS
-
- and then run:
-
- hpView2 <progname>.hp Main:<functionname>
-
- This is very like using hp2ps but much more exciting because you
- never know what's going to happen next :-)
-
-
-Good News 1:
-
- The prophet Stallman has blessed us with the shell command @mkfifo@
- (is there a standard Unix version?) which creates a named pipe. If we
- instead run:
-
- mkfifo <progname>.hp
- hpView2 <progname>.hp Main:<functionname> &
- <progname> <parameters> +RTS -h -i0.1 -RTS
- rm <progname>.hp
-
- Good Things happen.
-
- NB If you don't delete the pipe, Bad Things happen: the program
- writes profiling info to the pipe until the pipe fills up then it
- blocks...
-
-
-Right, on with the program:
-
-Here's an example heap profile
-
- JOB "a.out -p"
- DATE "Fri Apr 17 11:43:45 1992"
- SAMPLE_UNIT "seconds"
- VALUE_UNIT "bytes"
- BEGIN_SAMPLE 0.00
- SYSTEM 24
- END_SAMPLE 0.00
- BEGIN_SAMPLE 1.00
- elim 180
- insert 24
- intersect 12
- disin 60
- main 12
- reduce 20
- SYSTEM 12
- END_SAMPLE 1.00
- MARK 1.50
- MARK 1.75
- MARK 1.80
- BEGIN_SAMPLE 2.00
- elim 192
- insert 24
- intersect 12
- disin 84
- main 12
- SYSTEM 24
- END_SAMPLE 2.00
- BEGIN_SAMPLE 2.82
- END_SAMPLE 2.82
-
-In HpView.lhs, I had a fancy parser to handle all this - but it was
-immensely inefficient. We can produce something a lot more efficient
-and robust very easily by noting that the only lines we care about
-have precisely two entries on them.
-
-> type Line = String
-> type Word = String
-> type Sample = (Float, [(String, Int)])
-
-> parseProfile :: [[Word]] -> [Sample]
-> parseProfile [] = []
-> parseProfile ([keyword, time]:lines) | keyword == "BEGIN_SAMPLE" =
-> let (sample,rest) = parseSample lines
-> in
-> (read time, sample) : parseProfile rest
-> parseProfile (_:xs) = parseProfile xs
-
-> parseSample :: [[Word]] -> ([(String,Int)],[[Word]])
-> parseSample ([word, count]:lines) =
-> if word == "END_SAMPLE"
-> then ([], lines)
-> else let (samples, rest) = parseSample lines
-> in ( (word, read count):samples, rest )
-> parseSample duff_lines = ([],duff_lines)
-
-> screen_size = 200
-
-> main :: IO ()
-> main =
-> getArgs >>= \ r ->
-> case r of
-> [filename, ident] ->
-> xInitialise [] screen_size screen_size >>
-> readFile filename >>= \ hp ->
-> let samples = parseProfile (map words (lines hp))
-> totals = [ sum [ s | (_,s) <- ss ] | (t,ss) <- samples ]
->
-> ts = map scale totals
-> is = map scale (slice samples ident)
-> in
-> graphloop2 (is, []) (ts, [])
-> _ -> error "usage: hpView2 file identifier\n"
-
-For the example I'm running this on, the following scale does nicely.
-
-> scale :: Int -> Float
-> scale n = (fromInt n) / 10000.0
-
-Slice drawing stuff... shows profile for each identifier (Ignores time
-info in this version...)
-
-> slice :: [Sample] -> String -> [Int]
-> slice samples ident =
-> [ c | (t,ss) <- samples, c <- [lookupPairs ss ident 0] ]
-
-> lookupPairs :: Eq a => [(a, b)] -> a -> b -> b
-> lookupPairs ((a', b') : hs) a b =
-> if a == a' then b' else lookupPairs hs a b
-> lookupPairs [] a b = b
-
-Number of samples to display on screen
-
-> n :: Int
-> n = 40
-
-Graph-drawing loop. Get's the data for the particular identifier and
-the total usage, scales to get total to fit screen and draws them.
-
-> graphloop2 :: ([Float], [Float]) -> ([Float], [Float]) -> IO ()
-> graphloop2 (i:is,is') (t:ts, ts') =
-> let is'' = take n (i:is')
-> ts'' = take n (t:ts')
->
-> -- scaling information:
-> m = maximum ts''
-> y_scale = (floor m) + 1
-> y_scale' = fromInt y_scale
-> in
-> xCls >>
-> drawScales y_scale >>
-> draw x_coords [ x / y_scale' | x <- is'' ] >>
-> draw x_coords [ x / y_scale' | x <- ts'' ] >>
-> xHandleEvent >>
-> graphloop2 (is,is'') (ts, ts'')
-> graphloop2 _ _ =
-> return ()
-
-> x_coords :: [Float]
-> x_coords = [ 0.0, 1 / (fromInt n) .. ]
-
-Note: unpleasant as it is, the code cannot be simplified to something
-like the following (which has scope for changing draw to take a list
-of pairs). The problem is that the graph won't start to be drawn
-until the first @n@ values are available. (Is there also a danger of
-clearing the screen while waiting for the next input value?) A
-possible alternative solution is to keep count of how many values have
-actually been received.
-
-< graphloop2 :: [Float] -> [Float] -> IO ()
-< graphloop2 [] =
-< return ()
-< graphloop2 ys =
-< let ys' = take n ys
-< m = maximum ys'
-< y_scale = (floor m) + 1
-< y_scale' = fromInt y_scale
-< in
-< xCls >>
-< drawScales y_scale >>
-< draw x_coords [ x / y_scale' | x <- ys' ] >>
-< xHandleEvent >>
-< graphloop2 (tail ys)
-
-Draw lines specified by coordinates in range (0.0 .. 1.0) onto screen.
-
-> draw :: [Float] -> [Float] -> IO ()
-> draw xs ys = drawPoly (zip xs' (reverse ys'))
-> where
-> xs' = [ floor (x * sz) | x <- xs ]
-> ys' = [ floor ((1.0 - y) * sz) | y <- ys ]
-> sz = fromInt screen_size
-
-> drawPoly :: [(Int, Int)] -> IO ()
-> drawPoly ((x1,y1):(x2,y2):poly) =
-> xDrawLine x1 y1 x2 y2 >>
-> drawPoly ((x2,y2):poly)
-> drawPoly _ = return ()
-
-Draw horizontal line at major points on y-axis.
-
-> drawScales :: Int -> IO ()
-> drawScales y_scale =
-> sequence (map drawScale ys) >>
-> return ()
-> where
-> ys = [ (fromInt i) / (fromInt y_scale) | i <- [1 .. y_scale - 1] ]
-
-> drawScale :: Float -> IO ()
-> drawScale y =
-> let y' = floor ((1.0 - y) * (fromInt screen_size))
-> in
-> xDrawLine 0 y' screen_size y'
-
->#include "common-bits"
diff --git a/ghc/utils/heap-view/MAIL b/ghc/utils/heap-view/MAIL
deleted file mode 100644
index 966fcdcfc7..0000000000
--- a/ghc/utils/heap-view/MAIL
+++ /dev/null
@@ -1,67 +0,0 @@
-To: partain@dcs.gla.ac.uk
-cc: areid@dcs.gla.ac.uk, andy@dcs.gla.ac.uk
-Subject: Heap profiling programs
-Date: Thu, 09 Dec 93 17:33:09 +0000
-From: Alastair Reid <areid@dcs.gla.ac.uk>
-
-
-I've hacked up a couple of programs which it might be worth putting in
-the next ghc distribution. They are:
-
-graph:
-
- Draws a continuous graph of any one column of the statistics
- produced using the "+RTS -Sstderr" option.
-
- I'm not convinced this is astonishingly useful since I'm yet to
- learn anything useful from (manually) examining these statistics.
- (Although I do vaguely remember asking Patrick if the heap profiler
- could do stack profiles too.)
-
- A typical usage is:
-
- slife 2 Unis/gardenofeden +RTS -Sstderr -H1M -RTS |& graph 2
-
- which draws a graph of the third column (ie column 2!) of the
- stats.
-
- (btw is there a neater way of connecting stderr to graph's stdin?)
-
-hpView2:
-
- Draws a continuous graph of the statistics reported by the "+RTS -h"
- option.
-
- Since I understand what the figures mean, this seems to be the more
- useful program.
-
- A typical usage is:
-
- mkfifo slife.hp
- hpView2 slife.hp Main:mkQuad &
- slife 2 Unis/gardenofeden +RTS -h -i0.1 -RTS
- rm slife.hp
-
- which draws a graph of the total heap usage and the usage for Main:mkQuad.
-
-
-Minor problems:
-
-The code is a gross hack... but it works. (Maybe distribute in rot13
-format so that you don't get accidentally get exposed to obscene code
-:-))
-
-The code uses a variant of Andy's picoXlibrary (which he was talking
-about releasing but maybe isn't ready to do yet.)
-
-Also, there are lots of obvious extensions etc which could be made but
-haven't yet... (The major one is being able to set the initial
-scale-factor for displaying the graphs or being able to graph several
-stats at once without having to tee.)
-
-
-Hope you find them interesting.
-
-Alastair
-
-ps Code is in ~areid/hask/Life and should be readable/executable.
diff --git a/ghc/utils/heap-view/Makefile b/ghc/utils/heap-view/Makefile
deleted file mode 100644
index 2d8a819df3..0000000000
--- a/ghc/utils/heap-view/Makefile
+++ /dev/null
@@ -1,36 +0,0 @@
-#---------------------------------------------------------------------
-# $Id: Makefile,v 1.3 1997/03/13 09:36:28 sof Exp $
-#
-#---------------------------------------------------------------------
-
-TOP=../..
-include $(TOP)/mk/boilerplate.mk
-
-PROGRAMS = graph hpView hpView2
-
-SRC_HC_OPTS += -hi-diffs -fglasgow-exts -fhaskell-1.3 -O -L/usr/X11/lib -cpp
-SRC_CC_OPTS += -ansi -I/usr/X11/include
-# ToDo: use AC_PATH_X in configure to get lib/include dirs for X.
-
-OBJS_graph = Graph.o HaskXLib.o
-OBJS_hpView = HpView.o Parse.o HaskXLib.o
-OBJS_hpView2 = HpView2.o Parse.o HaskXLib.o
-
-all :: $(PROGRAMS)
-
-graph : $(OBJS_graph)
- $(HC) -o $@ $(HC_OPTS) $(LD_OPTS) $(OBJS_graph) -lX11
-
-hpView : $(OBJS_hpView)
- $(HC) -o $@ $(HC_OPTS) $(LD_OPTS) $(OBJS_hpView) -lX11
-
-hpView2 : $(OBJS_hpView2)
- $(HC) -o $@ $(HC_OPTS) $(LD_OPTS) $(OBJS_hpView2) -lX11
-
-HaskXLib.o : HaskXLib.c
- $(CC) -c $(CC_OPTS) HaskXLib.c
-
-INSTALL_PROGS += $(PROGRAMS)
-CLEAN_FILES += $(PROGRAMS)
-
-include $(TOP)/mk/target.mk
diff --git a/ghc/utils/heap-view/Makefile.original b/ghc/utils/heap-view/Makefile.original
deleted file mode 100644
index 1e35bc2e43..0000000000
--- a/ghc/utils/heap-view/Makefile.original
+++ /dev/null
@@ -1,48 +0,0 @@
-CC=gcc
-GLHC18 = glhc18
-GLHC19 = /users/fp/partain/bin/sun4/glhc
-HC= ghc -hi-diffs -fglasgow-exts -fhaskell-1.3
-HC_FLAGS = -O -prof -auto-all
-#HC_FLAGS = -O
-LIBS=-lX11
-FILES2 = Life2.o HaskXLib.o
-FILESS = LifeWithStability.o HaskXLib.o
-FILES = Life.o HaskXLib.o
-
-all : hpView hpView2
-
-# ADR's heap profile viewer
-hpView: HpView.o Parse.o HaskXLib.o
- $(HC) -o hpView $(HC_FLAGS) HpView.o Parse.o HaskXLib.o $(LIBS) -L/usr/X11/lib
-clean::
- rm -f hpView
-
-# ADR's continuous heap profile viewer (handles output of -p)
-hpView2: HpView2.o Parse.o HaskXLib.o
- $(HC) -o hpView2 $(HC_FLAGS) HpView2.o Parse.o HaskXLib.o $(LIBS) -L/usr/X11/lib
-clean::
- rm -f hpView2
-
-
-# ADR's continuous graph program (handles output of -Sstderr)
-graph: Graph.o HaskXLib.o
- $(HC) -o graph $(HC_FLAGS) Graph.o HaskXLib.o $(LIBS) -L/usr/X11/lib
-clean::
- rm -f graph
-
-# ADR's continuous graph program (part of heap profile viewer) that
-# crashes the compiler
-bugGraph: bugGraph.o HaskXLib.o
- $(HC) -o bugGraph $(HC_FLAGS) bugGraph.o HaskXLib.o $(LIBS) -L/usr/X11/lib
-clean::
- rm -f bugGraph
-
-%.o:%.c
- $(CC) -c -ansi -traditional -g -I/usr/X11/include/ $< $(INC)
-
-%.o:%.lhs
- $(HC) $(HC_FLAGS) -c $< $(INC)
-
-clean::
- rm -f core *.o *% #*
- rm -f *.hc
diff --git a/ghc/utils/heap-view/Parse.lhs b/ghc/utils/heap-view/Parse.lhs
deleted file mode 100644
index 9d7652fdcc..0000000000
--- a/ghc/utils/heap-view/Parse.lhs
+++ /dev/null
@@ -1,92 +0,0 @@
-> module Parse where
-
-The Parser monad in "Comprehending Monads"
-
-> infixr 9 `thenP`
-> infixr 9 `thenP_`
-> infixr 9 `plusP`
-
-> type P t a = [t] -> [(a,[t])]
-
-> unitP :: a -> P t a
-> unitP a = \i -> [(a,i)]
-
-> thenP :: P t a -> (a -> P t b) -> P t b
-> m `thenP` k = \i0 -> [(b,i2) | (a,i1) <- m i0, (b,i2) <- k a i1]
-
-> thenP_ :: P t a -> P t b -> P t b
-> m `thenP_` k = \i0 -> [(b,i2) | (a,i1) <- m i0, (b,i2) <- k i1]
-
-zeroP is the parser that always fails to parse its input
-
-> zeroP :: P t a
-> zeroP = \i -> []
-
-plusP combines two parsers in parallel
-(called "alt" in "Comprehending Monads")
-
-> plusP :: P t a -> P t a -> P t a
-> a1 `plusP` a2 = \i -> (a1 i) ++ (a2 i)
-
-itemP is the parser that parses a single token
-(called "next" in "Comprehending Monads")
-
-> itemP :: P t t
-> itemP = \i -> [(head i, tail i) | not (null i)]
-
-force successful parse
-
-> cutP :: P t a -> P t a
-> cutP p = \u -> let l = p u in if null l then [] else [head l]
-
-find all complete parses of a given string
-
-> useP :: P t a -> [t] -> [a]
-> useP m = \x -> [ a | (a,[]) <- m x ]
-
-find first complete parse
-
-> theP :: P t a -> [t] -> a
-> theP m = head . (useP m)
-
-
-Some standard parser definitions
-
-mapP applies f to all current parse trees
-
-> mapP :: (a -> b) -> P t a -> P t b
-> f `mapP` m = m `thenP` (\a -> unitP (f a))
-
-filter is the parser that parses a single token if it satisfies a
-predicate and fails otherwise.
-
-> filterP :: (a -> Bool) -> P t a -> P t a
-> p `filterP` m = m `thenP` (\a -> (if p a then unitP a else zeroP))
-
-lit recognises literals
-
-> litP :: Eq t => t -> P t ()
-> litP t = ((==t) `filterP` itemP) `thenP` (\c -> unitP () )
-
-> showP :: (Text a) => P t a -> [t] -> String
-> showP m xs = show (theP m xs)
-
-
-Simon Peyton Jones adds some useful operations:
-
-> zeroOrMoreP :: P t a -> P t [a]
-> zeroOrMoreP p = oneOrMoreP p `plusP` unitP []
-
-> oneOrMoreP :: P t a -> P t [a]
-> oneOrMoreP p = seq p
-> where seq p = p `thenP` (\a ->
-> (seq p `thenP` (\as -> unitP (a:as)))
-> `plusP`
-> unitP [a] )
-
-> oneOrMoreWithSepP :: P t a -> P t b -> P t [a]
-> oneOrMoreWithSepP p1 p2 = seq1 p1 p2
-> where seq1 p1 p2 = p1 `thenP` (\a -> seq2 p1 p2 a `plusP` unitP [a])
-> seq2 p1 p2 a = p2 `thenP` (\_ ->
-> seq1 p1 p2 `thenP` (\as -> unitP (a:as) ))
-
diff --git a/ghc/utils/heap-view/README b/ghc/utils/heap-view/README
deleted file mode 100644
index db9503abc4..0000000000
--- a/ghc/utils/heap-view/README
+++ /dev/null
@@ -1,62 +0,0 @@
-@HpView.lhs@ is a very primitive heap profile viewer written in
-Haskell. It feeds off the same files as hp2ps. It needs a lot of
-tidying up and would be far more useful as a continuous display.
-(It's in this directory `cos there happens to be a heap profile here
-and I couldn't be bothered setting up a new directory, Makefile, etc.)
-
-@Graph.lhs@ is a continuous heap viewer that "parses" the output of
-the +RTS -Sstderr option. Typical usage:
-
- slife 1 r4 +RTS -Sstderr |& graph 2
-
-(You might also try
-
- cat data | graph 2
-
- to see it in action on some sample data.
-)
-
-Things to watch:
-
- 1) Scaling varies from column to column - consult the source.
-
- 2) The horizontal scale is not time - it is garbage collections.
-
- 3) The graph is of the (n+1)st column of the -Sstderr output.
-
- The data is not always incredibly useful: For example, when using
- the (default) Appel 2-space garbage collector, the 3rd column
- displays the amount of "live" data in the minor space. A program
- with a constant data usage will appear to have a sawtooth usage
- as minor data gradually transfers to the major space and then,
- suddenly, all gets transferred back at major collections.
- Decreasing heap size decreases the size of the minor collections
- and increases major collections exaggerating the sawtooth.
-
- 4) The program is not as robust as it might be.
-
-
-@HpView2.lhs@ is the result of a casual coupling of @Graph.lhs@ and
-@HpView.lhs@ which draws continuous graphs of the heap consisting of:
-total usage and usage by one particular cost centre. For example:
-
- mkfifo slife.hp
- hpView2 slife.hp Main:mkQuad &
- slife 2 Unis/gardenofeden +RTS -h -i0.1 -RTS
- rm slife.hp
-
-draws a graph of total usage and usage by the function @mkQuad@.
-
-(You might also try
-
- hpView2 slife.old-hp Main:mkQuad
-
- to see it in action on some older data)
-
-The business with named pipes (mkfifo) is a little unfortunate - it
-would be nicer if the Haskell runtime system could output to stderr
-(say) which I could pipe into hpView which could just graph it's stdin
-(like graph does). It's probably worth wrapping the whole thing up in
-a little shell-script.
-
-
diff --git a/ghc/utils/heap-view/common-bits b/ghc/utils/heap-view/common-bits
deleted file mode 100644
index f41223b7f4..0000000000
--- a/ghc/utils/heap-view/common-bits
+++ /dev/null
@@ -1,35 +0,0 @@
- -----------------------------------------------------------------------------
-
- xInitialise :: [String] -> Int -> Int -> IO ()
- xInitialise str x y =
- _ccall_ haskXBegin x y (0::Int) `seqPrimIO`
- return ()
-
- xHandleEvent :: IO ()
- xHandleEvent =
- _ccall_ haskHandleEvent `thenPrimIO` \ n ->
- case (n::Int) of
- 0 -> return ()
- _ -> error "Unknown Message back from Handle Event"
-
- xClose :: IO ()
- xClose =
- _ccall_ haskXClose `seqPrimIO`
- return ()
-
- xCls :: IO ()
- xCls =
- _ccall_ haskXCls `seqPrimIO`
- return ()
-
- xDrawLine :: Int -> Int -> Int -> Int -> IO ()
- xDrawLine x1 y1 x2 y2 =
- _ccall_ haskXDraw x1 y1 x2 y2 `seqPrimIO`
- return ()
-
- ----------------------------------------------------------------
-
- usleep :: Int -> IO ()
- usleep t =
- _ccall_ usleep t `seqPrimIO`
- return ()
diff --git a/ghc/utils/hp2ps/AreaBelow.c b/ghc/utils/hp2ps/AreaBelow.c
deleted file mode 100644
index ec80e1ed48..0000000000
--- a/ghc/utils/hp2ps/AreaBelow.c
+++ /dev/null
@@ -1,62 +0,0 @@
-#include "Main.h"
-#include <stdio.h>
-#include <stdlib.h>
-#include "Defines.h"
-#include "Error.h"
-#include "HpFile.h"
-#include "Utilities.h"
-
-/* own stuff */
-#include "AreaBelow.h"
-
-/*
- * Return the area enclosed by all of the curves. The algorithm
- * used is the same as the trapizoidal rule for integration.
- */
-
-floatish
-AreaBelow()
-{
- intish i;
- intish j;
- intish bucket;
- floatish value;
- struct chunk *ch;
- floatish area;
- floatish trap;
- floatish base;
- floatish *maxima;
-
- maxima = (floatish *) xmalloc(nsamples * sizeof(floatish));
- for (i = 0; i < nsamples; i++) {
- maxima[i] = 0.0;
- }
-
- for (i = 0; i < nidents; i++) {
- for (ch = identtable[i]->chk; ch; ch = ch->next) {
- for (j = 0; j < ch->nd; j++) {
- bucket = ch->d[j].bucket;
- value = ch->d[j].value;
- if (bucket >= nsamples)
- Disaster("bucket out of range");
- maxima[ bucket ] += value;
- }
- }
- }
-
- area = 0.0;
-
- for (i = 1; i < nsamples; i++) {
- base = samplemap[i] - samplemap[i-1];
- if (maxima[i] > maxima[i-1]) {
- trap = base * maxima[i-1] + ((base * (maxima[i] - maxima[i-1]))/ 2.0);
- } else {
- trap = base * maxima[i] + ((base * (maxima[i-1] - maxima[i]))/ 2.0);
- }
-
- area += trap;
- }
-
- free(maxima);
- return area;
-}
diff --git a/ghc/utils/hp2ps/AreaBelow.h b/ghc/utils/hp2ps/AreaBelow.h
deleted file mode 100644
index d7f713f2b4..0000000000
--- a/ghc/utils/hp2ps/AreaBelow.h
+++ /dev/null
@@ -1,6 +0,0 @@
-#ifndef AREA_BELOW_H
-#define AREA_BELOW_H
-
-floatish AreaBelow PROTO((void));
-
-#endif /* AREA_BELOW_H */
diff --git a/ghc/utils/hp2ps/AuxFile.c b/ghc/utils/hp2ps/AuxFile.c
deleted file mode 100644
index 9998d3fc13..0000000000
--- a/ghc/utils/hp2ps/AuxFile.c
+++ /dev/null
@@ -1,168 +0,0 @@
-#include "Main.h"
-#include <ctype.h>
-#include <stdio.h>
-#include <string.h>
-#include "Defines.h"
-#include "Shade.h"
-#include "Error.h"
-#include "HpFile.h"
-#include "Reorder.h"
-
-/* own stuff */
-#include "AuxFile.h"
-
-static void GetAuxLine PROTO((FILE *)); /* forward */
-static void GetAuxTok PROTO((FILE *)); /* forward */
-
-void
-GetAuxFile(auxfp)
- FILE* auxfp;
-{
- ch = ' ';
- endfile = 0;
- linenum = 1;
-
- GetAuxTok(auxfp);
-
- while (endfile == 0) {
- GetAuxLine(auxfp);
- }
-
- fclose(auxfp);
-}
-
-
-
-/*
- * Read the next line from the aux file, check the syntax, and
- * perform the appropriate action.
- */
-
-static void
-GetAuxLine(auxfp)
- FILE* auxfp;
-{
- switch (thetok) {
- case X_RANGE_TOK:
- GetAuxTok(auxfp);
- if (thetok != FLOAT_TOK) {
- Error("%s, line %d, floating point number must follow X_RANGE",
- auxfile, linenum);
- }
- auxxrange = thefloatish;
- GetAuxTok(auxfp);
- break;
- case Y_RANGE_TOK:
- GetAuxTok(auxfp);
- if (thetok != FLOAT_TOK) {
- Error("%s, line %d, floating point number must follow Y_RANGE",
- auxfile, linenum);
- }
- auxyrange = thefloatish;
- GetAuxTok(auxfp);
- break;
- case ORDER_TOK:
- GetAuxTok(auxfp);
- if (thetok != IDENTIFIER_TOK) {
- Error("%s, line %d: identifier must follow ORDER",
- auxfile, linenum);
- }
- GetAuxTok(auxfp);
- if (thetok != INTEGER_TOK) {
- Error("%s, line %d: identifier and integer must follow ORDER",
- auxfile, linenum);
- }
- OrderFor(theident, theinteger);
- GetAuxTok(auxfp);
- break;
- case SHADE_TOK:
- GetAuxTok(auxfp);
- if (thetok != IDENTIFIER_TOK) {
- Error("%s, line %d: identifier must follow SHADE",
- auxfile, linenum);
- }
- GetAuxTok(auxfp);
- if (thetok != FLOAT_TOK) {
- Error("%s, line %d: identifier and floating point number must follow SHADE",
- auxfile, linenum);
- }
- ShadeFor(theident, thefloatish);
- GetAuxTok(auxfp);
- break;
- case EOF_TOK:
- endfile = 1;
- break;
- default:
- Error("%s, line %d: %s unexpected", auxfile, linenum,
- TokenToString(thetok));
- break;
- }
-}
-
-
-
-/*
- * Read the next token from the input and assign its value
- * to the global variable "thetok". In the case of numbers,
- * the corresponding value is also assigned to "thefloatish";
- * in the case of identifiers it is assigned to "theident".
- */
-
-static void GetAuxTok(auxfp)
-FILE* auxfp;
-{
-
- while (isspace(ch)) { /* skip whitespace */
- if (ch == '\n') linenum++;
- ch = getc(auxfp);
- }
-
- if (ch == EOF) {
- thetok = EOF_TOK;
- return;
- }
-
- if (isdigit(ch)) {
- thetok = GetNumber(auxfp);
- return;
- } else if (IsIdChar(ch)) { /* ch can't be a digit here */
- GetIdent(auxfp);
- if (!isupper((int)theident[0])) {
- thetok = IDENTIFIER_TOK;
- } else if (strcmp(theident, "X_RANGE") == 0) {
- thetok = X_RANGE_TOK;
- } else if (strcmp(theident, "Y_RANGE") == 0) {
- thetok = Y_RANGE_TOK;
- } else if (strcmp(theident, "ORDER") == 0) {
- thetok = ORDER_TOK;
- } else if (strcmp(theident, "SHADE") == 0) {
- thetok = SHADE_TOK;
- } else {
- thetok = IDENTIFIER_TOK;
- }
- return;
- } else {
- Error("%s, line %d: strange character (%c)", auxfile, linenum, ch);
- }
-}
-
-void
-PutAuxFile(auxfp)
- FILE* auxfp;
-{
- int i;
-
- fprintf(auxfp, "X_RANGE %.2f\n", xrange);
- fprintf(auxfp, "Y_RANGE %.2f\n", yrange);
-
- for (i = 0; i < nidents; i++) {
- fprintf(auxfp, "ORDER %s %d\n", identtable[i]->name, i+1);
- }
-
- for (i = 0; i < nidents; i++) {
- fprintf(auxfp, "SHADE %s %.2f\n", identtable[i]->name,
- ShadeOf(identtable[i]->name));
- }
-
- fclose(auxfp);
-}
diff --git a/ghc/utils/hp2ps/AuxFile.h b/ghc/utils/hp2ps/AuxFile.h
deleted file mode 100644
index 6e962c492e..0000000000
--- a/ghc/utils/hp2ps/AuxFile.h
+++ /dev/null
@@ -1,7 +0,0 @@
-#ifndef AUX_FILE_H
-#define AUX_FILE_H
-
-void PutAuxFile PROTO((FILE *));
-void GetAuxFile PROTO((FILE *));
-
-#endif /* AUX_FILE_H */
diff --git a/ghc/utils/hp2ps/Axes.c b/ghc/utils/hp2ps/Axes.c
deleted file mode 100644
index a2641cd676..0000000000
--- a/ghc/utils/hp2ps/Axes.c
+++ /dev/null
@@ -1,241 +0,0 @@
-#include "Main.h"
-#include <stdio.h>
-#include <string.h>
-#include "Curves.h"
-#include "Defines.h"
-#include "Dimensions.h"
-#include "HpFile.h"
-#include "Utilities.h"
-
-/* own stuff */
-#include "Axes.h"
-
-typedef enum {MEGABYTE, KILOBYTE, BYTE} mkb;
-
-static void XAxis PROTO((void)); /* forward */
-static void YAxis PROTO((void)); /* forward */
-
-static void XAxisMark PROTO((floatish, floatish)); /* forward */
-static void YAxisMark PROTO((floatish, floatish, mkb)); /* forward */
-
-static floatish Round PROTO((floatish)); /* forward */
-
-void
-Axes()
-{
- XAxis();
- YAxis();
-}
-
-static void
-XAxisMark(x, num)
- floatish x; floatish num;
-{
- /* calibration mark */
- fprintf(psfp, "%f %f moveto\n", xpage(x), ypage(0.0));
- fprintf(psfp, "0 -4 rlineto\n");
- fprintf(psfp, "stroke\n");
-
- /* number */
- fprintf(psfp, "HE%d setfont\n", NORMAL_FONT);
- fprintf(psfp, "(%.1f)\n", num);
- fprintf(psfp, "dup stringwidth pop\n");
- fprintf(psfp, "2 div\n");
- fprintf(psfp, "%f exch sub\n", xpage(x));
- fprintf(psfp, "%f moveto\n", borderspace);
- fprintf(psfp, "show\n");
-}
-
-
-#define N_X_MARKS 7
-#define XFUDGE 15
-
-extern floatish xrange;
-extern char *sampleunitstring;
-
-static void
-XAxis()
-{
- floatish increment, i;
- floatish t, x;
- floatish legendlen;
-
- /* draw the x axis line */
- fprintf(psfp, "%f %f moveto\n", xpage(0.0), ypage(0.0));
- fprintf(psfp, "%f 0 rlineto\n", graphwidth);
- fprintf(psfp, "%f setlinewidth\n", borderthick);
- fprintf(psfp, "stroke\n");
-
- /* draw x axis legend */
- fprintf(psfp, "HE%d setfont\n", NORMAL_FONT);
- fprintf(psfp, "(%s)\n", sampleunitstring);
- fprintf(psfp, "dup stringwidth pop\n");
- fprintf(psfp, "%f\n", xpage(0.0) + graphwidth);
- fprintf(psfp, "exch sub\n");
- fprintf(psfp, "%f moveto\n", borderspace);
- fprintf(psfp, "show\n");
-
-
- /* draw x axis scaling */
-
- increment = Round(xrange / (floatish) N_X_MARKS);
-
- t = graphwidth / xrange;
- legendlen = StringSize(sampleunitstring) + (floatish) XFUDGE;
-
- for (i = samplemap[0]; i < samplemap[nsamples - 1]; i += increment) {
- x = (i - samplemap[0]) * t;
-
- if (x < (graphwidth - legendlen)) {
- XAxisMark(x,i);
- }
- }
-}
-
-static void
-YAxisMark(y, num, unit)
- floatish y; floatish num; mkb unit;
-{
- /* calibration mark */
- fprintf(psfp, "%f %f moveto\n", xpage(0.0), ypage(y));
- fprintf(psfp, "-4 0 rlineto\n");
- fprintf(psfp, "stroke\n");
-
- /* number */
- fprintf(psfp, "HE%d setfont\n", NORMAL_FONT);
-
- switch (unit) {
- case MEGABYTE :
- fprintf(psfp, "(");
- CommaPrint(psfp, (intish) (num / 1e6 + 0.5));
- fprintf(psfp, "M)\n");
- break;
- case KILOBYTE :
- fprintf(psfp, "(");
- CommaPrint(psfp, (intish) (num / 1e3 + 0.5));
- fprintf(psfp, "k)\n");
- break;
- case BYTE:
- fprintf(psfp, "(");
- CommaPrint(psfp, (intish) (num + 0.5));
- fprintf(psfp, ")\n");
- break;
- }
-
- fprintf(psfp, "dup stringwidth\n");
- fprintf(psfp, "2 div\n");
- fprintf(psfp, "%f exch sub\n", ypage(y));
-
- fprintf(psfp, "exch\n");
- fprintf(psfp, "%f exch sub\n", graphx0 - borderspace);
-
- fprintf(psfp, "exch\n");
- fprintf(psfp, "moveto\n");
- fprintf(psfp, "show\n");
-}
-
-#define N_Y_MARKS 7
-#define YFUDGE 15
-
-extern floatish yrange;
-extern char *valueunitstring;
-
-static void
-YAxis()
-{
- floatish increment, i;
- floatish t, y;
- floatish legendlen;
- mkb unit;
-
- /* draw the y axis line */
- fprintf(psfp, "%f %f moveto\n", xpage(0.0), ypage(0.0));
- fprintf(psfp, "0 %f rlineto\n", graphheight);
- fprintf(psfp, "%f setlinewidth\n", borderthick);
- fprintf(psfp, "stroke\n");
-
- /* draw y axis legend */
- fprintf(psfp, "gsave\n");
- fprintf(psfp, "HE%d setfont\n", NORMAL_FONT);
- fprintf(psfp, "(%s)\n", valueunitstring);
- fprintf(psfp, "dup stringwidth pop\n");
- fprintf(psfp, "%f\n", ypage(0.0) + graphheight);
- fprintf(psfp, "exch sub\n");
- fprintf(psfp, "%f exch\n", xpage(0.0) - borderspace);
- fprintf(psfp, "translate\n");
- fprintf(psfp, "90 rotate\n");
- fprintf(psfp, "0 0 moveto\n");
- fprintf(psfp, "show\n");
- fprintf(psfp, "grestore\n");
-
- /* draw y axis scaling */
- increment = max( yrange / (floatish) N_Y_MARKS, 1.0);
- increment = Round(increment);
-
- if (increment >= 1e6) {
- unit = MEGABYTE;
- } else if (increment >= 1e3) {
- unit = KILOBYTE;
- } else {
- unit = BYTE;
- }
-
- t = graphheight / yrange;
- legendlen = StringSize(valueunitstring) + (floatish) YFUDGE;
-
- for (i = 0.0; i <= yrange; i += increment) {
- y = i * t;
-
- if (y < (graphheight - legendlen)) {
- YAxisMark(y, i, unit);
- }
- }
-}
-
-
-/*
- * Find a "nice round" value to use on the axis.
- */
-
-static floatish OneTwoFive PROTO((floatish)); /* forward */
-
-static floatish
-Round(y)
- floatish y;
-{
- int i;
-
- if (y > 10.0) {
- for (i = 0; y > 10.0; y /= 10.0, i++) ;
- y = OneTwoFive(y);
- for ( ; i > 0; y = y * 10.0, i--) ;
-
- } else if (y < 1.0) {
- for (i = 0; y < 1.0; y *= 10.0, i++) ;
- y = OneTwoFive(y);
- for ( ; i > 0; y = y / 10.0, i--) ;
-
- } else {
- y = OneTwoFive(y);
- }
-
- return (y);
-}
-
-
-/*
- * OneTwoFive() -- Runciman's 1,2,5 scaling rule. Argument 1.0 <= y <= 10.0.
- */
-
-static floatish
-OneTwoFive(y)
- floatish y;
-{
- if (y > 4.0) {
- return (5.0);
- } else if (y > 1.0) {
- return (2.0);
- } else {
- return (1.0);
- }
-}
diff --git a/ghc/utils/hp2ps/Axes.h b/ghc/utils/hp2ps/Axes.h
deleted file mode 100644
index e4be505dfb..0000000000
--- a/ghc/utils/hp2ps/Axes.h
+++ /dev/null
@@ -1,6 +0,0 @@
-#ifndef AXES_H
-#define AXES_H
-
-void Axes PROTO((void));
-
-#endif /* AXES_H */
diff --git a/ghc/utils/hp2ps/CHANGES b/ghc/utils/hp2ps/CHANGES
deleted file mode 100644
index db3b52e6d6..0000000000
--- a/ghc/utils/hp2ps/CHANGES
+++ /dev/null
@@ -1,37 +0,0 @@
-1.
-
-When generating PostScript to show strings, '(' and ')' may need to be escaped.
-These characters are now escaped when the JOB string is shown.
-
-2.
-
-Manually deleting samples from a .hp file now does what you would expect.
-
-3.
-
-The -t flag for setting the threshold percentage has been scrapped. No one
-ever used it.
-
-4.
-
-Long JOB strings cause hp2ps to use a big title box. Big and small boxes
-can be forced with -b and -s flag.
-
-5.
-
-MARKS now print as small triangles which remain below the x axis.
-
-6.
-
-There is an updated manual page.
-
-7.
-
--m flag for setting maximum no of bands (default 20, cant be more than 20).
--t flag for setting threshold (between 0% and 5%, default 1%).
-
-8.
-
-Axes scaling rounding errors removed.
-
-
diff --git a/ghc/utils/hp2ps/Curves.c b/ghc/utils/hp2ps/Curves.c
deleted file mode 100644
index ec05c98336..0000000000
--- a/ghc/utils/hp2ps/Curves.c
+++ /dev/null
@@ -1,165 +0,0 @@
-#include "Main.h"
-#include <stdio.h>
-#include <math.h>
-#include "Defines.h"
-#include "Dimensions.h"
-#include "HpFile.h"
-#include "Shade.h"
-#include "Utilities.h"
-
-/* own stuff */
-#include "Curves.h"
-
-static floatish *x; /* x and y values */
-static floatish *y;
-
-static floatish *py; /* previous y values */
-
-static void Curve PROTO((struct entry *)); /* forward */
-static void ShadeCurve
- PROTO((floatish *x, floatish *y, floatish *py, floatish shade));
-
-void
-Curves()
-{
- intish i;
-
- for (i = 0; i < nidents; i++) {
- Curve(identtable[i]);
- }
-}
-
-/*
- * Draw a curve, and fill the area that is below it and above
- * the previous curve.
- */
-
-static void
-Curve(e)
- struct entry* e;
-{
- struct chunk* ch;
- int j;
-
- for (ch = e->chk; ch; ch = ch->next) {
- for (j = 0; j < ch->nd; j++) {
- y[ ch->d[j].bucket ] += ch->d[j].value;
- }
- }
-
- ShadeCurve(x, y, py, ShadeOf(e->name));
-}
-
-
-static void PlotCurveLeftToRight PROTO((floatish *, floatish *)); /* forward */
-static void PlotCurveRightToLeft PROTO((floatish *, floatish *)); /* forward */
-
-static void SaveCurve PROTO((floatish *, floatish *)); /* forward */
-
-/*
- * Map virtual x coord to physical x coord
- */
-
-floatish
-xpage(x)
- floatish x;
-{
- return (x + graphx0);
-}
-
-
-
-/*
- * Map virtual y coord to physical y coord
- */
-
-floatish
-ypage(y)
- floatish y;
-{
- return (y + graphy0);
-}
-
-
-/*
- * Fill the region bounded by two splines, using the given
- * shade.
- */
-
-static void
-ShadeCurve(x, y, py, shade)
- floatish *x; floatish *y; floatish *py; floatish shade;
-{
- fprintf(psfp, "%f %f moveto\n", xpage(x[0]), ypage(py[0]));
- PlotCurveLeftToRight(x, py);
-
- fprintf(psfp, "%f %f lineto\n", xpage(x[nsamples - 1]),
- ypage(y[nsamples - 1]));
- PlotCurveRightToLeft(x, y);
-
- fprintf(psfp, "closepath\n");
-
- fprintf(psfp, "gsave\n");
-
- SetPSColour(shade);
- fprintf(psfp, "fill\n");
-
- fprintf(psfp, "grestore\n");
- fprintf(psfp, "stroke\n");
-
- SaveCurve(y, py);
-}
-
-static void
-PlotCurveLeftToRight(x,y)
- floatish *x; floatish *y;
-{
- intish i;
-
- for (i = 0; i < nsamples; i++) {
- fprintf(psfp, "%f %f lineto\n", xpage(x[i]), ypage(y[i]));
- }
-}
-
-static void
-PlotCurveRightToLeft(x,y)
- floatish *x; floatish *y;
-{
- intish i;
-
- for (i = nsamples - 1; i >= 0; i-- ) {
- fprintf(psfp, "%f %f lineto\n", xpage(x[i]), ypage(y[i]));
- }
-}
-
-/*
- * Save the curve coordinates stored in y[] in py[].
- */
-
-static void
-SaveCurve(y, py)
- floatish *y; floatish* py;
-{
- intish i;
-
- for (i = 0; i < nsamples; i++) {
- py[i] = y[i];
- }
-}
-
-extern floatish xrange;
-
-void
-CurvesInit()
-{
- intish i;
-
- x = (floatish*) xmalloc(nsamples * sizeof(floatish));
- y = (floatish*) xmalloc(nsamples * sizeof(floatish));
- py = (floatish*) xmalloc(nsamples * sizeof(floatish));
-
- for (i = 0; i < nsamples; i++) {
- x[i] = ((samplemap[i] - samplemap[0])/ xrange) * graphwidth;
- y[i] = py[i] = 0.0;
- }
-}
diff --git a/ghc/utils/hp2ps/Curves.h b/ghc/utils/hp2ps/Curves.h
deleted file mode 100644
index 0aa397f42c..0000000000
--- a/ghc/utils/hp2ps/Curves.h
+++ /dev/null
@@ -1,10 +0,0 @@
-#ifndef CURVES_H
-#define CURVES_H
-
-void Curves PROTO((void));
-void CurvesInit PROTO((void));
-
-floatish xpage PROTO((floatish));
-floatish ypage PROTO((floatish));
-
-#endif /* CURVES_H */
diff --git a/ghc/utils/hp2ps/Defines.h b/ghc/utils/hp2ps/Defines.h
deleted file mode 100644
index 8d38546fec..0000000000
--- a/ghc/utils/hp2ps/Defines.h
+++ /dev/null
@@ -1,61 +0,0 @@
-#ifndef DEFINES_H
-#define DEFINES_H
-
-/*
- * Things that can be altered.
- */
-
-#define THRESHOLD_PERCENT _thresh_ /* all values below 1% insignificant */
-#define DEFAULT_THRESHOLD 1.0
-extern floatish _thresh_;
-
-#define TWENTY _twenty_ /* show top 20 bands, grouping excess */
-#define DEFAULT_TWENTY 20 /* this is default and absolute maximum */
-extern int _twenty_;
-
-#define LARGE_FONT 12 /* Helvetica 12pt */
-#define NORMAL_FONT 10 /* Helvetica 10pt */
-
-#define BORDER_HEIGHT 432.0 /* page border box 432pt (6 inches high) */
-#define BORDER_WIDTH 648.0 /* page border box 648pt (9 inches wide) */
-#define BORDER_SPACE 5.0 /* page border space */
-#define BORDER_THICK 0.5 /* page border line thickness 0.5pt */
-
-
-#define TITLE_HEIGHT 20.0 /* title box is 20pt high */
-#define TITLE_TEXT_FONT LARGE_FONT /* title in large font */
-#define TITLE_TEXT_SPACE 6.0 /* space between title text and box */
-
-
-#define AXIS_THICK 0.5 /* axis thickness 0.5pt */
-#define AXIS_TEXT_SPACE 6 /* space between axis legends and axis */
-#define AXIS_TEXT_FONT NORMAL_FONT /* axis legends in normal font */
-#define AXIS_Y_TEXT_SPACE 35 /* space for y axis text */
-
-#define KEY_BOX_WIDTH 14 /* key boxes are 14pt high */
-
-#define SMALL_JOB_STRING_WIDTH 35 /* small title for 35 characters or less */
-#define BIG_JOB_STRING_WIDTH 80 /* big title for everything else */
-
-#define GRAPH_X0 (AXIS_Y_TEXT_SPACE + (2 * BORDER_SPACE))
-#define GRAPH_Y0 (AXIS_TEXT_FONT + (2 * BORDER_SPACE))
-
-
-/*
- * Things that should be left well alone.
- */
-
-
-
-#define START_X 72 /* start 72pt (1 inch) from left (portrait) */
-#define START_Y 108 /* start 108pt (1.5 inch) from bottom (portrait) */
-
-#define NUMBER_LENGTH 32
-
-#define N_CHUNK 24
-
-#define VERSION "0.25" /* as of 95/03/21 */
-
-#define max(x,y) ((x) > (y) ? (x) : (y)) /* not everyone has this */
-
-#endif /* DEFINES_H */
diff --git a/ghc/utils/hp2ps/Deviation.c b/ghc/utils/hp2ps/Deviation.c
deleted file mode 100644
index ecf7faba16..0000000000
--- a/ghc/utils/hp2ps/Deviation.c
+++ /dev/null
@@ -1,139 +0,0 @@
-#include "Main.h"
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-#include <math.h>
-#include "Defines.h"
-#include "Error.h"
-#include "HpFile.h"
-#include "Utilities.h"
-
-/* own stuff */
-#include "Deviation.h"
-
-/*
- * Reorder the identifiers in the identifier table so that the
- * ones whose data points exhibit the mininal standard deviation
- * come first.
- */
-
-void
-Deviation()
-{
- intish i;
- intish j;
- floatish dev;
- struct chunk* ch;
- int min;
- floatish t;
- struct entry* e;
- floatish *averages;
- floatish *deviations;
-
- averages = (floatish*) xmalloc(nidents * sizeof(floatish));
- deviations = (floatish*) xmalloc(nidents * sizeof(floatish));
-
- /* find averages */
-
- for (i = 0; i < nidents; i++) {
- averages[i] = 0.0;
- }
-
- for (i = 0; i < nidents; i++) {
- for (ch = identtable[i]->chk; ch; ch = ch->next) {
- for (j = 0; j < ch->nd; j++) {
- averages[i] += ch->d[j].value;
- }
- }
- }
-
- for (i = 0; i < nidents; i++) {
- averages[i] /= (floatish) nsamples;
- }
-
- /* calculate standard deviation */
-
- for (i = 0; i < nidents; i++) {
- deviations[i] = 0.0;
- }
-
- for (i = 0; i < nidents; i++) {
- for (ch = identtable[i]->chk; ch; ch = ch->next) {
- for (j = 0; j < ch->nd; j++) {
- dev = ch->d[j].value - averages[i];
- deviations[i] += dev * dev;
- }
- }
- }
-
- for (i = 0; i < nidents; i++) {
- deviations[i] = (floatish) sqrt ((doublish) (deviations[i] /
- (floatish) (nsamples - 1)));
- }
-
-
- /* sort on basis of standard deviation */
-
- for (i = 0; i < nidents-1; i++) {
- min = i;
- for (j = i+1; j < nidents; j++) {
- if (deviations[ j ] < deviations[min]) {
- min = j;
- }
- }
-
- t = deviations[min];
- deviations[min] = deviations[i];
- deviations[i] = t;
-
- e = identtable[min];
- identtable[min] = identtable[i];
- identtable[i] = e;
- }
-
- free(averages);
- free(deviations);
-}
-
-void
-Identorder(iflag)
- int iflag; /* a funny three-way flag ? WDP 95/03 */
-{
- int i;
- int j;
- int min;
- struct entry* e;
-
- /* sort on basis of ident string */
- if (iflag > 0) {
- /* greatest at top i.e. smallest at start */
-
- for (i = 0; i < nidents-1; i++) {
- min = i;
- for (j = i+1; j < nidents; j++) {
- if (strcmp(identtable[j]->name, identtable[min]->name) < 0) {
- min = j;
- }
- }
-
- e = identtable[min];
- identtable[min] = identtable[i];
- identtable[i] = e;
- }
- } else {
- /* smallest at top i.e. greatest at start */
-
- for (i = 0; i < nidents-1; i++) {
- min = i;
- for (j = i+1; j < nidents; j++) {
- if (strcmp(identtable[j]->name, identtable[min]->name) > 0) {
- min = j;
- }
- }
-
- e = identtable[min];
- identtable[min] = identtable[i];
- identtable[i] = e;
- }
- }
-}
diff --git a/ghc/utils/hp2ps/Deviation.h b/ghc/utils/hp2ps/Deviation.h
deleted file mode 100644
index 14e4df1ad0..0000000000
--- a/ghc/utils/hp2ps/Deviation.h
+++ /dev/null
@@ -1,7 +0,0 @@
-#ifndef DEVIATION_H
-#define DEVIATION_H
-
-void Deviation PROTO((void));
-void Identorder PROTO((int));
-
-#endif /* DEVIATION_H */
diff --git a/ghc/utils/hp2ps/Dimensions.c b/ghc/utils/hp2ps/Dimensions.c
deleted file mode 100644
index e732402dac..0000000000
--- a/ghc/utils/hp2ps/Dimensions.c
+++ /dev/null
@@ -1,203 +0,0 @@
-#include "Main.h"
-#include <ctype.h>
-#include <string.h>
-#include <stdio.h>
-#include "Defines.h"
-#include "HpFile.h"
-#include "Scale.h"
-
-/* own stuff */
-#include "Dimensions.h"
-
-/*
- * Get page and other dimensions before printing.
- */
-
-floatish borderheight = BORDER_HEIGHT;
-floatish borderwidth = BORDER_WIDTH;
-floatish borderspace = BORDER_SPACE;
-floatish borderthick = BORDER_THICK;
-
-floatish titlewidth = (BORDER_WIDTH - (2 * BORDER_SPACE));
-floatish titletextspace = TITLE_TEXT_SPACE;
-floatish titleheight;
-
-floatish graphx0 = GRAPH_X0;
-floatish graphy0 = GRAPH_Y0;
-
-floatish graphheight;
-floatish graphwidth;
-
-static floatish KeyWidth PROTO((void)); /* forward */
-
-void
-Dimensions()
-{
- xrange = samplemap[nsamples - 1] - samplemap[0];
- xrange = max(xrange, auxxrange);
- if (xrange == 0.0) xrange = 1.0; /* avoid division by 0.0 */
-
- yrange = MaxCombinedHeight();
- yrange = max(yrange, auxyrange);
- if (yrange == 0.0) yrange = 1.0; /* avoid division by 0.0 */
-
- if (!bflag && !sflag) {
- bflag = strlen(jobstring) > SMALL_JOB_STRING_WIDTH;
- }
-
- if (bflag) {
- titleheight = 2 * TITLE_HEIGHT;
- } else {
- titleheight = TITLE_HEIGHT;
- }
-
- graphwidth = titlewidth - graphx0 - (TWENTY ? KeyWidth() : 0);
- graphheight = borderheight - titleheight - (2 * borderspace) - graphy0;
-}
-
-/*
- * Calculate the width of the key.
- */
-
-static floatish
-KeyWidth()
-{
- intish i;
- floatish c;
-
- c = 0.0;
-
- for (i = 0; i < nidents; i++) {
- c = max(c, StringSize(identtable[i]->name));
- }
-
- c += 3.0 * borderspace;
-
- c += (floatish) KEY_BOX_WIDTH;
-
- return c;
-}
-
-
-/*
- * A desperately grim solution.
- */
-
-
-floatish fonttab[] = {
- /* 20 (' ') = */ 3.0,
- /* 21 ('!') = */ 1.0,
- /* 22 ('"') = */ 1.0,
- /* 23 ('#') = */ 3.0,
- /* 24 ('$') = */ 3.0,
- /* 25 ('%') = */ 3.0,
- /* 26 ('&') = */ 3.0,
- /* 27 (''') = */ 1.0,
- /* 28 ('(') = */ 3.0,
- /* 29 (')') = */ 3.0,
- /* 2a ('*') = */ 2.0,
- /* 2b ('+') = */ 3.0,
- /* 2c (',') = */ 1.0,
- /* 2d ('-') = */ 3.0,
- /* 2e ('.') = */ 1.0,
- /* 2f ('/') = */ 3.0,
- /* 30 ('0') = */ 4.0,
- /* 31 ('1') = */ 4.0,
- /* 32 ('2') = */ 4.0,
- /* 33 ('3') = */ 4.0,
- /* 34 ('4') = */ 4.0,
- /* 35 ('5') = */ 4.0,
- /* 36 ('6') = */ 4.0,
- /* 37 ('7') = */ 4.0,
- /* 38 ('8') = */ 4.0,
- /* 39 ('9') = */ 4.0,
- /* 3a (':') = */ 1.0,
- /* 3b (';') = */ 1.0,
- /* 3c ('<') = */ 3.0,
- /* 3d ('=') = */ 3.0,
- /* 3e ('>') = */ 3.0,
- /* 3f ('?') = */ 2.0,
- /* 40 ('@') = */ 3.0,
- /* 41 ('A') = */ 5.0,
- /* 42 ('B') = */ 5.0,
- /* 43 ('C') = */ 5.0,
- /* 44 ('D') = */ 5.0,
- /* 45 ('E') = */ 5.0,
- /* 46 ('F') = */ 5.0,
- /* 47 ('G') = */ 5.0,
- /* 48 ('H') = */ 5.0,
- /* 49 ('I') = */ 1.0,
- /* 4a ('J') = */ 5.0,
- /* 4b ('K') = */ 5.0,
- /* 4c ('L') = */ 5.0,
- /* 4d ('M') = */ 5.0,
- /* 4e ('N') = */ 5.0,
- /* 4f ('O') = */ 5.0,
- /* 50 ('P') = */ 5.0,
- /* 51 ('Q') = */ 5.0,
- /* 52 ('R') = */ 5.0,
- /* 53 ('S') = */ 5.0,
- /* 54 ('T') = */ 5.0,
- /* 55 ('U') = */ 5.0,
- /* 56 ('V') = */ 5.0,
- /* 57 ('W') = */ 5.0,
- /* 58 ('X') = */ 5.0,
- /* 59 ('Y') = */ 5.0,
- /* 5a ('Z') = */ 5.0,
- /* 5b ('[') = */ 2.0,
- /* 5c ('\') = */ 3.0,
- /* 5d (']') = */ 2.0,
- /* 5e ('^') = */ 1.0,
- /* 5f ('_') = */ 3.0,
- /* 60 ('`') = */ 1.0,
- /* 61 ('a') = */ 3.0,
- /* 62 ('b') = */ 3.0,
- /* 63 ('c') = */ 3.0,
- /* 64 ('d') = */ 3.0,
- /* 65 ('e') = */ 3.0,
- /* 66 ('f') = */ 3.0,
- /* 67 ('g') = */ 3.0,
- /* 68 ('h') = */ 3.0,
- /* 69 ('i') = */ 1.0,
- /* 6a ('j') = */ 2.0,
- /* 6b ('k') = */ 3.0,
- /* 6c ('l') = */ 1.0,
- /* 6d ('m') = */ 5.0,
- /* 6e ('n') = */ 3.0,
- /* 6f ('o') = */ 3.0,
- /* 70 ('p') = */ 3.0,
- /* 71 ('q') = */ 3.0,
- /* 72 ('r') = */ 2.0,
- /* 73 ('s') = */ 3.0,
- /* 74 ('t') = */ 2.0,
- /* 75 ('u') = */ 3.0,
- /* 76 ('v') = */ 3.0,
- /* 77 ('w') = */ 3.0,
- /* 78 ('x') = */ 3.0,
- /* 79 ('y') = */ 3.0,
- /* 7a ('z') = */ 3.0,
- /* 7b ('{') = */ 2.0,
- /* 7c ('|') = */ 1.0,
- /* 7d ('}') = */ 2.0,
- /* 7e ('~') = */ 2.0
-};
-
-
-/*
- * What size is a string (in points)?
- */
-
-#define FUDGE (2.834646 * 0.6)
-
-floatish
-StringSize(s)
- char* s;
-{
- floatish r;
-
- for (r = 0.0; *s; s++) {
- r += fonttab[(*s) - 0x20];
- }
-
- return r * FUDGE;
-}
diff --git a/ghc/utils/hp2ps/Dimensions.h b/ghc/utils/hp2ps/Dimensions.h
deleted file mode 100644
index 7bcc05beee..0000000000
--- a/ghc/utils/hp2ps/Dimensions.h
+++ /dev/null
@@ -1,22 +0,0 @@
-#ifndef DIMENSIONS_H
-#define DIMENSIONS_H
-
-extern floatish borderheight;
-extern floatish borderwidth;
-extern floatish borderspace;
-extern floatish borderthick;
-
-extern floatish titleheight;
-extern floatish titlewidth;
-extern floatish titletextspace;
-
-extern floatish graphx0;
-extern floatish graphy0;
-
-extern floatish graphheight;
-extern floatish graphwidth;
-
-void Dimensions PROTO((void));
-floatish StringSize PROTO((char *));
-
-#endif /* DIMENSIONS_H */
diff --git a/ghc/utils/hp2ps/Error.c b/ghc/utils/hp2ps/Error.c
deleted file mode 100644
index 809c24ea44..0000000000
--- a/ghc/utils/hp2ps/Error.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "Main.h"
-#include <stdarg.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include "Defines.h"
-
-/* own stuff */
-#include "Error.h"
-
-/*VARARGS0*/
-void
-Error(const char *fmt, ...)
-{
- va_list ap;
- fflush(stdout);
- fprintf(stderr, "%s: ", programname);
- va_start(ap, fmt);
- vfprintf(stderr, fmt, ap);
- va_end(ap);
- fprintf(stderr, "\n");
- exit(1);
-}
-
-/*VARARGS0*/
-void
-Disaster(const char *fmt, ...)
-{
- va_list ap;
- fflush(stdout);
- fprintf(stderr, "%s: ", programname);
- fprintf(stderr, " Disaster! (");
- va_start(ap, fmt);
- vfprintf(stderr, fmt, ap);
- va_end(ap);
- fprintf(stderr, ")\n");
- exit(1);
-}
-
-void
-Usage(str)
- const char *str;
-{
- if (str) printf("error: %s\n", str);
- printf("usage: %s -b -d -ef -g -i -p -mn -p -s -tf -y [file[.hp]]\n", programname);
- printf("where -b use large title box\n");
- printf(" -d sort by standard deviation\n");
- printf(" -ef[in|mm|pt] produce Encapsulated PostScript f units wide (f > 2 inches)\n");
- printf(" -g produce output suitable for GHOSTSCRIPT previever\n");
- printf(" -i[+|-] sort by identifier string (-i+ gives greatest on top) \n");
- printf(" -mn print maximum of n bands (default & max 20)\n");
- printf(" -m0 removes the band limit altogether\n");
- printf(" -p use previous scaling, shading and ordering\n");
- printf(" -s use small title box\n");
- printf(" -tf ignore trace bands which sum below f%% (default 1%%, max 5%%)\n");
- printf(" -y traditional\n");
- printf(" -c colour ouput\n");
- exit(0);
-}
-
diff --git a/ghc/utils/hp2ps/Error.h b/ghc/utils/hp2ps/Error.h
deleted file mode 100644
index c1cdede415..0000000000
--- a/ghc/utils/hp2ps/Error.h
+++ /dev/null
@@ -1,8 +0,0 @@
-#ifndef ERROR_H
-#define ERROR_H
-
-extern void Error PROTO((const char *, ...));
-extern void Disaster PROTO((const char *, ...));
-extern void Usage PROTO((const char *));
-
-#endif /* ERROR_H */
diff --git a/ghc/utils/hp2ps/HpFile.c b/ghc/utils/hp2ps/HpFile.c
deleted file mode 100644
index 9db94977df..0000000000
--- a/ghc/utils/hp2ps/HpFile.c
+++ /dev/null
@@ -1,587 +0,0 @@
-#include "Main.h"
-#include <ctype.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-#include "Defines.h"
-#include "Error.h"
-#include "HpFile.h"
-#include "Utilities.h"
-
-#ifndef atof
-double atof PROTO((const char *));
-#endif
-
-/* own stuff already included */
-
-#define N_MARKS 50 /* start size of the mark table */
-#define N_SAMPLES 500 /* start size of the sample table */
-
-char *theident;
-char *thestring;
-int theinteger;
-floatish thefloatish;
-int ch; /* last character read */
-token thetok; /* last token */
-int linenum; /* current line number */
-int endfile; /* true at end of file */
-
-static boolish gotjob = 0; /* "JOB" read */
-static boolish gotdate = 0; /* "DATE" read */
-static boolish gotvalueunit = 0; /* "VALUE_UNIT" read */
-static boolish gotsampleunit = 0; /* "SAMPLE_UNIT" read */
-static boolish insample = 0; /* true when in sample */
-
-static floatish lastsample; /* the last sample time */
-
-static void GetHpLine PROTO((FILE *)); /* forward */
-static void GetHpTok PROTO((FILE *)); /* forward */
-
-static struct entry *GetEntry PROTO((char *)); /* forward */
-
-static void MakeIdentTable PROTO((void)); /* forward */
-
-char *jobstring;
-char *datestring;
-
-char *sampleunitstring;
-char *valueunitstring;
-
-floatish *samplemap; /* sample intervals */
-floatish *markmap; /* sample marks */
-
-/*
- * An extremely simple parser. The input is organised into lines of
- * the form
- *
- * JOB s -- job identifier string
- * DATE s -- date string
- * SAMPLE_UNIT s -- sample unit eg "seconds"
- * VALUE_UNIT s -- value unit eg "bytes"
- * MARK i -- sample mark
- * BEGIN_SAMPLE i -- start of ith sample
- * identifier i -- there are i identifiers in this sample
- * END_SAMPLE i -- end of ith sample
- *
- */
-
-void
-GetHpFile(infp)
- FILE *infp;
-{
- nsamples = 0;
- nmarks = 0;
- nidents = 0;
-
- ch = ' ';
- endfile = 0;
- linenum = 1;
- lastsample = 0.0;
-
- GetHpTok(infp);
-
- while (endfile == 0) {
- GetHpLine(infp);
- }
-
- if (!gotjob) {
- Error("%s: JOB missing", hpfile);
- }
-
- if (!gotdate) {
- Error("%s: DATE missing", hpfile);
- }
-
- if (!gotvalueunit) {
- Error("%s: VALUE_UNIT missing", hpfile);
- }
-
- if (!gotsampleunit) {
- Error("%s: SAMPLE_UNIT missing", hpfile);
- }
-
- if (nsamples == 0) {
- Error("%s: contains no samples", hpfile);
- }
-
-
- MakeIdentTable();
-
- fclose(hpfp);
-}
-
-
-/*
- * Read the next line from the input, check the syntax, and perform
- * the appropriate action.
- */
-
-static void
-GetHpLine(infp)
- FILE* infp;
-{
- static intish nmarkmax = 0, nsamplemax = 0;
-
- switch (thetok) {
- case JOB_TOK:
- GetHpTok(infp);
- if (thetok != STRING_TOK) {
- Error("%s, line %d: string must follow JOB", hpfile, linenum);
- }
- jobstring = thestring;
- gotjob = 1;
- GetHpTok(infp);
- break;
-
- case DATE_TOK:
- GetHpTok(infp);
- if (thetok != STRING_TOK) {
- Error("%s, line %d: string must follow DATE", hpfile, linenum);
- }
- datestring = thestring;
- gotdate = 1;
- GetHpTok(infp);
- break;
-
- case SAMPLE_UNIT_TOK:
- GetHpTok(infp);
- if (thetok != STRING_TOK) {
- Error("%s, line %d: string must follow SAMPLE_UNIT", hpfile,
- linenum);
- }
- sampleunitstring = thestring;
- gotsampleunit = 1;
- GetHpTok(infp);
- break;
-
- case VALUE_UNIT_TOK:
- GetHpTok(infp);
- if (thetok != STRING_TOK) {
- Error("%s, line %d: string must follow VALUE_UNIT", hpfile,
- linenum);
- }
- valueunitstring = thestring;
- gotvalueunit = 1;
- GetHpTok(infp);
- break;
-
- case MARK_TOK:
- GetHpTok(infp);
- if (thetok != FLOAT_TOK) {
- Error("%s, line %d, floating point number must follow MARK",
- hpfile, linenum);
- }
- if (insample) {
- Error("%s, line %d, MARK occurs within sample", hpfile, linenum);
- }
- if (nmarks >= nmarkmax) {
- if (!markmap) {
- nmarkmax = N_MARKS;
- markmap = (floatish*) xmalloc(nmarkmax * sizeof(floatish));
- } else {
- nmarkmax *= 2;
- markmap = (floatish*) xrealloc(markmap, nmarkmax * sizeof(floatish));
- }
- }
- markmap[ nmarks++ ] = thefloatish;
- GetHpTok(infp);
- break;
-
- case BEGIN_SAMPLE_TOK:
- insample = 1;
- GetHpTok(infp);
- if (thetok != FLOAT_TOK) {
- Error("%s, line %d, floating point number must follow BEGIN_SAMPLE", hpfile, linenum);
- }
- if (thefloatish < lastsample) {
- Error("%s, line %d, samples out of sequence", hpfile, linenum);
- } else {
- lastsample = thefloatish;
- }
- if (nsamples >= nsamplemax) {
- if (!samplemap) {
- nsamplemax = N_SAMPLES;
- samplemap = (floatish*) xmalloc(nsamplemax * sizeof(floatish));
- } else {
- nsamplemax *= 2;
- samplemap = (floatish*) xrealloc(samplemap,
- nsamplemax * sizeof(floatish));
- }
- }
- samplemap[ nsamples ] = thefloatish;
- GetHpTok(infp);
- break;
-
- case END_SAMPLE_TOK:
- insample = 0;
- GetHpTok(infp);
- if (thetok != FLOAT_TOK) {
- Error("%s, line %d: floating point number must follow END_SAMPLE",
- hpfile, linenum);
- }
- nsamples++;
- GetHpTok(infp);
- break;
-
- case IDENTIFIER_TOK:
- GetHpTok(infp);
- if (thetok != INTEGER_TOK) {
- Error("%s, line %d: integer must follow identifier", hpfile,
- linenum);
- }
- StoreSample(GetEntry(theident), nsamples, (floatish) theinteger);
- GetHpTok(infp);
- break;
-
- case EOF_TOK:
- endfile = 1;
- break;
-
- default:
- Error("%s, line %d: %s unexpected", hpfile, linenum,
- TokenToString(thetok));
- break;
- }
-}
-
-
-char *
-TokenToString(t)
- token t;
-{
- switch (t) {
- case EOF_TOK: return "EOF";
- case INTEGER_TOK: return "integer";
- case FLOAT_TOK: return "floating point number";
- case IDENTIFIER_TOK: return "identifier";
- case STRING_TOK: return "string";
- case BEGIN_SAMPLE_TOK: return "BEGIN_SAMPLE";
- case END_SAMPLE_TOK: return "END_SAMPLE";
- case JOB_TOK: return "JOB";
- case DATE_TOK: return "DATE";
- case SAMPLE_UNIT_TOK: return "SAMPLE_UNIT";
- case VALUE_UNIT_TOK: return "VALUE_UNIT";
- case MARK_TOK: return "MARK";
-
- case X_RANGE_TOK: return "X_RANGE";
- case Y_RANGE_TOK: return "Y_RANGE";
- case ORDER_TOK: return "ORDER";
- case SHADE_TOK: return "SHADE";
- default: return "(strange token)";
- }
-}
-
-/*
- * Read the next token from the input and assign its value
- * to the global variable "thetok". In the case of numbers,
- * the corresponding value is also assigned to "theinteger"
- * or "thefloatish" as appropriate; in the case of identifiers
- * it is assigned to "theident".
- */
-
-static void
-GetHpTok(infp)
- FILE* infp;
-{
-
- while (isspace(ch)) { /* skip whitespace */
- if (ch == '\n') linenum++;
- ch = getc(infp);
- }
-
- if (ch == EOF) {
- thetok = EOF_TOK;
- return;
- }
-
- if (isdigit(ch)) {
- thetok = GetNumber(infp);
- return;
- } else if (ch == '\"') {
- GetString(infp);
- thetok = STRING_TOK;
- return;
- } else if (IsIdChar(ch)) {
- ASSERT(! (isdigit(ch))); /* ch can't be a digit here */
- GetIdent(infp);
- if (!isupper((int)theident[0])) {
- thetok = IDENTIFIER_TOK;
- } else if (strcmp(theident, "BEGIN_SAMPLE") == 0) {
- thetok = BEGIN_SAMPLE_TOK;
- } else if (strcmp(theident, "END_SAMPLE") == 0) {
- thetok = END_SAMPLE_TOK;
- } else if (strcmp(theident, "JOB") == 0) {
- thetok = JOB_TOK;
- } else if (strcmp(theident, "DATE") == 0) {
- thetok = DATE_TOK;
- } else if (strcmp(theident, "SAMPLE_UNIT") == 0) {
- thetok = SAMPLE_UNIT_TOK;
- } else if (strcmp(theident, "VALUE_UNIT") == 0) {
- thetok = VALUE_UNIT_TOK;
- } else if (strcmp(theident, "MARK") == 0) {
- thetok = MARK_TOK;
- } else {
- thetok = IDENTIFIER_TOK;
- }
- return;
- } else {
- Error("%s, line %d: strange character (%c)", hpfile, linenum, ch);
- }
-}
-
-
-/*
- * Read a sequence of digits and convert the result to an integer
- * or floating point value (assigned to the "theinteger" or
- * "thefloatish").
- */
-
-static char numberstring[ NUMBER_LENGTH - 1 ];
-
-token
-GetNumber(infp)
- FILE* infp;
-{
- int i;
- int containsdot;
-
- ASSERT(isdigit(ch)); /* we must have a digit to start with */
-
- containsdot = 0;
-
- for (i = 0; i < NUMBER_LENGTH && (isdigit(ch) || ch == '.'); i++) {
- numberstring[ i ] = ch;
- containsdot |= (ch == '.');
- ch = getc(infp);
- }
-
- ASSERT(i < NUMBER_LENGTH); /* did not overflow */
-
- numberstring[ i ] = '\0';
-
- if (containsdot) {
- thefloatish = (floatish) atof(numberstring);
- return FLOAT_TOK;
- } else {
- theinteger = atoi(numberstring);
- return INTEGER_TOK;
- }
-}
-
-/*
- * Read a sequence of identifier characters and assign the result
- * to the string "theident".
- */
-
-void
-GetIdent(infp)
- FILE *infp;
-{
- unsigned int i;
- char idbuffer[5000];
-
- for (i = 0; i < (sizeof idbuffer)-1 && IsIdChar(ch); i++) {
- idbuffer[ i ] = ch;
- ch = getc(infp);
- }
-
- idbuffer[ i ] = '\0';
-
- if (theident)
- free(theident);
-
- theident = copystring(idbuffer);
-}
-
-
-/*
- * Read a sequence of characters that make up a string and
- * assign the result to "thestring".
- */
-
-void
-GetString(infp)
- FILE *infp;
-{
- unsigned int i;
- char stringbuffer[5000];
-
- ASSERT(ch == '\"');
-
- ch = getc(infp); /* skip the '\"' that begins the string */
-
- for (i = 0; i < (sizeof stringbuffer)-1 && ch != '\"'; i++) {
- stringbuffer[ i ] = ch;
- ch = getc(infp);
- }
-
- stringbuffer[i] = '\0';
- thestring = copystring(stringbuffer);
-
- ASSERT(ch == '\"');
-
- ch = getc(infp); /* skip the '\"' that terminates the string */
-}
-
-boolish
-IsIdChar(ch)
- int ch;
-{
- return (!isspace(ch));
-}
-
-
-/*
- * The information associated with each identifier is stored
- * in a linked list of chunks. The table below allows the list
- * of chunks to be retrieved given an identifier name.
- */
-
-#define N_HASH 513
-
-static struct entry* hashtable[ N_HASH ];
-
-static intish
-Hash(s)
- char *s;
-{
- int r;
-
- for (r = 0; *s; s++) {
- r = r + r + r + *s;
- }
-
- if (r < 0) r = -r;
-
- return r % N_HASH;
-}
-
-/*
- * Get space for a new chunk. Initialise it, and return a pointer
- * to the new chunk.
- */
-
-static struct chunk*
-MakeChunk()
-{
- struct chunk* ch;
- struct datapoint* d;
-
- ch = (struct chunk*) xmalloc( sizeof(struct chunk) );
-
- d = (struct datapoint*) xmalloc (sizeof(struct datapoint) * N_CHUNK);
-
- ch->nd = 0;
- ch->d = d;
- ch->next = 0;
- return ch;
-}
-
-
-/*
- * Get space for a new entry. Initialise it, and return a pointer
- * to the new entry.
- */
-
-struct entry *
-MakeEntry(name)
- char *name;
-{
- struct entry* e;
-
- e = (struct entry *) xmalloc(sizeof(struct entry));
- e->chk = MakeChunk();
- e->name = copystring(name);
- return e;
-}
-
-/*
- * Get the entry associated with "name", creating a new entry if
- * necessary.
- */
-
-static struct entry *
-GetEntry(name)
- char* name;
-{
- intish h;
- struct entry* e;
-
- h = Hash(name);
-
- for (e = hashtable[ h ]; e; e = e->next) {
- if (strcmp(e->name, name) == 0) {
- break;
- }
- }
-
- if (e) {
- return (e);
- } else {
- nidents++;
- e = MakeEntry(name);
- e->next = hashtable[ h ];
- hashtable[ h ] = e;
- return (e);
- }
-}
-
-
-/*
- * Store information from a sample.
- */
-
-void
-StoreSample(en, bucket, value)
- struct entry* en; intish bucket; floatish value;
-{
- struct chunk* chk;
-
- for (chk = en->chk; chk->next != 0; chk = chk->next)
- ;
-
- if (chk->nd < N_CHUNK) {
- chk->d[ chk->nd ].bucket = bucket;
- chk->d[ chk->nd ].value = value;
- chk->nd += 1;
- } else {
- struct chunk* t;
- t = chk->next = MakeChunk();
- t->d[ 0 ].bucket = bucket;
- t->d[ 0 ].value = value;
- t->nd += 1;
- }
-}
-
-
-struct entry** identtable;
-
-/*
- * The hash table is useful while reading the input, but it
- * becomes a liability thereafter. The code below converts
- * it to a more easily processed table.
- */
-
-static void
-MakeIdentTable()
-{
- intish i;
- intish j;
- struct entry* e;
-
- nidents = 0;
- for (i = 0; i < N_HASH; i++) {
- for (e = hashtable[ i ]; e; e = e->next) {
- nidents++;
- }
- }
-
- identtable = (struct entry**) xmalloc(nidents * sizeof(struct entry*));
- j = 0;
-
- for (i = 0; i < N_HASH; i++) {
- for (e = hashtable[ i ]; e; e = e->next, j++) {
- identtable[ j ] = e;
- }
- }
-}
diff --git a/ghc/utils/hp2ps/HpFile.h b/ghc/utils/hp2ps/HpFile.h
deleted file mode 100644
index 1c43f73d6d..0000000000
--- a/ghc/utils/hp2ps/HpFile.h
+++ /dev/null
@@ -1,77 +0,0 @@
-#ifndef HP_FILE_H
-#define HP_FILE_H
-
-typedef enum {
- /* These tokens are found in ".hp" files */
-
- EOF_TOK,
- INTEGER_TOK,
- FLOAT_TOK,
- IDENTIFIER_TOK,
- STRING_TOK,
- BEGIN_SAMPLE_TOK,
- END_SAMPLE_TOK,
- JOB_TOK,
- DATE_TOK,
- SAMPLE_UNIT_TOK,
- VALUE_UNIT_TOK,
- MARK_TOK,
-
- /* These extra ones are found only in ".aux" files */
-
- X_RANGE_TOK,
- Y_RANGE_TOK,
- ORDER_TOK,
- SHADE_TOK
-} token;
-
-struct datapoint {
- int bucket;
- floatish value;
-};
-
-struct chunk {
- struct chunk *next;
- short nd; /* 0 .. N_CHUNK - 1 */
- struct datapoint *d;
-};
-
-
-struct entry {
- struct entry *next;
- struct chunk *chk;
- char *name;
-};
-
-extern char *theident;
-extern char *thestring;
-extern int theinteger;
-extern floatish thefloatish;
-extern int ch;
-extern token thetok;
-extern int linenum;
-extern int endfile;
-
-char *TokenToString PROTO((token));
-
-extern struct entry** identtable;
-
-extern floatish *samplemap;
-extern floatish *markmap;
-
-void GetHpFile PROTO((FILE *));
-void StoreSample PROTO((struct entry *, intish, floatish));
-struct entry *MakeEntry PROTO((char *));
-
-token GetNumber PROTO((FILE *));
-void GetIdent PROTO((FILE *));
-void GetString PROTO((FILE *));
-boolish IsIdChar PROTO((int)); /* int is a "char" from getc */
-
-extern char *jobstring;
-extern char *datestring;
-
-extern char *sampleunitstring;
-extern char *valueunitstring;
-
-#endif /* HP_FILE_H */
diff --git a/ghc/utils/hp2ps/Key.c b/ghc/utils/hp2ps/Key.c
deleted file mode 100644
index 8c63721c74..0000000000
--- a/ghc/utils/hp2ps/Key.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "Main.h"
-#include <stdio.h>
-#include <math.h>
-#include "Defines.h"
-#include "Dimensions.h"
-#include "HpFile.h"
-#include "Shade.h"
-
-/* own stuff */
-#include "Key.h"
-
-static void KeyEntry PROTO((floatish, char *, floatish));
-
-void Key()
-{
- intish i;
- floatish c;
- floatish dc;
-
- for (i = 0; i < nidents; i++) /* count identifiers */
- ;
-
- c = graphy0;
- dc = graphheight / (floatish) (i + 1);
-
- for (i = 0; i < nidents; i++) {
- c += dc;
- KeyEntry(c, identtable[i]->name, ShadeOf(identtable[i]->name));
- }
-}
-
-
-
-static void
-KeyEntry(centreline, name, colour)
- floatish centreline; char* name; floatish colour;
-{
- floatish namebase;
- floatish keyboxbase;
- floatish kstart;
-
- namebase = centreline - (floatish) (NORMAL_FONT / 2);
- keyboxbase = centreline - ((floatish) KEY_BOX_WIDTH / 2.0);
-
- kstart = graphx0 + graphwidth;
-
- fprintf(psfp, "%f %f moveto\n", kstart + borderspace, keyboxbase);
- fprintf(psfp, "0 %d rlineto\n", KEY_BOX_WIDTH);
- fprintf(psfp, "%d 0 rlineto\n", KEY_BOX_WIDTH);
- fprintf(psfp, "0 %d rlineto\n", -KEY_BOX_WIDTH);
- fprintf(psfp, "closepath\n");
-
- fprintf(psfp, "gsave\n");
- SetPSColour(colour);
- fprintf(psfp, "fill\n");
- fprintf(psfp, "grestore\n");
- fprintf(psfp, "stroke\n");
-
- fprintf(psfp, "HE%d setfont\n", NORMAL_FONT);
- fprintf(psfp, "%f %f moveto\n", kstart + (floatish) KEY_BOX_WIDTH + 2 * borderspace, namebase);
-
- fprintf(psfp, "(%s) show\n", name);
-}
diff --git a/ghc/utils/hp2ps/Key.h b/ghc/utils/hp2ps/Key.h
deleted file mode 100644
index d2a7b8eae3..0000000000
--- a/ghc/utils/hp2ps/Key.h
+++ /dev/null
@@ -1,6 +0,0 @@
-#ifndef KEY_H
-#define KEY_H
-
-void Key PROTO((void));
-
-#endif /* KEY_H */
diff --git a/ghc/utils/hp2ps/Main.c b/ghc/utils/hp2ps/Main.c
deleted file mode 100644
index 3b5efed51b..0000000000
--- a/ghc/utils/hp2ps/Main.c
+++ /dev/null
@@ -1,253 +0,0 @@
-#include "Main.h"
-#include <stdio.h>
-#include <string.h>
-#include <stdlib.h>
-#include "Defines.h"
-#include "AuxFile.h"
-#include "AreaBelow.h"
-#include "Dimensions.h"
-#include "HpFile.h"
-#include "PsFile.h"
-#include "Reorder.h"
-#include "Scale.h"
-#include "TopTwenty.h"
-#include "TraceElement.h"
-#include "Deviation.h"
-#include "Error.h"
-#include "Utilities.h"
-
-boolish pflag = 0; /* read auxiliary file */
-boolish eflag = 0; /* scaled EPSF */
-boolish dflag = 0; /* sort by standard deviation */
-int iflag = 0; /* sort by identifier (3-way flag) */
-boolish gflag = 0; /* output suitable for previewer */
-boolish yflag = 0; /* ignore marks */
-boolish bflag = 0; /* use a big title box */
-boolish sflag = 0; /* use a small title box */
-int mflag = 0; /* max no. of bands displayed (default 20) */
-boolish tflag = 0; /* ignored threshold specified */
-boolish cflag = 0; /* colour output */
-
-boolish filter; /* true when running as a filter */
-
-static floatish WidthInPoints PROTO((char *)); /* forward */
-static FILE *Fp PROTO((char *, char **, char *, char *)); /* forward */
-
-char *hpfile;
-char *psfile;
-char *auxfile;
-
-char *programname;
-
-static char *pathName;
-static char *baseName; /* "basename" is a std C library name (sigh) */
-
-FILE* hpfp;
-FILE* psfp;
-FILE* auxfp;
-
-floatish xrange = 0.0;
-floatish yrange = 0.0;
-
-floatish auxxrange = 0.0;
-floatish auxyrange = 0.0;
-
-floatish epsfwidth;
-floatish areabelow;
-
-intish nsamples;
-intish nmarks;
-intish nidents;
-
-floatish THRESHOLD_PERCENT = DEFAULT_THRESHOLD;
-int TWENTY = DEFAULT_TWENTY;
-
-int main(argc, argv)
-int argc;
-char* argv[];
-{
-
- programname = copystring(Basename(argv[0]));
-
- argc--, argv++;
- while (argc && argv[0][0] == '-') {
- while (*++*argv)
- switch(**argv) {
- case 'p':
- pflag++;
- break;
- case 'e':
- eflag++;
- epsfwidth = WidthInPoints(*argv + 1);
- goto nextarg;
- case 'd':
- dflag++;
- goto nextarg;
- case 'i':
- switch( *(*argv + 1) ) {
- case '-':
- iflag = -1;
- case '+':
- default:
- iflag = 1;
- }
- goto nextarg;
- case 'g':
- gflag++;
- goto nextarg;
- case 'y':
- yflag++;
- goto nextarg;
- case 'b':
- bflag++;
- goto nextarg;
- case 's':
- sflag++;
- goto nextarg;
- case 'm':
- mflag++;
- TWENTY = atoi(*argv + 1);
- if (TWENTY > DEFAULT_TWENTY)
- Usage(*argv-1);
- goto nextarg;
- case 't':
- tflag++;
- THRESHOLD_PERCENT = (floatish) atof(*argv + 1);
- if (THRESHOLD_PERCENT < 0 || THRESHOLD_PERCENT > 5)
- Usage(*argv-1);
- goto nextarg;
- case 'c':
- cflag++;
- goto nextarg;
- case '?':
- default:
- Usage(*argv-1);
- }
-nextarg: ;
- argc--, argv++;
- }
-
- hpfile = "stdin";
- psfile = "stdout";
-
- hpfp = stdin;
- psfp = stdout;
-
- filter = argc < 1;
-
-
-
- if (!filter) {
- pathName = copystring(argv[0]);
- DropSuffix(pathName, ".hp");
- baseName = copystring(Basename(pathName));
-
- hpfp = Fp(pathName, &hpfile, ".hp", "r");
- psfp = Fp(baseName, &psfile, ".ps", "w");
-
- if (pflag) auxfp = Fp(baseName, &auxfile, ".aux", "r");
- }
-
- GetHpFile(hpfp);
-
- if (!filter && pflag) GetAuxFile(auxfp);
-
-
- TraceElement(); /* Orders on total, Removes trace elements (tflag) */
-
- if (dflag) Deviation(); /* ReOrders on deviation */
-
- if (iflag) Identorder(iflag); /* ReOrders on identifier */
-
- if (pflag) Reorder(); /* ReOrders on aux file */
-
- if (TWENTY) TopTwenty(); /* Selects top twenty (mflag) */
-
- Dimensions();
-
- areabelow = AreaBelow();
-
- Scale();
-
- PutPsFile();
-
- if (!filter) {
- auxfp = Fp(baseName, &auxfile, ".aux", "w");
- PutAuxFile(auxfp);
- }
-
- return(0);
-}
-
-
-
-typedef enum {POINTS, INCHES, MILLIMETRES} pim;
-
-static pim Units PROTO((char *)); /* forward */
-
-static floatish
-WidthInPoints(wstr)
- char *wstr;
-{
- floatish result;
-
- result = (floatish) atof(wstr);
-
- switch (Units(wstr)) {
- case INCHES:
- result *= 72.0;
- break;
- case MILLIMETRES:
- result *= 2.834646;
- break;
- case POINTS:
- default: ;
- }
-
- if (result <= 144) /* Minimum of 2in wide ! */
- Usage(wstr);
-
- return result;
-}
-
-
-static pim
-Units(wstr)
- char* wstr;
-{
-int i;
-
- i = strlen(wstr) - 2;
-
- if (wstr[i] == 'p' && wstr[i+1] == 't') {
- return POINTS;
- } else if (wstr[i] == 'i' && wstr[i+1] == 'n') {
- return INCHES;
- } else if (wstr[i] == 'm' && wstr[i+1] == 'm') {
- return MILLIMETRES;
- } else {
- return POINTS;
- }
-}
-
-static FILE *
-Fp(rootname, filename, suffix, mode)
- char* rootname; char** filename; char* suffix; char* mode;
-{
- *filename = copystring2(rootname, suffix);
-
- return(OpenFile(*filename, mode));
-}
-
-#ifdef DEBUG
-void
-_stgAssert (filename, linenum)
- char *filename;
- unsigned int linenum;
-{
- fflush(stdout);
- fprintf(stderr, "ASSERTION FAILED: file %s, line %u\n", filename, linenum);
- fflush(stderr);
- abort();
-}
-#endif
diff --git a/ghc/utils/hp2ps/Main.h b/ghc/utils/hp2ps/Main.h
deleted file mode 100644
index 30e7a7e9be..0000000000
--- a/ghc/utils/hp2ps/Main.h
+++ /dev/null
@@ -1,77 +0,0 @@
-#ifndef MAIN_H
-#define MAIN_H
-
-#include "../includes/ghcconfig.h"
-#include <stdio.h>
-
-#ifdef __STDC__
-#define PROTO(x) x
-#else
-#define PROTO(x) ()
-#endif
-
-/* our own ASSERT macro (for C) */
-#ifndef DEBUG
-#define ASSERT(predicate) /*nothing*/
-
-#else
-void _ghcAssert PROTO((char *, unsigned int));
-
-#define ASSERT(predicate) \
- if (predicate) \
- /*null*/; \
- else \
- _ghcAssert(__FILE__, __LINE__)
-#endif
-
-/* partain: some ubiquitous types: floatish & intish.
- Dubious to use float/int, but that is what it used to be...
- (WDP 95/03)
-*/
-typedef double floatish;
-typedef double doublish; /* higher precision, if anything; little used */
-typedef int boolish;
-
-/* Use "long long" if we have it: the numbers in profiles can easily
- * overflow 32 bits after a few seconds execution.
- */
-#ifdef HAVE_LONG_LONG
-typedef long long int intish;
-#else
-typedef long int intish;
-#endif
-
-extern intish nsamples;
-extern intish nmarks;
-extern intish nidents;
-
-extern floatish maxcombinedheight;
-extern floatish areabelow;
-extern floatish epsfwidth;
-
-extern floatish xrange;
-extern floatish yrange;
-
-extern floatish auxxrange;
-extern floatish auxyrange;
-
-extern boolish eflag;
-extern boolish gflag;
-extern boolish yflag;
-extern boolish bflag;
-extern boolish sflag;
-extern int mflag;
-extern boolish tflag;
-extern boolish cflag;
-
-extern char *programname;
-
-extern char *hpfile;
-extern char *psfile;
-extern char *auxfile;
-
-extern FILE *hpfp;
-extern FILE *psfp;
-extern FILE *auxfp;
-
-#endif /* MAIN_H */
diff --git a/ghc/utils/hp2ps/Makefile b/ghc/utils/hp2ps/Makefile
deleted file mode 100644
index 18cb05b1bd..0000000000
--- a/ghc/utils/hp2ps/Makefile
+++ /dev/null
@@ -1,14 +0,0 @@
-TOP=../..
-include $(TOP)/mk/boilerplate.mk
-
-C_PROG = hp2ps
-
-SRC_CC_OPTS += -I$(GHC_INCLUDE_DIR) -Wall
-
-INSTALL_PROGS += $(C_PROG)
-
-LIBS = $(LIBM)
-
-CLEAN_FILES += $(C_OBJS) $(C_PROG)
-
-include $(TOP)/mk/target.mk
diff --git a/ghc/utils/hp2ps/Marks.c b/ghc/utils/hp2ps/Marks.c
deleted file mode 100644
index 8d6f924e17..0000000000
--- a/ghc/utils/hp2ps/Marks.c
+++ /dev/null
@@ -1,43 +0,0 @@
-#include "Main.h"
-#include <stdio.h>
-#include "Curves.h"
-#include "Dimensions.h"
-#include "HpFile.h"
-
-/* own stuff */
-#include "Marks.h"
-
-static void Caret PROTO((floatish, floatish, floatish));
-
-void
-Marks()
-{
- intish i;
- floatish m;
-
- for (i = 0; i < nmarks; i++) {
- m = ((markmap[i] - samplemap[0]) / xrange) * graphwidth;
- Caret(xpage(m), ypage(0.0), 4.0);
- }
-}
-
-
-/*
- * Draw a small white caret at (x,y) with width 2 * d
- */
-
-static void
-Caret(x,y,d)
- floatish x; floatish y; floatish d;
-{
- fprintf(psfp, "%f %f moveto\n", x - d, y);
- fprintf(psfp, "%f %f rlineto\n", d, -d);
- fprintf(psfp, "%f %f rlineto\n", d, d);
- fprintf(psfp, "closepath\n");
-
- fprintf(psfp, "gsave\n");
- fprintf(psfp, "1.0 setgray\n");
- fprintf(psfp, "fill\n");
- fprintf(psfp, "grestore\n");
- fprintf(psfp, "stroke\n");
-}
diff --git a/ghc/utils/hp2ps/Marks.h b/ghc/utils/hp2ps/Marks.h
deleted file mode 100644
index 41956f6e83..0000000000
--- a/ghc/utils/hp2ps/Marks.h
+++ /dev/null
@@ -1,6 +0,0 @@
-#ifndef MARKS_H
-#define MARKS_H
-
-void Marks PROTO((void));
-
-#endif /* MARKS_H */
diff --git a/ghc/utils/hp2ps/PsFile.c b/ghc/utils/hp2ps/PsFile.c
deleted file mode 100644
index 357f826259..0000000000
--- a/ghc/utils/hp2ps/PsFile.c
+++ /dev/null
@@ -1,280 +0,0 @@
-#include "Main.h"
-#include <stdio.h>
-#include <string.h>
-#include "Defines.h"
-#include "Dimensions.h"
-#include "Curves.h"
-#include "HpFile.h"
-#include "Axes.h"
-#include "Key.h"
-#include "Marks.h"
-#include "Utilities.h"
-
-/* own stuff */
-#include "PsFile.h"
-
-static void Prologue PROTO((void)); /* forward */
-static void Variables PROTO((void)); /* forward */
-static void BorderOutlineBox PROTO((void)); /* forward */
-static void BigTitleOutlineBox PROTO((void)); /* forward */
-static void TitleOutlineBox PROTO((void)); /* forward */
-static void BigTitleText PROTO((void)); /* forward */
-static void TitleText PROTO((void)); /* forward */
-
-void
-PutPsFile()
-{
- Prologue();
- Variables();
- BorderOutlineBox();
-
- if (bflag) {
- BigTitleOutlineBox();
- BigTitleText();
- } else {
- TitleOutlineBox();
- TitleText();
- }
-
- CurvesInit();
-
- Axes();
-
- if (TWENTY) Key();
-
- Curves();
-
- if (!yflag) Marks();
-
- fprintf(psfp, "showpage\n");
-}
-
-
-static void StandardSpecialComments PROTO((void)); /* forward */
-static void EPSFSpecialComments PROTO((floatish)); /* forward */
-static void Landscape PROTO((void)); /* forward */
-static void Portrait PROTO((void)); /* forward */
-static void Scaling PROTO((floatish)); /* forward */
-
-static void
-Prologue()
-{
- if (eflag) {
- floatish epsfscale = epsfwidth / (floatish) borderwidth;
- EPSFSpecialComments(epsfscale);
- Scaling(epsfscale);
- } else {
- StandardSpecialComments();
- if (gflag) Portrait(); else Landscape();
- }
-}
-
-extern char *jobstring;
-extern char *datestring;
-
-static void
-StandardSpecialComments()
-{
- fprintf(psfp, "%%!PS-Adobe-2.0\n");
- fprintf(psfp, "%%%%Title: %s\n", jobstring);
- fprintf(psfp, "%%%%Creator: %s (version %s)\n", programname, VERSION);
- fprintf(psfp, "%%%%CreationDate: %s\n", datestring);
- fprintf(psfp, "%%%%EndComments\n");
-}
-
-static void
-EPSFSpecialComments(epsfscale)
- floatish epsfscale;
-{
- fprintf(psfp, "%%!PS-Adobe-2.0\n");
- fprintf(psfp, "%%%%Title: %s\n", jobstring);
- fprintf(psfp, "%%%%Creator: %s (version %s)\n", programname, VERSION);
- fprintf(psfp, "%%%%CreationDate: %s\n", datestring);
- fprintf(psfp, "%%%%BoundingBox: 0 0 %d %d\n",
- (int) (borderwidth * epsfscale + 0.5),
- (int) (borderheight * epsfscale + 0.5) );
- fprintf(psfp, "%%%%EndComments\n");
-}
-
-
-
-static void
-Landscape()
-{
- fprintf(psfp, "-90 rotate\n");
- fprintf(psfp, "%f %f translate\n", -(borderwidth + (floatish) START_Y),
- (floatish) START_X);
-}
-
-static void
-Portrait()
-{
- fprintf(psfp, "%f %f translate\n", (floatish) START_X, (floatish) START_Y);
-}
-
-static void
-Scaling(epsfscale)
- floatish epsfscale;
-{
- fprintf(psfp, "%f %f scale\n", epsfscale, epsfscale);
-}
-
-
-static void
-Variables()
-{
- fprintf(psfp, "/HE%d /Helvetica findfont %d scalefont def\n",
- NORMAL_FONT, NORMAL_FONT);
-
- fprintf(psfp, "/HE%d /Helvetica findfont %d scalefont def\n",
- LARGE_FONT, LARGE_FONT);
-}
-
-
-static void
-BorderOutlineBox()
-{
- fprintf(psfp, "newpath\n");
- fprintf(psfp, "0 0 moveto\n");
- fprintf(psfp, "0 %f rlineto\n", borderheight);
- fprintf(psfp, "%f 0 rlineto\n", borderwidth);
- fprintf(psfp, "0 %f rlineto\n", -borderheight);
- fprintf(psfp, "closepath\n");
- fprintf(psfp, "%f setlinewidth\n", borderthick);
- fprintf(psfp, "stroke\n");
-}
-
-static void
-BigTitleOutlineBox()
-{
- fprintf(psfp, "newpath\n");
- fprintf(psfp, "%f %f moveto\n", borderspace,
- borderheight - titleheight - borderspace);
- fprintf(psfp, "0 %f rlineto\n", titleheight);
- fprintf(psfp, "%f 0 rlineto\n", titlewidth);
- fprintf(psfp, "0 %f rlineto\n", -titleheight);
- fprintf(psfp, "closepath\n");
- fprintf(psfp, "%f setlinewidth\n", borderthick);
- fprintf(psfp, "stroke\n");
-
- fprintf(psfp, "%f %f moveto\n", borderspace,
- borderheight - titleheight / 2 - borderspace);
- fprintf(psfp, "%f 0 rlineto\n", titlewidth);
- fprintf(psfp, "stroke\n");
-}
-
-
-static void
-TitleOutlineBox()
-{
- fprintf(psfp, "newpath\n");
- fprintf(psfp, "%f %f moveto\n", borderspace,
- borderheight - titleheight - borderspace);
- fprintf(psfp, "0 %f rlineto\n", titleheight);
- fprintf(psfp, "%f 0 rlineto\n", titlewidth);
- fprintf(psfp, "0 %f rlineto\n", -titleheight);
- fprintf(psfp, "closepath\n");
- fprintf(psfp, "%f setlinewidth\n", borderthick);
- fprintf(psfp, "stroke\n");
-}
-
-static void EscapePrint PROTO((char *, int)); /* forward */
-
-static void
-BigTitleText()
-{
- floatish x, y;
-
- x = borderspace + titletextspace;
- y = borderheight - titleheight / 2 - borderspace + titletextspace;
-
- /* job identifier goes on top at the far left */
-
- fprintf(psfp, "HE%d setfont\n", TITLE_TEXT_FONT);
- fprintf(psfp, "%f %f moveto\n", x, y);
- fputc('(', psfp);
- EscapePrint(jobstring, BIG_JOB_STRING_WIDTH);
- fprintf(psfp, ") show\n");
-
- y = borderheight - titleheight - borderspace + titletextspace;
-
- /* area below curve gows at the botton, far left */
-
- fprintf(psfp, "HE%d setfont\n", TITLE_TEXT_FONT);
- fprintf(psfp, "%f %f moveto\n", x, y);
- fputc('(', psfp);
- CommaPrint(psfp, (intish)areabelow);
- fprintf(psfp, " %s x %s)\n", valueunitstring, sampleunitstring);
- fprintf(psfp, "show\n");
-
- /* date goes at far right */
-
- fprintf(psfp, "HE%d setfont\n", TITLE_TEXT_FONT);
- fprintf(psfp, "(%s)\n", datestring);
- fprintf(psfp, "dup stringwidth pop\n");
- fprintf(psfp, "%f\n", (titlewidth + borderspace) - titletextspace);
- fprintf(psfp, "exch sub\n");
- fprintf(psfp, "%f moveto\n", y);
- fprintf(psfp, "show\n");
-}
-
-
-static void
-TitleText()
-{
- floatish x, y;
-
- x = borderspace + titletextspace;
- y = borderheight - titleheight - borderspace + titletextspace;
-
- /* job identifier goes at far left */
-
- fprintf(psfp, "HE%d setfont\n", TITLE_TEXT_FONT);
- fprintf(psfp, "%f %f moveto\n", x, y);
- fputc('(', psfp);
- EscapePrint(jobstring, SMALL_JOB_STRING_WIDTH);
- fprintf(psfp, ") show\n");
-
- /* area below curve is centered */
-
- fprintf(psfp, "HE%d setfont\n", TITLE_TEXT_FONT);
- fputc('(', psfp);
- CommaPrint(psfp, (intish) areabelow);
- fprintf(psfp, " %s x %s)\n", valueunitstring, sampleunitstring);
-
- fprintf(psfp, "dup stringwidth pop\n");
- fprintf(psfp, "2 div\n");
- fprintf(psfp, "%f\n", titlewidth / 2);
- fprintf(psfp, "exch sub\n");
- fprintf(psfp, "%f moveto\n", y);
- fprintf(psfp, "show\n");
-
- /* date goes at far right */
-
- fprintf(psfp, "HE%d setfont\n", TITLE_TEXT_FONT);
- fprintf(psfp, "(%s)\n", datestring);
- fprintf(psfp, "dup stringwidth pop\n");
- fprintf(psfp, "%f\n", (titlewidth + borderspace) - titletextspace);
- fprintf(psfp, "exch sub\n");
- fprintf(psfp, "%f moveto\n", y);
- fprintf(psfp, "show\n");
-}
-
-/*
- * Print a string s in width w, escaping characters where necessary.
- */
-
-static void
-EscapePrint(s,w)
- char* s; int w;
-{
- for ( ; *s && w > 0; s++, w--) {
- if (*s == '(') { /* escape required */
- fputc('\\', psfp);
- } else if (*s == ')') {
- fputc('\\', psfp);
- }
-
- fputc(*s, psfp);
- }
-}
diff --git a/ghc/utils/hp2ps/PsFile.h b/ghc/utils/hp2ps/PsFile.h
deleted file mode 100644
index acec0703bc..0000000000
--- a/ghc/utils/hp2ps/PsFile.h
+++ /dev/null
@@ -1,6 +0,0 @@
-#ifndef PS_FILE_H
-#define PS_FILE_H
-
-void PutPsFile PROTO((void));
-
-#endif /* PS_FILE_H */
diff --git a/ghc/utils/hp2ps/README.GHC b/ghc/utils/hp2ps/README.GHC
deleted file mode 100644
index a3fb21e922..0000000000
--- a/ghc/utils/hp2ps/README.GHC
+++ /dev/null
@@ -1,4 +0,0 @@
-This "hp2ps" program was written and is maintained by Dave Wakeling at
-York. All I (WDP) have done is make it slot into the "make world"ery.
-
-We are grateful for this contribution of shared code.
diff --git a/ghc/utils/hp2ps/Reorder.c b/ghc/utils/hp2ps/Reorder.c
deleted file mode 100644
index afeed52d85..0000000000
--- a/ghc/utils/hp2ps/Reorder.c
+++ /dev/null
@@ -1,89 +0,0 @@
-#include "Main.h"
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-#include "Defines.h"
-#include "Error.h"
-#include "HpFile.h"
-#include "Utilities.h"
-
-/* own stuff */
-#include "Reorder.h"
-
-static struct order {
- char* ident;
- int order;
-} *ordermap = 0;
-
-static int ordermapmax = 0;
-static int ordermapindex = 0;
-
-
-void
-OrderFor(ident, order)
- char* ident;
- int order;
-{
- if (! ordermap) {
- ordermapmax = (nidents > TWENTY ? nidents : TWENTY) * 2;
- /* Assume nidents read is indication of the No of
- idents in the .aux file (*2 for good luck !) */
- ordermap = xmalloc(ordermapmax * sizeof(struct order));
- }
-
- if (ordermapindex < ordermapmax) {
- ordermap[ ordermapindex ].ident = copystring(ident);
- ordermap[ ordermapindex ].order = order;
- ordermapindex++;
- } else {
- Disaster("order map overflow");
- }
-}
-
-/*
- * Get the order of to be used for "ident" if there is one.
- * Otherwise, return 0 which is the minimum ordering value.
- */
-
-int
-OrderOf(ident)
- char* ident;
-{
- int i;
-
- for (i = 0; i < ordermapindex; i++) {
- if (strcmp(ordermap[i].ident, ident) == 0) { /* got it */
- return(ordermap[i].order);
- }
- }
-
- return 0;
-}
-
-/*
- * Reorder on the basis of information from ".aux" file.
- */
-
-void
-Reorder()
-{
- intish i;
- intish j;
- int min;
- struct entry* e;
- int o1, o2;
-
- for (i = 0; i < nidents-1; i++) {
- min = i;
- for (j = i+1; j < nidents; j++) {
- o1 = OrderOf(identtable[ j ]->name);
- o2 = OrderOf(identtable[ min ]->name);
-
- if (o1 < o2 ) min = j;
- }
-
- e = identtable[ min ];
- identtable[ min ] = identtable[ i ];
- identtable[ i ] = e;
- }
-}
diff --git a/ghc/utils/hp2ps/Reorder.h b/ghc/utils/hp2ps/Reorder.h
deleted file mode 100644
index 089ef75cfc..0000000000
--- a/ghc/utils/hp2ps/Reorder.h
+++ /dev/null
@@ -1,8 +0,0 @@
-#ifndef REORDER_H
-#define REORDER_H
-
-void Reorder PROTO((void));
-int OrderOf PROTO((char *));
-void OrderFor PROTO((char *, int));
-
-#endif /* REORDER_H */
diff --git a/ghc/utils/hp2ps/Scale.c b/ghc/utils/hp2ps/Scale.c
deleted file mode 100644
index 32120407b3..0000000000
--- a/ghc/utils/hp2ps/Scale.c
+++ /dev/null
@@ -1,86 +0,0 @@
-#include "Main.h"
-#include <stdio.h>
-#include <stdlib.h>
-#include "Defines.h"
-#include "Dimensions.h"
-#include "Error.h"
-#include "HpFile.h"
-#include "Utilities.h"
-
-/* own stuff */
-#include "Scale.h"
-
-/*
- * Return the maximum combined height that all the sample
- * curves will reach. This (absolute) figure can then be
- * used to scale the samples automatically so that they
- * fit on the page.
- */
-
-floatish
-MaxCombinedHeight()
-{
- intish i;
- intish j;
- floatish mx;
- int bucket;
- floatish value;
- struct chunk* ch;
- floatish *maxima;
-
- maxima = (floatish*) xmalloc(nsamples * sizeof(floatish));
- for (i = 0; i < nsamples; i++) {
- maxima[ i ] = 0.0;
- }
-
- for (i = 0; i < nidents; i++) {
- for (ch = identtable[i]->chk; ch; ch = ch->next) {
- for (j = 0; j < ch->nd; j++) {
- bucket = ch->d[j].bucket;
- value = ch->d[j].value;
- if (bucket >= nsamples)
- Disaster("bucket out of range");
- maxima[ bucket ] += value;
- }
- }
- }
-
- for (mx = maxima[ 0 ], i = 0; i < nsamples; i++) {
- if (maxima[ i ] > mx) mx = maxima[ i ];
- }
-
- free(maxima);
- return mx;
-}
-
-
-
-/*
- * Scale the values from the samples so that they will fit on
- * the page.
- */
-
-extern floatish xrange;
-extern floatish yrange;
-
-void
-Scale()
-{
- intish i;
- intish j;
- floatish sf;
- struct chunk* ch;
-
- if (yrange == 0.0) /* no samples */
- return;
-
- sf = graphheight / yrange;
-
- for (i = 0; i < nidents; i++) {
- for (ch = identtable[i]->chk; ch; ch = ch->next) {
- for (j = 0; j < ch->nd; j++) {
- ch->d[j].value = ch->d[j].value * sf;
- }
- }
- }
-}
diff --git a/ghc/utils/hp2ps/Scale.h b/ghc/utils/hp2ps/Scale.h
deleted file mode 100644
index 0c19d6c3c0..0000000000
--- a/ghc/utils/hp2ps/Scale.h
+++ /dev/null
@@ -1,7 +0,0 @@
-#ifndef SCALE_H
-#define SCALE_H
-
-floatish MaxCombinedHeight PROTO((void));
-void Scale PROTO((void));
-
-#endif /* SCALE_H */
diff --git a/ghc/utils/hp2ps/Shade.c b/ghc/utils/hp2ps/Shade.c
deleted file mode 100644
index 9e3274bf69..0000000000
--- a/ghc/utils/hp2ps/Shade.c
+++ /dev/null
@@ -1,130 +0,0 @@
-#include "Main.h"
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-#include "Defines.h"
-#include "Error.h"
-#include "Utilities.h"
-
-/* own stuff */
-#include "Shade.h"
-
-static struct shade {
- char* ident;
- floatish shade;
-} *shademap;
-
-static int shademapmax = 0;
-static int shademapindex = 0;
-
-/*
- * Set the shade to be used for "ident" to "shade".
- */
-
-void
-ShadeFor(ident, shade)
- char* ident;
- floatish shade;
-{
- if (! shademap) {
- shademapmax = (nidents > TWENTY ? nidents : TWENTY) * 2;
- /* Assume nidents read is indication of the No of
- idents in the .aux file (*2 for good luck) */
- /* NB *2 is needed as .aux and .hp elements may differ */
- shademap = xmalloc(shademapmax * sizeof(struct shade));
- }
-
- if (shademapindex < shademapmax) {
- shademap[ shademapindex ].ident = copystring(ident);
- shademap[ shademapindex ].shade = shade;
- shademapindex++;
- } else {
- Disaster("shade map overflow");
- }
-}
-
-/*
- * Get the shade to be used for "ident" if there is one.
- * Otherwise, think of a new one.
- */
-
-static floatish ThinkOfAShade PROTO((void)); /* forward */
-
-floatish
-ShadeOf(ident)
- char* ident;
-{
- int i;
- floatish shade;
-
- for (i = 0; i < shademapindex; i++) {
- if (strcmp(shademap[i].ident, ident) == 0) { /* got it */
- return(shademap[i].shade);
- }
- }
-
- shade = ThinkOfAShade();
-
- ShadeFor(ident, shade);
-
- return shade;
-}
-
-
-
-#define N_MONO_SHADES 10
-
-static floatish m_shades[ N_MONO_SHADES ] = {
- 0.00000, 0.20000, 0.60000, 0.30000, 0.90000,
- 0.40000, 1.00000, 0.70000, 0.50000, 0.80000
-};
-
-#define N_COLOUR_SHADES 27
-
-/* HACK: 0.100505 means 100% red, 50% green, 50% blue */
-
-static floatish c_shades[ N_COLOUR_SHADES ] = {
- 0.000000, 0.000010, 0.001000, 0.001010, 0.100000,
- 0.100010, 0.101000, 0.101010, 0.000005, 0.000500,
- 0.000510, 0.001005, 0.050000, 0.050010, 0.051000,
- 0.051010, 0.100005, 0.100500, 0.100510, 0.101005,
- 0.000505, 0.050005, 0.050500, 0.050510, 0.051005,
- 0.100505, 0.050505
-};
-
-static floatish
-ThinkOfAShade()
-{
- static int thisshade = -1;
-
- thisshade++;
- return cflag ?
- c_shades[ thisshade % N_COLOUR_SHADES ] :
- m_shades[ thisshade % N_MONO_SHADES ] ;
-}
-
-static floatish
-extract_colour(shade,factor)
- floatish shade;
- intish factor;
-{
- intish i,j;
-
- i = (int)(shade * factor);
- j = i / 100;
- return (i - j * 100) / 10.0;
-}
-
-void
-SetPSColour(shade)
- floatish shade;
-{
- if (cflag) {
- fprintf(psfp, "%f %f %f setrgbcolor\n",
- extract_colour(shade, (intish)100),
- extract_colour(shade, (intish)10000),
- extract_colour(shade, (intish)1000000));
- } else {
- fprintf(psfp, "%f setgray\n", shade);
- }
-}
diff --git a/ghc/utils/hp2ps/Shade.h b/ghc/utils/hp2ps/Shade.h
deleted file mode 100644
index 0e49c90d04..0000000000
--- a/ghc/utils/hp2ps/Shade.h
+++ /dev/null
@@ -1,8 +0,0 @@
-#ifndef SHADE_H
-#define SHADE_H
-
-floatish ShadeOf PROTO((char *));
-void ShadeFor PROTO((char *, floatish));
-void SetPSColour PROTO((floatish));
-
-#endif /* SHADE_H */
diff --git a/ghc/utils/hp2ps/TopTwenty.c b/ghc/utils/hp2ps/TopTwenty.c
deleted file mode 100644
index bbb6be4390..0000000000
--- a/ghc/utils/hp2ps/TopTwenty.c
+++ /dev/null
@@ -1,72 +0,0 @@
-#include "Main.h"
-#include <stdio.h>
-#include <stdlib.h>
-#include "Defines.h"
-#include "Error.h"
-#include "HpFile.h"
-#include "Utilities.h"
-
-/* own stuff */
-#include "TopTwenty.h"
-
-/*
- * We only have room in the key for a maximum of 20 identifiers.
- * We therefore choose to keep the top 20 bands --- these will
- * be the most important ones, since this pass is performed after
- * the threshold and standard deviation passes. If there are more
- * than 20 bands, the excess are gathered together as an "OTHER" ]
- * band which appears as band 20.
- */
-
-void
-TopTwenty()
-{
- intish i;
- intish j;
- intish compact;
- intish bucket;
- floatish value;
- struct entry* en;
- struct chunk* ch;
- floatish *other;
-
- i = nidents;
- if (i <= TWENTY) return; /* nothing to do! */
-
- other = (floatish*) xmalloc(nsamples * sizeof(floatish));
- /* build a list of samples for "OTHER" */
-
- compact = (i - TWENTY) + 1;
-
- for (i = 0; i < nsamples; i++) {
- other[ i ] = 0.0;
- }
-
- for (i = 0; i < compact && i < nidents; i++) {
- for (ch = identtable[i]->chk; ch; ch = ch->next) {
- for (j = 0; j < ch->nd; j++) {
- bucket = ch->d[j].bucket;
- value = ch->d[j].value;
- if (bucket >= nsamples)
- Disaster("bucket out of range");
- other[ bucket ] += value;
- }
- }
- }
-
- en = MakeEntry("OTHER");
- en->next = 0;
-
- for (i = 0; i < nsamples; i++) {
- StoreSample(en, i, other[i]);
- }
-
- /* slide samples down */
- for (i = compact; i < nidents; i++) {
- identtable[i-compact+1] = identtable[i];
- }
-
- nidents = TWENTY;
- identtable[0] = en;
- free(other);
-}
diff --git a/ghc/utils/hp2ps/TopTwenty.h b/ghc/utils/hp2ps/TopTwenty.h
deleted file mode 100644
index 53a7aed509..0000000000
--- a/ghc/utils/hp2ps/TopTwenty.h
+++ /dev/null
@@ -1,6 +0,0 @@
-#ifndef TOP_TWENTY_H
-#define TOP_TWENTY_H
-
-void TopTwenty PROTO((void));
-
-#endif /* TOP_TWENTY_H */
diff --git a/ghc/utils/hp2ps/TraceElement.c b/ghc/utils/hp2ps/TraceElement.c
deleted file mode 100644
index c14062dced..0000000000
--- a/ghc/utils/hp2ps/TraceElement.c
+++ /dev/null
@@ -1,96 +0,0 @@
-#include "Main.h"
-#include <stdio.h>
-#include <stdlib.h>
-#include "Defines.h"
-#include "HpFile.h"
-#include "Error.h"
-#include "Utilities.h"
-
-/* own stuff */
-#include "TraceElement.h"
-
-/*
- * Compute the total volume for each identifier, and the grand
- * total of these totals. The identifiers whose totals when
- * added together amount to less that a threshold percentage
- * (default 1%) of the grand total are considered to be ``trace
- * elements'' and they are thrown away.
- */
-
-extern floatish thresholdpercent;
-
-void TraceElement()
-{
- intish i;
- intish j;
- struct chunk* ch;
- floatish grandtotal;
- intish min;
- floatish t;
- floatish p;
- struct entry* e;
- intish *totals;
-
- totals = (intish *) xmalloc(nidents * sizeof(intish));
-
- /* find totals */
-
- for (i = 0; i < nidents; i++) {
- totals[ i ] = 0;
- }
-
- for (i = 0; i < nidents; i++) {
- for (ch = identtable[i]->chk; ch; ch = ch->next) {
- for (j = 0; j < ch->nd; j++) {
- totals[ i ] += ch->d[j].value;
- }
- }
- }
-
- /* sort on the basis of total */
-
- for (i = 0; i < nidents-1; i++) {
- min = i;
- for (j = i+1; j < nidents; j++) {
- if (totals[ j ] < totals[ min ]) {
- min = j;
- }
- }
-
- t = totals[ min ];
- totals[ min ] = totals[ i ];
- totals[ i ] = t;
-
- e = identtable[ min ];
- identtable[ min ] = identtable[ i ];
- identtable[ i ] = e;
- }
-
-
- /* find the grand total (NB: can get *BIG*!) */
-
- grandtotal = 0.0;
-
- for (i = 0; i < nidents; i++) {
- grandtotal += (floatish) totals[ i ];
- }
-
- t = 0.0; /* cumulative percentage */
-
- for (i = 0; i < nidents; i++) {
- p = (100.0 * (floatish) totals[i]) / grandtotal;
- t = t + p;
- if (t >= THRESHOLD_PERCENT) {
- break;
- }
- }
-
- /* identifiers from 0 to i-1 should be removed */
- for (j = 0; i < nidents; i++, j++) {
- identtable[j] = identtable[i];
- }
-
- nidents = j;
-
- free(totals);
-}
diff --git a/ghc/utils/hp2ps/TraceElement.h b/ghc/utils/hp2ps/TraceElement.h
deleted file mode 100644
index d843392a23..0000000000
--- a/ghc/utils/hp2ps/TraceElement.h
+++ /dev/null
@@ -1,6 +0,0 @@
-#ifndef TRACE_ELEMENT_H
-#define TRACE_ELEMENT_H
-
-void TraceElement PROTO((void));
-
-#endif /* TRACE_ELEMENT_H */
diff --git a/ghc/utils/hp2ps/Utilities.c b/ghc/utils/hp2ps/Utilities.c
deleted file mode 100644
index c9fb612f0e..0000000000
--- a/ghc/utils/hp2ps/Utilities.c
+++ /dev/null
@@ -1,132 +0,0 @@
-#include "Main.h"
-#include <stdio.h>
-#include <string.h>
-#include "Error.h"
-
-extern void* malloc();
-
-char*
-Basename(name)
- char* name;
-{
- char* t;
-
- t = name;
-
- while (*name) {
- if (*name == '/') {
- t = name+1;
- }
- name++;
- }
-
- return t;
-}
-
-void
-DropSuffix(name, suffix)
- char* name; char* suffix;
-{
- char* t;
-
- t = (char*) 0;
-
- while (*name) {
- if (*name == '.') {
- t = name;
- }
- name++;
- }
-
- if (t != (char*) 0 && strcmp(t, suffix) == 0) {
- *t = '\0';
- }
-}
-
-FILE*
-OpenFile(s, mode)
- char* s; char* mode;
-{
- FILE* r;
-
- if ((r = fopen(s, mode)) == NULL) {
- /*NOTREACHED*/
- Error("cannot open %s", s);
- }
-
- return r;
-}
-
-
-#define ONETHOUSAND 1000
-
-/*
- * Print a positive integer with commas
- */
-
-void
-CommaPrint(fp,n)
- FILE* fp;
- intish n;
-{
- if (n < ONETHOUSAND) {
- fprintf(fp, "%d", (int)n);
- } else {
- CommaPrint(fp, n / ONETHOUSAND);
- fprintf(fp, ",%03d", (int)(n % ONETHOUSAND));
- }
-}
-
-void *
-xmalloc(n)
- size_t n;
-{
- void *r;
-
- r = (void*) malloc(n);
- if (!r) {
- /*NOTREACHED*/
- Disaster("%s, sorry, out of memory", hpfile);
- }
- return r;
-}
-
-void *
-xrealloc(p, n)
- void *p;
- size_t n;
-{
- void *r;
- extern void *realloc();
-
- r = realloc(p, n);
- if (!r) {
- /*NOTREACHED*/
- Disaster("%s, sorry, out of memory", hpfile);
- }
- return r;
-}
-
-char *
-copystring(s)
- char *s;
-{
- char *r;
-
- r = (char*) xmalloc(strlen(s)+1);
- strcpy(r, s);
- return r;
-}
-
-char *
-copystring2(s, t)
- char *s, *t;
-{
- char *r;
-
- r = (char*) xmalloc(strlen(s)+strlen(t)+1);
- strcpy(r, s);
- strcat(r, t);
- return r;
-}
-
diff --git a/ghc/utils/hp2ps/Utilities.h b/ghc/utils/hp2ps/Utilities.h
deleted file mode 100644
index 10776d9613..0000000000
--- a/ghc/utils/hp2ps/Utilities.h
+++ /dev/null
@@ -1,13 +0,0 @@
-#ifndef UTILITIES_H
-#define UTILITIES_H
-
-char* Basename PROTO((char *));
-void DropSuffix PROTO((char *, char *));
-FILE* OpenFile PROTO((char *, char *));
-void CommaPrint PROTO((FILE *, intish));
-char *copystring PROTO((char *));
-char *copystring2 PROTO((char *, char *));
-void *xmalloc PROTO((size_t));
-void *xrealloc PROTO((void *, size_t));
-
-#endif /* UTILITIES_H */
diff --git a/ghc/utils/hp2ps/hp2ps.1 b/ghc/utils/hp2ps/hp2ps.1
deleted file mode 100644
index fd0bca0234..0000000000
--- a/ghc/utils/hp2ps/hp2ps.1
+++ /dev/null
@@ -1,145 +0,0 @@
-.\" man page for hp2ps
-.ds PS P\s-2OST\s+2S\s-2CRIPT\s+2
-.\" typeset examples in fixed size font as indented paragraph
-.de Ex
-.sp
-.RS
-.nf
-.ft C
-..
-.de Xe
-.RE
-.sp
-.fi
-..
-.TH HP2PS 1 "18 April 1992"
-.SH NAME
-hp2ps \- convert a heap profile to a \*(PS graph
-.SH SYNOPSIS
-.B hp2ps
-[flags] [file][.hp]
-.SH DESCRIPTION
-The program
-.B hp2ps
-converts a heap profile stored in
-.IR file
-into a \*(PS graph, sending the result to
-.IR file.ps.
-By convention, files to be processed by
-.B hp2ps
-have a
-.I .hp
-extension. However, for compatibility with older versions of
-.B hp2ps,
-this extension can be omitted. If
-.IR file
-is omitted entirely, then the program behaves as a filter.
-.SH OPTIONS
-The flags are:
-.IP "\fB\-d\fP"
-In order to make graphs more readable,
-.B hp2ps
-sorts the shaded bands for each identifier. The default sort ordering is for
-the bands with the largest area to be stacked on top of the smaller ones.
-The
-.B \-d
-option causes rougher bands (those reprsenting series of values with the
-largest standard deviations) to be stacked on top of smoother ones.
-.IP "\fB\-b\fP"
-Normally,
-.B hp2ps
-puts the title of the graph in a small box at the top of the page. However,
-if the JOB string is too long to fit in a small box (more than 35 characters),
-then
-.B hp2ps
-will choose to use a big box instead. The
-.B \-b
-option forces
-.B hp2ps
-to use a big box.
-.IP "\fB\-e\fP \fIfloat\fP[in|mm|pt]"
-Generate encapsulated \*(PS suitable for inclusion in LaTeX documents.
-Usually, the \*(PS graph is drawn in landscape mode in an area
-9 inches wide by 6 inches high, and
-.B hp2ps
-arranges for this area to be approximately centered on a sheet of a4
-paper. This format is convenient of studying the graph in detail, but
-it is unsuitable for inclusion in LaTeX documents. The
-.B \-e
-option causes the graph to be drawn in portrait mode, with
-.I float
-specifying the width in inches, millimetres or points (the default).
-The resulting \*(PS file conforms to the
-.I "Encapsulated Post Script"
-(EPS) convention, and it can be included in a LaTeX document using Rokicki's
-dvi-to-\*(PS converter
-.B dvips.
-.B hp2ps
-requires the width to exceed 2 inches.
-.IP "\fB\-g\fP"
-Create output suitable for the
-.B gs
-\*(PS previewer (or similar). In this case the graph is printed in portrait
-mode without scaling. The output is unsuitable for a laser printer.
-.IP "\fB\-p\fP"
-Use previous parameters. By default, the \*(PS graph is automatically
-scaled both horizontally and vertically so that it fills the page.
-However, when preparing a seires of graphs for use in a presentation,
-it is often useful to draw a new graph using the same scale, shading and
-ordering as a previous one. The
-.B \-p
-flag causes the graph to be drawn using the parameters determined by
-a previous run of
-.B hp2ps
-on
-.IR file.
-.IP "\fB\-s\fP"
-Use a small box for the title.
-.IP "\fB\-y\fP"
-Draw the graph in the traditional York style, ignoring marks.
-.IP "\fB\-?\fP"
-Print out usage information.
-.SH "INPUT FORMAT"
-The format of a heap profile is best described by example:
-.Ex
-JOB "a.out -p"
-DATE "Fri Apr 17 11:43:45 1992"
-SAMPLE_UNIT "seconds"
-VALUE_UNIT "bytes"
-BEGIN_SAMPLE 0.00
- SYSTEM 24
-END_SAMPLE 0.00
-BEGIN_SAMPLE 1.00
- elim 180
- insert 24
- intersect 12
- disin 60
- main 12
- reduce 20
- SYSTEM 12
-END_SAMPLE 1.00
-MARK 1.50
-MARK 1.75
-MARK 1.80
-BEGIN_SAMPLE 2.00
- elim 192
- insert 24
- intersect 12
- disin 84
- main 12
- SYSTEM 24
-END_SAMPLE 2.00
-BEGIN_SAMPLE 2.82
-END_SAMPLE 2.82
-
-.Xe
-.SH "SEE ALSO"
-dvips(1), latex(1), hbchp (1), lmlchp(1)
-.br
-C. Runciman and D. Wakeling,
-.I
-Heap Profiling for Lazy Functional Languages, YCS-172, University of York, 1992
-.SH NOTES
-\*(PS is a registered trademark of Adobe Systems Incorporated.
-.SH AUTHOR
-David Wakeling of the University of York.
diff --git a/ghc/utils/hp2ps/makefile.original b/ghc/utils/hp2ps/makefile.original
deleted file mode 100644
index a625149552..0000000000
--- a/ghc/utils/hp2ps/makefile.original
+++ /dev/null
@@ -1,42 +0,0 @@
-OBJS= \
- AuxFile.o \
- Axes.o \
- AreaBelow.o \
- Curves.o \
- Deviation.o \
- Dimensions.o \
- Error.o \
- HpFile.o \
- Key.o \
- Main.o \
- Marks.o \
- TopTwenty.o \
- TraceElement.o \
- PsFile.o \
- Reorder.o \
- Scale.o \
- Shade.o \
- Utilities.o
-
-# Please set MATHLIB and BIN appropriately. I don't need MATHLIB on my machine,
-# but you may.
-
-MATHLIB = -lm
-
-DSTBIN = /n/Numbers/usr/lml/lml-0.997.4hp/sun3/bin
-
-CC= cc # gcc -Wall
-CFLAGS= -g
-LDFLAGS= ${STATICFLAG}
-
-TARGET=hp2ps
-
-${TARGET}: ${OBJS}
- ${CC} -o ${TARGET} ${CCFLAGS} ${LDFLAGS} ${OBJS} ${MATHLIB}
-
-install: ${TARGET}
- mv ${TARGET} ${DSTBIN}/${TARGET}
- chmod 555 ${DSTBIN}/${TARGET}
-
-clean:
- rm -f core *.o ${TARGET}
diff --git a/ghc/utils/hsc2hs/Main.hs b/ghc/utils/hsc2hs/Main.hs
deleted file mode 100644
index 4b39e4a7bb..0000000000
--- a/ghc/utils/hsc2hs/Main.hs
+++ /dev/null
@@ -1,938 +0,0 @@
-{-# OPTIONS -fffi -cpp #-}
-
-------------------------------------------------------------------------
--- Program for converting .hsc files to .hs files, by converting the
--- file into a C program which is run to generate the Haskell source.
--- Certain items known only to the C compiler can then be used in
--- the Haskell module; for example #defined constants, byte offsets
--- within structures, etc.
---
--- See the documentation in the Users' Guide for more details.
-
-#if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
-#include "../../includes/ghcconfig.h"
-#endif
-
-#if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114 || __HUGS__
-import System.Console.GetOpt
-#else
-import GetOpt
-#endif
-
-import System (getProgName, getArgs, ExitCode(..), exitWith)
-import Directory (removeFile,doesFileExist)
-import Monad (MonadPlus(..), liftM, liftM2, when)
-import Char (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord)
-import List (intersperse, isSuffixOf)
-import IO (hPutStr, hPutStrLn, stderr)
-
-#if defined(mingw32_HOST_OS) && !__HUGS__
-import Foreign
-#if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114
-import Foreign.C.String
-#else
-import CString
-#endif
-#endif
-
-
-#if __GLASGOW_HASKELL__ >= 604
-import System.Process ( runProcess, waitForProcess )
-import System.IO ( openFile, IOMode(..), hClose )
-#define HAVE_runProcess
-#endif
-
-#if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
-import Compat.RawSystem ( rawSystem )
-#define HAVE_rawSystem
-#elif __HUGS__ || __NHC__ >= 117
-import System.Cmd ( rawSystem )
-#define HAVE_rawSystem
-#endif
-
-#if !defined(HAVE_runProcess) || !defined(HAVE_rawSystem)
--- we need system
-#if __HUGS__ || __NHC__ >= 117 || __GLASGOW_HASKELL__ >= 600
-import System.Cmd ( system )
-#else
-import System ( system )
-#endif
-#endif
-
-version :: String
-version = "hsc2hs version 0.66\n"
-
-data Flag
- = Help
- | Version
- | Template String
- | Compiler String
- | Linker String
- | CompFlag String
- | LinkFlag String
- | NoCompile
- | Include String
- | Define String (Maybe String)
- | Output String
- | Verbose
-
-template_flag :: Flag -> Bool
-template_flag (Template _) = True
-template_flag _ = False
-
-include :: String -> Flag
-include s@('\"':_) = Include s
-include s@('<' :_) = Include s
-include s = Include ("\""++s++"\"")
-
-define :: String -> Flag
-define s = case break (== '=') s of
- (name, []) -> Define name Nothing
- (name, _:value) -> Define name (Just value)
-
-options :: [OptDescr Flag]
-options = [
- Option ['o'] ["output"] (ReqArg Output "FILE")
- "name of main output file",
- Option ['t'] ["template"] (ReqArg Template "FILE")
- "template file",
- Option ['c'] ["cc"] (ReqArg Compiler "PROG")
- "C compiler to use",
- Option ['l'] ["ld"] (ReqArg Linker "PROG")
- "linker to use",
- Option ['C'] ["cflag"] (ReqArg CompFlag "FLAG")
- "flag to pass to the C compiler",
- Option ['I'] [] (ReqArg (CompFlag . ("-I"++)) "DIR")
- "passed to the C compiler",
- Option ['L'] ["lflag"] (ReqArg LinkFlag "FLAG")
- "flag to pass to the linker",
- Option ['i'] ["include"] (ReqArg include "FILE")
- "as if placed in the source",
- Option ['D'] ["define"] (ReqArg define "NAME[=VALUE]")
- "as if placed in the source",
- Option [] ["no-compile"] (NoArg NoCompile)
- "stop after writing *_hsc_make.c",
- Option ['v'] ["verbose"] (NoArg Verbose)
- "dump commands to stderr",
- Option ['?'] ["help"] (NoArg Help)
- "display this help and exit",
- Option ['V'] ["version"] (NoArg Version)
- "output version information and exit" ]
-
-
-main :: IO ()
-main = do
- prog <- getProgramName
- let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]\n"
- args <- getArgs
- let (flags, files, errs) = getOpt Permute options args
-
- -- If there is no Template flag explicitly specified, try
- -- to find one by looking near the executable. This only
- -- works on Win32 or Hugs (getExecDir). On Unix, there's a wrapper
- -- script which specifies an explicit template flag.
- flags_w_tpl <- if any template_flag flags then
- return flags
- else
-#ifdef __HUGS__
- do mb_path <- getExecDir "/Main.hs"
-#else
- do mb_path <- getExecDir "/bin/hsc2hs.exe"
-#endif
- add_opt <-
- case mb_path of
- Nothing -> return id
- Just path -> do
- let templ = path ++ "/template-hsc.h"
- flg <- doesFileExist templ
- if flg
- then return ((Template templ):)
- else return id
- return (add_opt flags)
- case (files, errs) of
- (_, _)
- | any isHelp flags_w_tpl -> bye (usageInfo header options)
- | any isVersion flags_w_tpl -> bye version
- where
- isHelp Help = True; isHelp _ = False
- isVersion Version = True; isVersion _ = False
- ((_:_), []) -> mapM_ (processFile flags_w_tpl) files
- (_, _ ) -> die (concat errs ++ usageInfo header options)
-
-getProgramName :: IO String
-getProgramName = liftM (`withoutSuffix` "-bin") getProgName
- where str `withoutSuffix` suff
- | suff `isSuffixOf` str = take (length str - length suff) str
- | otherwise = str
-
-bye :: String -> IO a
-bye s = putStr s >> exitWith ExitSuccess
-
-die :: String -> IO a
-die s = hPutStr stderr s >> exitWith (ExitFailure 1)
-
-processFile :: [Flag] -> String -> IO ()
-processFile flags name
- = do let file_name = dosifyPath name
- s <- readFile file_name
- case parser of
- Parser p -> case p (SourcePos file_name 1) s of
- Success _ _ _ toks -> output flags file_name toks
- Failure (SourcePos name' line) msg ->
- die (name'++":"++show line++": "++msg++"\n")
-
-------------------------------------------------------------------------
--- A deterministic parser which remembers the text which has been parsed.
-
-newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
-
-data ParseResult a = Success !SourcePos String String a
- | Failure !SourcePos String
-
-data SourcePos = SourcePos String !Int
-
-updatePos :: SourcePos -> Char -> SourcePos
-updatePos pos@(SourcePos name line) ch = case ch of
- '\n' -> SourcePos name (line + 1)
- _ -> pos
-
-instance Monad Parser where
- return a = Parser $ \pos s -> Success pos [] s a
- Parser m >>= k =
- Parser $ \pos s -> case m pos s of
- Success pos' out1 s' a -> case k a of
- Parser k' -> case k' pos' s' of
- Success pos'' out2 imp'' b ->
- Success pos'' (out1++out2) imp'' b
- Failure pos'' msg -> Failure pos'' msg
- Failure pos' msg -> Failure pos' msg
- fail msg = Parser $ \pos _ -> Failure pos msg
-
-instance MonadPlus Parser where
- mzero = fail "mzero"
- Parser m `mplus` Parser n =
- Parser $ \pos s -> case m pos s of
- success@(Success _ _ _ _) -> success
- Failure _ _ -> n pos s
-
-getPos :: Parser SourcePos
-getPos = Parser $ \pos s -> Success pos [] s pos
-
-setPos :: SourcePos -> Parser ()
-setPos pos = Parser $ \_ s -> Success pos [] s ()
-
-message :: Parser a -> String -> Parser a
-Parser m `message` msg =
- Parser $ \pos s -> case m pos s of
- success@(Success _ _ _ _) -> success
- Failure pos' _ -> Failure pos' msg
-
-catchOutput_ :: Parser a -> Parser String
-catchOutput_ (Parser m) =
- Parser $ \pos s -> case m pos s of
- Success pos' out s' _ -> Success pos' [] s' out
- Failure pos' msg -> Failure pos' msg
-
-fakeOutput :: Parser a -> String -> Parser a
-Parser m `fakeOutput` out =
- Parser $ \pos s -> case m pos s of
- Success pos' _ s' a -> Success pos' out s' a
- Failure pos' msg -> Failure pos' msg
-
-lookAhead :: Parser String
-lookAhead = Parser $ \pos s -> Success pos [] s s
-
-satisfy :: (Char -> Bool) -> Parser Char
-satisfy p =
- Parser $ \pos s -> case s of
- c:cs | p c -> Success (updatePos pos c) [c] cs c
- _ -> Failure pos "Bad character"
-
-char_ :: Char -> Parser ()
-char_ c = do
- satisfy (== c) `message` (show c++" expected")
- return ()
-
-anyChar_ :: Parser ()
-anyChar_ = do
- satisfy (const True) `message` "Unexpected end of file"
- return ()
-
-any2Chars_ :: Parser ()
-any2Chars_ = anyChar_ >> anyChar_
-
-many :: Parser a -> Parser [a]
-many p = many1 p `mplus` return []
-
-many1 :: Parser a -> Parser [a]
-many1 p = liftM2 (:) p (many p)
-
-many_ :: Parser a -> Parser ()
-many_ p = many1_ p `mplus` return ()
-
-many1_ :: Parser a -> Parser ()
-many1_ p = p >> many_ p
-
-manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
-manySatisfy = many . satisfy
-manySatisfy1 = many1 . satisfy
-
-manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
-manySatisfy_ = many_ . satisfy
-manySatisfy1_ = many1_ . satisfy
-
-------------------------------------------------------------------------
--- Parser of hsc syntax.
-
-data Token
- = Text SourcePos String
- | Special SourcePos String String
-
-parser :: Parser [Token]
-parser = do
- pos <- getPos
- t <- catchOutput_ text
- s <- lookAhead
- rest <- case s of
- [] -> return []
- _:_ -> liftM2 (:) (special `fakeOutput` []) parser
- return (if null t then rest else Text pos t : rest)
-
-text :: Parser ()
-text = do
- s <- lookAhead
- case s of
- [] -> return ()
- c:_ | isAlpha c || c == '_' -> do
- anyChar_
- manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
- text
- c:_ | isHsSymbol c -> do
- symb <- catchOutput_ (manySatisfy_ isHsSymbol)
- case symb of
- "#" -> return ()
- '-':'-':symb' | all (== '-') symb' -> do
- return () `fakeOutput` symb
- manySatisfy_ (/= '\n')
- text
- _ -> do
- return () `fakeOutput` unescapeHashes symb
- text
- '\"':_ -> do anyChar_; hsString '\"'; text
- '\'':_ -> do anyChar_; hsString '\''; text
- '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
- _:_ -> do anyChar_; text
-
-hsString :: Char -> Parser ()
-hsString quote = do
- s <- lookAhead
- case s of
- [] -> return ()
- c:_ | c == quote -> anyChar_
- '\\':c:_
- | isSpace c -> do
- anyChar_
- manySatisfy_ isSpace
- char_ '\\' `mplus` return ()
- hsString quote
- | otherwise -> do any2Chars_; hsString quote
- _:_ -> do anyChar_; hsString quote
-
-hsComment :: Parser ()
-hsComment = do
- s <- lookAhead
- case s of
- [] -> return ()
- '-':'}':_ -> any2Chars_
- '{':'-':_ -> do any2Chars_; hsComment; hsComment
- _:_ -> do anyChar_; hsComment
-
-linePragma :: Parser ()
-linePragma = do
- char_ '#'
- manySatisfy_ isSpace
- satisfy (\c -> c == 'L' || c == 'l')
- satisfy (\c -> c == 'I' || c == 'i')
- satisfy (\c -> c == 'N' || c == 'n')
- satisfy (\c -> c == 'E' || c == 'e')
- manySatisfy1_ isSpace
- line <- liftM read $ manySatisfy1 isDigit
- manySatisfy1_ isSpace
- char_ '\"'
- name <- manySatisfy (/= '\"')
- char_ '\"'
- manySatisfy_ isSpace
- char_ '#'
- char_ '-'
- char_ '}'
- setPos (SourcePos name (line - 1))
-
-isHsSymbol :: Char -> Bool
-isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$' = True
-isHsSymbol '%' = True; isHsSymbol '&' = True; isHsSymbol '*' = True
-isHsSymbol '+' = True; isHsSymbol '.' = True; isHsSymbol '/' = True
-isHsSymbol '<' = True; isHsSymbol '=' = True; isHsSymbol '>' = True
-isHsSymbol '?' = True; isHsSymbol '@' = True; isHsSymbol '\\' = True
-isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-' = True
-isHsSymbol '~' = True
-isHsSymbol _ = False
-
-unescapeHashes :: String -> String
-unescapeHashes [] = []
-unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
-unescapeHashes (c:s) = c : unescapeHashes s
-
-lookAheadC :: Parser String
-lookAheadC = liftM joinLines lookAhead
- where
- joinLines [] = []
- joinLines ('\\':'\n':s) = joinLines s
- joinLines (c:s) = c : joinLines s
-
-satisfyC :: (Char -> Bool) -> Parser Char
-satisfyC p = do
- s <- lookAhead
- case s of
- '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
- _ -> satisfy p
-
-charC_ :: Char -> Parser ()
-charC_ c = do
- satisfyC (== c) `message` (show c++" expected")
- return ()
-
-anyCharC_ :: Parser ()
-anyCharC_ = do
- satisfyC (const True) `message` "Unexpected end of file"
- return ()
-
-any2CharsC_ :: Parser ()
-any2CharsC_ = anyCharC_ >> anyCharC_
-
-manySatisfyC :: (Char -> Bool) -> Parser String
-manySatisfyC = many . satisfyC
-
-manySatisfyC_ :: (Char -> Bool) -> Parser ()
-manySatisfyC_ = many_ . satisfyC
-
-special :: Parser Token
-special = do
- manySatisfyC_ (\c -> isSpace c && c /= '\n')
- s <- lookAheadC
- case s of
- '{':_ -> do
- anyCharC_
- manySatisfyC_ isSpace
- sp <- keyArg (== '\n')
- charC_ '}'
- return sp
- _ -> keyArg (const False)
-
-keyArg :: (Char -> Bool) -> Parser Token
-keyArg eol = do
- pos <- getPos
- key <- keyword `message` "hsc keyword or '{' expected"
- manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
- arg <- catchOutput_ (argument eol)
- return (Special pos key arg)
-
-keyword :: Parser String
-keyword = do
- c <- satisfyC (\c' -> isAlpha c' || c' == '_')
- cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
- return (c:cs)
-
-argument :: (Char -> Bool) -> Parser ()
-argument eol = do
- s <- lookAheadC
- case s of
- [] -> return ()
- c:_ | eol c -> do anyCharC_; argument eol
- '\n':_ -> return ()
- '\"':_ -> do anyCharC_; cString '\"'; argument eol
- '\'':_ -> do anyCharC_; cString '\''; argument eol
- '(':_ -> do anyCharC_; nested ')'; argument eol
- ')':_ -> return ()
- '/':'*':_ -> do any2CharsC_; cComment; argument eol
- '/':'/':_ -> do
- any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
- '[':_ -> do anyCharC_; nested ']'; argument eol
- ']':_ -> return ()
- '{':_ -> do anyCharC_; nested '}'; argument eol
- '}':_ -> return ()
- _:_ -> do anyCharC_; argument eol
-
-nested :: Char -> Parser ()
-nested c = do argument (== '\n'); charC_ c
-
-cComment :: Parser ()
-cComment = do
- s <- lookAheadC
- case s of
- [] -> return ()
- '*':'/':_ -> do any2CharsC_
- _:_ -> do anyCharC_; cComment
-
-cString :: Char -> Parser ()
-cString quote = do
- s <- lookAheadC
- case s of
- [] -> return ()
- c:_ | c == quote -> anyCharC_
- '\\':_:_ -> do any2CharsC_; cString quote
- _:_ -> do anyCharC_; cString quote
-
-------------------------------------------------------------------------
--- Write the output files.
-
-splitName :: String -> (String, String)
-splitName name =
- case break (== '/') name of
- (file, []) -> ([], file)
- (dir, sep:rest) -> (dir++sep:restDir, restFile)
- where
- (restDir, restFile) = splitName rest
-
-splitExt :: String -> (String, String)
-splitExt name =
- case break (== '.') name of
- (base, []) -> (base, [])
- (base, sepRest@(sep:rest))
- | null restExt -> (base, sepRest)
- | otherwise -> (base++sep:restBase, restExt)
- where
- (restBase, restExt) = splitExt rest
-
-output :: [Flag] -> String -> [Token] -> IO ()
-output flags name toks = do
-
- (outName, outDir, outBase) <- case [f | Output f <- flags] of
- [] -> if not (null ext) && last ext == 'c'
- then return (dir++base++init ext, dir, base)
- else
- if ext == ".hs"
- then return (dir++base++"_out.hs", dir, base)
- else return (dir++base++".hs", dir, base)
- where
- (dir, file) = splitName name
- (base, ext) = splitExt file
- [f] -> let
- (dir, file) = splitName f
- (base, _) = splitExt file
- in return (f, dir, base)
- _ -> onlyOne "output file"
-
- let cProgName = outDir++outBase++"_hsc_make.c"
- oProgName = outDir++outBase++"_hsc_make.o"
- progName = outDir++outBase++"_hsc_make"
-#if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
--- This is a real hack, but the quoting mechanism used for calling the C preprocesseor
--- via GHC has changed a few times, so this seems to be the only way... :-P * * *
- ++ ".exe"
-#endif
- outHFile = outBase++"_hsc.h"
- outHName = outDir++outHFile
- outCName = outDir++outBase++"_hsc.c"
-
- beVerbose = any (\ x -> case x of { Verbose -> True; _ -> False}) flags
-
- let execProgName
- | null outDir = dosifyPath ("./" ++ progName)
- | otherwise = progName
-
- let specials = [(pos, key, arg) | Special pos key arg <- toks]
-
- let needsC = any (\(_, key, _) -> key == "def") specials
- needsH = needsC
-
- let includeGuard = map fixChar outHName
- where
- fixChar c | isAlphaNum c = toUpper c
- | otherwise = '_'
-
-#ifdef __HUGS__
- compiler <- case [c | Compiler c <- flags] of
- [] -> return "gcc"
- [c] -> return c
- _ -> onlyOne "compiler"
-
- linker <- case [l | Linker l <- flags] of
- [] -> return compiler
- [l] -> return l
- _ -> onlyOne "linker"
-#else
- -- Try locating GHC..on Win32, look in the vicinity of hsc2hs.
- -- Returns a native-format path
- locateGhc def = do
- mb <- getExecDir "bin/hsc2hs.exe"
- case mb of
- Nothing -> return def
- Just x -> do
- let ghc_path = dosifyPath (x ++ "bin/ghc.exe")
- flg <- doesFileExist ghc_path
- if flg
- then return ghc_path
- else return def
-
- -- On a Win32 installation we execute the hsc2hs binary directly,
- -- with no --cc flags, so we'll call locateGhc here, which will
- -- succeed, via getExecDir.
- --
- -- On a Unix installation, we'll run the wrapper script hsc2hs.sh
- -- (called plain hsc2hs in the installed tree), which will pass
- -- a suitable C compiler via --cc
- --
- -- The in-place installation always uses the wrapper script,
- -- (called hsc2hs-inplace, generated from hsc2hs.sh)
- compiler <- case [c | Compiler c <- flags] of
- [] -> locateGhc "ghc"
- [c] -> return c
- _ -> onlyOne "compiler"
-
- linker <- case [l | Linker l <- flags] of
- [] -> locateGhc compiler
- [l] -> return l
- _ -> onlyOne "linker"
-#endif
-
- writeFile cProgName $
- concatMap outFlagHeaderCProg flags++
- concatMap outHeaderCProg specials++
- "\nint main (int argc, char *argv [])\n{\n"++
- outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
- outHsLine (SourcePos name 0)++
- concatMap outTokenHs toks++
- " return 0;\n}\n"
-
- -- NOTE: hbc compiles "[() | NoCompile <- flags]" into wrong code,
- -- so we use something slightly more complicated. :-P
- when (any (\x -> case x of NoCompile -> True; _ -> False) flags) $
- exitWith ExitSuccess
-
-
-
- compilerStatus <- rawSystemL beVerbose compiler
- ( ["-c"]
- ++ [f | CompFlag f <- flags]
- ++ [cProgName]
- ++ ["-o", oProgName]
- )
-
- case compilerStatus of
- e@(ExitFailure _) -> exitWith e
- _ -> return ()
- removeFile cProgName
-
- linkerStatus <- rawSystemL beVerbose linker
- ( [f | LinkFlag f <- flags]
- ++ [oProgName]
- ++ ["-o", progName]
- )
-
- case linkerStatus of
- e@(ExitFailure _) -> exitWith e
- _ -> return ()
- removeFile oProgName
-
- progStatus <- rawSystemWithStdOutL beVerbose execProgName [] outName
- removeFile progName
- case progStatus of
- e@(ExitFailure _) -> exitWith e
- _ -> return ()
-
- when needsH $ writeFile outHName $
- "#ifndef "++includeGuard++"\n" ++
- "#define "++includeGuard++"\n" ++
- "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
- "#include <Rts.h>\n" ++
- "#endif\n" ++
- "#include <HsFFI.h>\n" ++
- "#if __NHC__\n" ++
- "#undef HsChar\n" ++
- "#define HsChar int\n" ++
- "#endif\n" ++
- concatMap outFlagH flags++
- concatMap outTokenH specials++
- "#endif\n"
-
- when needsC $ writeFile outCName $
- "#include \""++outHFile++"\"\n"++
- concatMap outTokenC specials
- -- NB. outHFile not outHName; works better when processed
- -- by gcc or mkdependC.
-
-rawSystemL :: Bool -> FilePath -> [String] -> IO ExitCode
-rawSystemL flg prog args = do
- let cmdLine = prog++" "++unwords args
- when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine)
-#ifndef HAVE_rawSystem
- system cmdLine
-#else
- rawSystem prog args
-#endif
-
-rawSystemWithStdOutL :: Bool -> FilePath -> [String] -> FilePath -> IO ExitCode
-rawSystemWithStdOutL flg prog args outFile = do
- let cmdLine = prog++" "++unwords args++" >"++outFile
- when flg (hPutStrLn stderr ("Executing: " ++ cmdLine))
-#ifndef HAVE_runProcess
- system cmdLine
-#else
- hOut <- openFile outFile WriteMode
- process <- runProcess prog args Nothing Nothing Nothing (Just hOut) Nothing
- res <- waitForProcess process
- hClose hOut
- return res
-#endif
-
-onlyOne :: String -> IO a
-onlyOne what = die ("Only one "++what++" may be specified\n")
-
-outFlagHeaderCProg :: Flag -> String
-outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
-outFlagHeaderCProg (Include f) = "#include "++f++"\n"
-outFlagHeaderCProg (Define n Nothing) = "#define "++n++" 1\n"
-outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
-outFlagHeaderCProg _ = ""
-
-outHeaderCProg :: (SourcePos, String, String) -> String
-outHeaderCProg (pos, key, arg) = case key of
- "include" -> outCLine pos++"#include "++arg++"\n"
- "define" -> outCLine pos++"#define "++arg++"\n"
- "undef" -> outCLine pos++"#undef "++arg++"\n"
- "def" -> case arg of
- 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
- 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
- _ -> ""
- _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
- "let" -> case break (== '=') arg of
- (_, "") -> ""
- (header, _:body) -> case break isSpace header of
- (name, args) ->
- outCLine pos++
- "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
- "printf ("++joinLines body++");\n"
- _ -> ""
- where
- joinLines = concat . intersperse " \\\n" . lines
-
-outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
-outHeaderHs flags inH toks =
- "#if " ++
- "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
- " printf (\"{-# OPTIONS -optc-D" ++
- "__GLASGOW_HASKELL__=%d #-}\\n\", " ++
- "__GLASGOW_HASKELL__);\n" ++
- "#endif\n"++
- case inH of
- Nothing -> concatMap outFlag flags++concatMap outSpecial toks
- Just f -> outInclude ("\""++f++"\"")
- where
- outFlag (Include f) = outInclude f
- outFlag (Define n Nothing) = outOption ("-optc-D"++n)
- outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
- outFlag _ = ""
- outSpecial (pos, key, arg) = case key of
- "include" -> outInclude arg
- "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
- | otherwise -> ""
- _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
- _ -> ""
- goodForOptD arg = case arg of
- "" -> True
- c:_ | isSpace c -> True
- '(':_ -> False
- _:s -> goodForOptD s
- toOptD arg = case break isSpace arg of
- (name, "") -> name
- (name, _:value) -> name++'=':dropWhile isSpace value
- outOption s =
- "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
- " printf (\"{-# OPTIONS %s #-}\\n\", \""++
- showCString s++"\");\n"++
- "#else\n"++
- " printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++
- showCString s++"\");\n"++
- "#endif\n"
- outInclude s =
- "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
- " printf (\"{-# OPTIONS -#include %s #-}\\n\", \""++
- showCString s++"\");\n"++
- "#else\n"++
- " printf (\"{-# INCLUDE %s #-}\\n\", \""++
- showCString s++"\");\n"++
- "#endif\n"
-
-outTokenHs :: Token -> String
-outTokenHs (Text pos txt) =
- case break (== '\n') txt of
- (allTxt, []) -> outText allTxt
- (first, _:rest) ->
- outText (first++"\n")++
- outHsLine pos++
- outText rest
- where
- outText s = " fputs (\""++showCString s++"\", stdout);\n"
-outTokenHs (Special pos key arg) =
- case key of
- "include" -> ""
- "define" -> ""
- "undef" -> ""
- "def" -> ""
- _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
- "let" -> ""
- "enum" -> outCLine pos++outEnum arg
- _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
-
-outEnum :: String -> String
-outEnum arg =
- case break (== ',') arg of
- (_, []) -> ""
- (t, _:afterT) -> case break (== ',') afterT of
- (f, afterF) -> let
- enums [] = ""
- enums (_:s) = case break (== ',') s of
- (enum, rest) -> let
- this = case break (== '=') $ dropWhile isSpace enum of
- (name, []) ->
- " hsc_enum ("++t++", "++f++", " ++
- "hsc_haskellize (\""++name++"\"), "++
- name++");\n"
- (hsName, _:cName) ->
- " hsc_enum ("++t++", "++f++", " ++
- "printf (\"%s\", \""++hsName++"\"), "++
- cName++");\n"
- in this++enums rest
- in enums afterF
-
-outFlagH :: Flag -> String
-outFlagH (Include f) = "#include "++f++"\n"
-outFlagH (Define n Nothing) = "#define "++n++" 1\n"
-outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
-outFlagH _ = ""
-
-outTokenH :: (SourcePos, String, String) -> String
-outTokenH (pos, key, arg) =
- case key of
- "include" -> outCLine pos++"#include "++arg++"\n"
- "define" -> outCLine pos++"#define " ++arg++"\n"
- "undef" -> outCLine pos++"#undef " ++arg++"\n"
- "def" -> outCLine pos++case arg of
- 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
- 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
- 'i':'n':'l':'i':'n':'e':' ':_ ->
- "#ifdef __GNUC__\n" ++
- "extern\n" ++
- "#endif\n"++
- arg++"\n"
- _ -> "extern "++header++";\n"
- where header = takeWhile (\c -> c /= '{' && c /= '=') arg
- _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
- _ -> ""
-
-outTokenC :: (SourcePos, String, String) -> String
-outTokenC (pos, key, arg) =
- case key of
- "def" -> case arg of
- 's':'t':'r':'u':'c':'t':' ':_ -> ""
- 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
- 'i':'n':'l':'i':'n':'e':' ':arg' ->
- case span (\c -> c /= '{' && c /= '=') arg' of
- (header, body) ->
- outCLine pos++
- "#ifndef __GNUC__\n" ++
- "extern inline\n" ++
- "#endif\n"++
- header++
- "\n#ifndef __GNUC__\n" ++
- ";\n" ++
- "#else\n"++
- body++
- "\n#endif\n"
- _ -> outCLine pos++arg++"\n"
- _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
- _ -> ""
-
-conditional :: String -> Bool
-conditional "if" = True
-conditional "ifdef" = True
-conditional "ifndef" = True
-conditional "elif" = True
-conditional "else" = True
-conditional "endif" = True
-conditional "error" = True
-conditional "warning" = True
-conditional _ = False
-
-outCLine :: SourcePos -> String
-outCLine (SourcePos name line) =
- "#line "++show line++" \""++showCString (snd (splitName name))++"\"\n"
-
-outHsLine :: SourcePos -> String
-outHsLine (SourcePos name line) =
- " hsc_line ("++show (line + 1)++", \""++
- showCString name++"\");\n"
-
-showCString :: String -> String
-showCString = concatMap showCChar
- where
- showCChar '\"' = "\\\""
- showCChar '\'' = "\\\'"
- showCChar '?' = "\\?"
- showCChar '\\' = "\\\\"
- showCChar c | c >= ' ' && c <= '~' = [c]
- showCChar '\a' = "\\a"
- showCChar '\b' = "\\b"
- showCChar '\f' = "\\f"
- showCChar '\n' = "\\n\"\n \""
- showCChar '\r' = "\\r"
- showCChar '\t' = "\\t"
- showCChar '\v' = "\\v"
- showCChar c = ['\\',
- intToDigit (ord c `quot` 64),
- intToDigit (ord c `quot` 8 `mod` 8),
- intToDigit (ord c `mod` 8)]
-
-
-
------------------------------------------
--- Modified version from ghc/compiler/SysTools
--- Convert paths foo/baz to foo\baz on Windows
-
-subst :: Char -> Char -> String -> String
-#if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
-subst a b = map (\x -> if x == a then b else x)
-#else
-subst _ _ = id
-#endif
-
-dosifyPath :: String -> String
-dosifyPath = subst '/' '\\'
-
--- (getExecDir cmd) returns the directory in which the current
--- executable, which should be called 'cmd', is running
--- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
--- you'll get "/a/b/c" back as the result
-getExecDir :: String -> IO (Maybe String)
-getExecDir cmd =
- getExecPath >>= maybe (return Nothing) removeCmdSuffix
- where unDosifyPath = subst '\\' '/'
- initN n = reverse . drop n . reverse
- removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
-
-getExecPath :: IO (Maybe String)
-#if defined(__HUGS__)
-getExecPath = liftM Just getProgName
-#elif defined(mingw32_HOST_OS)
-getExecPath =
- allocaArray len $ \buf -> do
- ret <- getModuleFileName nullPtr buf len
- if ret == 0 then return Nothing
- else liftM Just $ peekCString buf
- where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
-
-foreign import stdcall unsafe "GetModuleFileNameA"
- getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
-#else
-getExecPath = return Nothing
-#endif
diff --git a/ghc/utils/hsc2hs/Makefile b/ghc/utils/hsc2hs/Makefile
deleted file mode 100644
index ccaf68eec8..0000000000
--- a/ghc/utils/hsc2hs/Makefile
+++ /dev/null
@@ -1,101 +0,0 @@
-# -----------------------------------------------------------------------------
-# To compile with nhc98 on unix:
-# nhc98 -cpp -package base -o hsc2hs-bin Main.hs
-
-TOP=../..
-include $(TOP)/mk/boilerplate.mk
-
-CURRENT_DIR=ghc/utils/hsc2hs
-INCLUDE_DIR=ghc/includes
-
-INSTALLING=1
-
-# This causes libghccompat.a to be used:
-include $(GHC_LIB_COMPAT_DIR)/compat.mk
-
-# This is required because libghccompat.a must be built with
-# $(GhcHcOpts) because it is linked to the compiler, and hence
-# we must also build with $(GhcHcOpts) here:
-SRC_HC_OPTS += $(GhcHcOpts)
-
-HS_PROG = hsc2hs-bin
-ifeq "$(HOSTPLATFORM)" "i386-unknown-mingw32"
-HS_PROG = hsc2hs$(exeext)
-endif
-ifeq "$(HOSTPLATFORM)" "i386-unknown-cygwinw32"
-HS_PROG = hsc2hs$(exeext)
-endif
-
-ifeq "$(ghc_ge_504)" "NO"
-SRC_HC_OPTS += -package util
-endif
-
-# Note: Somehow we should pass $(exeext) here, but the history of changes used
-# for calling the C preprocessor via GHC has changed a few times, making a
-# clean solution impossible. So we revert to a hack in Main.hs...
-SRC_HC_OPTS += -Wall
-
-ifneq "$(HOSTPLATFORM)" "i386-unknown-mingw32"
-INSTALLED_SCRIPT_PROG = hsc2hs
-endif
-INPLACE_SCRIPT_PROG = hsc2hs-inplace
-
-ifeq "$(INSTALLING)" "1"
-TOP_PWD := $(prefix)
-SCRIPT_PROG = $(INSTALLED_SCRIPT_PROG)
-else
-TOP_PWD := $(FPTOOLS_TOP_ABS)
-SCRIPT_PROG = $(INPLACE_SCRIPT_PROG)
-endif
-
-ifeq "$(INSTALLING)" "1"
-ifeq "$(BIN_DIST)" "1"
-HSC2HS_BINDIR=$$\"\"libexecdir
-HSC2HS_DIR=$$\"\"libdir
-HSC2HS_EXTRA=
-else
-HSC2HS_BINDIR=$(libexecdir)
-HSC2HS_DIR=$(libdir)
-HSC2HS_EXTRA=--cc=$(bindir)/ghc-$(ProjectVersion)
-endif # BIN_DIST
-else
-HSC2HS_BINDIR=$(FPTOOLS_TOP_ABS)/$(CURRENT_DIR)
-HSC2HS_DIR=$(FPTOOLS_TOP_ABS_PLATFORM)/$(CURRENT_DIR)
-
-ifeq "$(HOSTPLATFORM)" "i386-unknown-mingw32"
-extra_flags=$(addprefix --cflag=,$(filter-out -O,$(SRC_CC_OPTS)))
-endif
-
-HSC2HS_EXTRA="--cc=$(CC) --ld=$(CC) $(extra_flags) --cflag=-D__GLASGOW_HASKELL__=$(ProjectVersionInt) -I$(FPTOOLS_TOP_ABS_PLATFORM)/$(INCLUDE_DIR)"
-endif
-
-$(SCRIPT_PROG) : Makefile
-$(INSTALLED_SCRIPT_PROG) : $(TOP)/mk/config.mk
-
-SCRIPT_SUBST_VARS = HSC2HS_BINDIR HSC2HS_DIR HS_PROG HSC2HS_EXTRA
-
-SCRIPT_OBJS=hsc2hs.sh
-INTERP=$(SHELL)
-
-ifneq "$(TARGETPLATFORM)" "i386-unknown-mingw32"
-INSTALL_SCRIPTS += $(SCRIPT_PROG)
-INSTALL_LIBEXECS += $(HS_PROG)
-else
-INSTALL_PROGS += $(HS_PROG)
-endif
-
-override datadir=$(libdir)
-INSTALL_DATAS += template-hsc.h
-
-# -----------------------------------------------------------------------------
-# don't recurse on 'make install'
-#
-ifeq "$(INSTALLING)" "1"
-all :: $(HS_PROG)
- $(MAKE) INSTALLING=0 BIN_DIST=0 $(MFLAGS) $@
-
-clean distclean maintainer-clean ::
- $(MAKE) INSTALLING=0 BIN_DIST=0 $(MFLAGS) $@
-endif
-
-include $(TOP)/mk/target.mk
diff --git a/ghc/utils/hsc2hs/Makefile.inc b/ghc/utils/hsc2hs/Makefile.inc
deleted file mode 100644
index 91ac818437..0000000000
--- a/ghc/utils/hsc2hs/Makefile.inc
+++ /dev/null
@@ -1,7 +0,0 @@
-ifeq "" "${MKDIR}"
-MKDIR:=$(shell pwd)
-#MKDIR:=$(PWD)
-else
-MKDIR:=$(patsubst %/$(notdir ${MKDIR}),%, ${MKDIR})
-endif
-include ${MKDIR}/Makefile.inc
diff --git a/ghc/utils/hsc2hs/Makefile.nhc98 b/ghc/utils/hsc2hs/Makefile.nhc98
deleted file mode 100644
index a35a0dc9e7..0000000000
--- a/ghc/utils/hsc2hs/Makefile.nhc98
+++ /dev/null
@@ -1,48 +0,0 @@
-include Makefile.inc
-
-OBJDIR = ${BUILDDIR}/obj/hsc2hs
-TARGET = ${DST}/hsc2hs$(EXE)
-
-SRCS = Main.hs
-FROMC = ../libraries/base/System/Console/GetOpt.$C \
- ../libraries/base/Data/List.$C \
- ../libraries/base/System/Cmd.$C
-
-ifeq "$(findstring ghc, ${HC})" "ghc"
-HFLAGS = $(shell $(LOCAL)fixghc $(GHCSYM) -package base -package lang )
-export HFLAGS
-endif
-ifeq "$(findstring hbc, ${HC})" "hbc"
-HFLAGS =
-export HFLAGS
-endif
-ifeq "$(findstring nhc98, ${HC})" "nhc98"
-HFLAGS = -package base +CTS -H4M -CTS
-export HFLAGS
-endif
-
-all: $(TARGET)
-install: $(TARGET)
-cfiles: cleanC $(SRCS)
- $(HMAKE) -hc=$(LOCAL)nhc98 -package base -C Main.hs
-clean:
- -rm -f *.hi *.o $(OBJDIR)/*.o
-cleanC: clean
- -rm -f *.hc *.c
-realclean: clean cleanC
- -rm -f $(OBJDIR)/Main$(EXE)
-
-$(TARGET): $(OBJDIR) $(SRCS)
- $(HMAKE) -hc=$(HC) Main -d$(OBJDIR) -DBUILD_NHC \
- $(shell echo "${BUILDOPTS}") $(HFLAGS) $(CYGFLAG)
- mv $(OBJDIR)/Main$(EXE) $(TARGET)
- $(STRIP) $(TARGET)
-
-$(OBJDIR):
- mkdir -p $(OBJDIR)
-
-fromC: $(OBJDIR)
- cp $(FROMC) .
- $(LOCAL)nhc98 -cpp -o $(TARGET) -d$(OBJDIR) *.$C
- $(STRIP) $(TARGET)
-
diff --git a/ghc/utils/hsc2hs/hsc2hs.sh b/ghc/utils/hsc2hs/hsc2hs.sh
deleted file mode 100644
index fe00d45036..0000000000
--- a/ghc/utils/hsc2hs/hsc2hs.sh
+++ /dev/null
@@ -1,13 +0,0 @@
-
-tflag="--template=$HSC2HS_DIR/template-hsc.h"
-for arg do
- case "$arg" in
- -c*) HSC2HS_EXTRA=;;
- --cc=*) HSC2HS_EXTRA=;;
- -t*) tflag=;;
- --template=*) tflag=;;
- --) break;;
- esac
-done
-
-$HSC2HS_BINDIR/$HS_PROG $tflag $HSC2HS_EXTRA "$@"
diff --git a/ghc/utils/hsc2hs/template-hsc.h b/ghc/utils/hsc2hs/template-hsc.h
deleted file mode 100644
index bdc34eda78..0000000000
--- a/ghc/utils/hsc2hs/template-hsc.h
+++ /dev/null
@@ -1,105 +0,0 @@
-#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409
-#include <Rts.h>
-#endif
-#include <HsFFI.h>
-
-#include <stddef.h>
-#include <string.h>
-#include <stdio.h>
-#include <stdarg.h>
-#include <ctype.h>
-
-#ifndef offsetof
-#define offsetof(t, f) ((size_t) &((t *)0)->f)
-#endif
-
-#if __NHC__
-#define hsc_line(line, file) \
- printf ("# %d \"%s\"\n", line, file);
-#else
-#define hsc_line(line, file) \
- printf ("{-# LINE %d \"%s\" #-}\n", line, file);
-#endif
-
-#define hsc_const(x) \
- if ((x) < 0) \
- printf ("%ld", (long)(x)); \
- else \
- printf ("%lu", (unsigned long)(x));
-
-#define hsc_const_str(x) \
- { \
- const char *s = (x); \
- printf ("\""); \
- while (*s != '\0') \
- { \
- if (*s == '"' || *s == '\\') \
- printf ("\\%c", *s); \
- else if (*s >= 0x20 && *s <= 0x7E) \
- printf ("%c", *s); \
- else \
- printf ("\\%d%s", \
- (unsigned char) *s, \
- s[1] >= '0' && s[1] <= '9' ? "\\&" : ""); \
- ++s; \
- } \
- printf ("\""); \
- }
-
-#define hsc_type(t) \
- if ((t)(int)(t)1.4 == (t)1.4) \
- printf ("%s%d", \
- (t)(-1) < (t)0 ? "Int" : "Word", \
- sizeof (t) * 8); \
- else \
- printf ("%s", \
- sizeof (t) > sizeof (double) ? "LDouble" : \
- sizeof (t) == sizeof (double) ? "Double" : \
- "Float");
-
-#define hsc_peek(t, f) \
- printf ("(\\hsc_ptr -> peekByteOff hsc_ptr %ld)", (long) offsetof (t, f));
-
-#define hsc_poke(t, f) \
- printf ("(\\hsc_ptr -> pokeByteOff hsc_ptr %ld)", (long) offsetof (t, f));
-
-#define hsc_ptr(t, f) \
- printf ("(\\hsc_ptr -> hsc_ptr `plusPtr` %ld)", (long) offsetof (t, f));
-
-#define hsc_offset(t, f) \
- printf("(%ld)", (long) offsetof (t, f));
-
-#define hsc_size(t) \
- printf("(%ld)", (long) sizeof(t));
-
-#define hsc_enum(t, f, print_name, x) \
- print_name; \
- printf (" :: %s\n", #t); \
- print_name; \
- printf (" = %s ", #f); \
- if ((x) < 0) \
- printf ("(%ld)\n", (long)(x)); \
- else \
- printf ("%lu\n", (unsigned long)(x));
-
-#define hsc_haskellize(x) \
- { \
- const char *s = (x); \
- int upper = 0; \
- if (*s != '\0') \
- { \
- putchar (tolower (*s)); \
- ++s; \
- while (*s != '\0') \
- { \
- if (*s == '_') \
- upper = 1; \
- else \
- { \
- putchar (upper ? toupper (*s) : tolower (*s)); \
- upper = 0; \
- } \
- ++s; \
- } \
- } \
- }
diff --git a/ghc/utils/hstags/Makefile b/ghc/utils/hstags/Makefile
deleted file mode 100644
index 981bafd897..0000000000
--- a/ghc/utils/hstags/Makefile
+++ /dev/null
@@ -1,70 +0,0 @@
-TOP=../..
-include $(TOP)/mk/boilerplate.mk
-include $(TOP)/mk/version.mk
-
-# Note: might be overridden from cmd-line (see install rule below)
-INSTALLING=0
-
-C_PROG=hstags-help
-SRC_CC_OPTS += -O
-
-SCRIPT_PROG=hstags
-SCRIPT_OBJS=hstags.prl
-
-SCRIPT_SUBST_VARS=\
- INSTALLING \
- TOP_PWD \
- ProjectVersionInt
-
-ifneq "$(BIN_DIST)" "1"
-SCRIPT_SUBST_VARS += libdir libexecdir DEFAULT_TMPDIR
-endif
-
-#
-# The hstags script is configured with different
-# set of config variables, depending on whether it
-# is to be installed or not.
-#
-ifeq "$(INSTALLING)" "1"
-TOP_PWD := $(prefix)
-ifeq "$(BIN_DIST)" "1"
-SCRIPT_PREFIX_FILES += prefix.txt
-endif
-else
-TOP_PWD := $(FPTOOLS_TOP_ABS)
-HSP_IMPORTS:="$(TOP_PWD)/ghc/lib/ghc":"$(TOP_PWD)/ghc/lib/required":"$(TOP_PWD)/ghc/lib/glaExts":"$(TOP_PWD)/ghc/lib/concurrent"
-SCRIPT_SUBST_VARS += HSP_IMPORTS
-endif
-
-#
-# no INTERP: do *not* want #! script stuck on the front
-#
-# what's the deal? I'll add it for now (and perhaps pay for it later :-)
-# -- SOF
-INTERP=perl
-
-#
-# install setup
-#
-INSTALL_SCRIPTS+=$(SCRIPT_PROG)
-INSTALL_LIBEXECS=$(C_PROG)
-
-#
-# Before really installing the script, we have to
-# reconfigure it such that the paths it refers to,
-# point to the installed utils.
-#
-install ::
- @$(RM) $(SCRIPT_PROG)
- @$(MAKE) $(MFLAGS) INSTALLING=1 $(SCRIPT_PROG)
-
-include $(TOP)/mk/target.mk
-
-
-# Hack to re-create the in-situ build tree script after
-# having just installed it.
-#
-install ::
- @$(RM) $(SCRIPT_PROG)
- @$(MAKE) $(MFLAGS) BIN_DIST=0 $(SCRIPT_PROG)
-
diff --git a/ghc/utils/hstags/README b/ghc/utils/hstags/README
deleted file mode 100644
index b457ef125a..0000000000
--- a/ghc/utils/hstags/README
+++ /dev/null
@@ -1,10 +0,0 @@
-"hstags" is a relatively sophisticated program to produce Emacs TAGS
-files for Glasgow-Haskell-compilable programs. (It is "sophisticated"
-only in that it uses the GHC parser to find "interesting" things in
-the source files.)
-
-With GHC 2.01: doesn't work yet.
-
-A simpler alternative is Denis Howe's "fptags" script, which is
-distributed in the ghc/CONTRIB directory.
-
diff --git a/ghc/utils/hstags/hstags-help.c b/ghc/utils/hstags/hstags-help.c
deleted file mode 100644
index 92604876ff..0000000000
--- a/ghc/utils/hstags/hstags-help.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include <stdio.h>
-#include <string.h> /* for strlen */
-
-/* typedef enum { False, True } Boolean; */
-
-#define SKIP /* Algol-68 lives */
-
-main(argc,argv)
-int argc;
-char **argv;
-{
- unsigned line;
- FILE *srcf;
- int thisline = 0, lastline = 0, linestart = 0;
- char linebuff[1024];
-
- if(argc < 2)
- {
- fprintf(stderr,"usage: %s sourcefile",argv[0]);
- exit(1);
- }
-
- if((srcf=fopen(argv[1],"r")) == NULL)
- {
- fprintf(stderr,"can't read %s\n",argv[1]);
- exit(2);
- }
-
- *linebuff = '\0';
-
- while(scanf("%u",&line)!=EOF)
- {
- if(line != lastline)
- {
- while(thisline < line && !feof(srcf))
- {
- linestart+=strlen(linebuff);
- fgets(linebuff,1023,srcf);
- thisline++;
- }
-
- if(thisline >= line)
- {
- char *chpos;
- for(chpos = linebuff; *chpos != '=' && *chpos != '\n' && *chpos != '\0'; ++chpos)
- putchar(*chpos);
-
- if(*chpos == '=')
- putchar('=');
-
- printf("%c%d,%d\n",0177,line,linestart);
- }
- lastline = line;
- }
- }
-
- fclose(srcf);
- exit(0);
-}
diff --git a/ghc/utils/hstags/hstags.prl b/ghc/utils/hstags/hstags.prl
deleted file mode 100644
index 16e770bd8a..0000000000
--- a/ghc/utils/hstags/hstags.prl
+++ /dev/null
@@ -1,94 +0,0 @@
-#
-# To fully function, this script needs the following variables
-# set:
-#
-# INSTALLING
-# DEFAULT_TMPDIR
-# TOP_PWD
-# libdir
-# libexecdir
-# ProjectVersionInt
-# HSP_IMPORTS
-
-if ( $ENV{'TMPDIR'} ) { # where to make tmp file names
- $tmp = $ENV{'TMPDIR'} . "/$$.eht";
-} else {
- $tmp ="${DEFAULT_TMPDIR}/$$.eht";
- $ENV{'TMPDIR'} = ${DEFAULT_TMPDIR}; # set the env var as well
-}
-
-$TopPwd = "${TOP_PWD}"; # *Only* needed when using it in-situ (i.e., INSTALLING=0).
-$InstLibDirGhc = "${libdir}";
-$InstLibExecDirGhc = "${libexecdir}";
-
-$Unlit = ( $INSTALLING ?
- "${InstLibExecDirGhc}/unlit" :
- "${TopPwd}/ghc/utils/unlit/unlit" );
-# but this is re-set to "cat" (after options) if -cpp not seen
-$HsCpp = ( $INSTALLING ?
- "${InstLibDirGhc}/hscpp" :
- "${TopPwd}/ghc/utils/hscpp/hscpp" );
-$HsP = ( $INSTALLING ?
- "${InstLibExecDirGhc}/hsp" :
- "${TopPwd}/ghc/compiler/hsp" );
-$HsTagsHelp =
- ( $INSTALLING ?
- "${InstLibExecDirGhc}/hstags-help" :
- "${TopPwd}/ghc/utils/hstags/hstags-help" );
-
-$Verbose = 0;
-$Append = '>';
-$DoCpp = 0;
-$Cpp_opts = '';
-$HsP_opts = '';
-@Files = ();
-
-while ($ARGV[0] =~ /^-./) {
- $_ = shift(@ARGV);
- /^--/ && last;
- /^-v/ && ($Verbose = 1, next);
- /^-a$/ && ($Append = '>>', next);
- /^-fglasgow-exts/ && ($HsP_opts .= ' -N', next);
- /^-optP(.*)/ && ($Cpp_opts .= " $1", next);
- /^-[UDI]/ && ($Cpp_opts .= " $_", next);
- /^-cpp/ && ($DoCpp = 1, next);
- /^-/ && next; # ignore the rest
- push(@Files, $_);
-}
-
-$DoHsCpp = ( ! $DoCpp ) ? 'cat'
- : "$HsCpp -D__HASKELL1__=2 -D__GLASGOW_HASKELL__=$ProjectVersionInt $Cpp_opts";
-
-# to find Prelude.hi and friends.
-$HsP_opts .= ( $INSTALLING ?
- "-J${InstLibDirGhc}/imports" :
- ( '-J' . join(' -J',split(/:/,${HSP_IMPORTS})) ));
-
-open(STDOUT, "$Append TAGS") || die "can't create TAGS";
-
-foreach $f ( @ARGV ) {
- # if file is in a dir && we are CPPing, then we add its dir to the -I list.
- if ( $DoCpp && $f =~ /(.+)\/[^\/]+$/ ) {
- $Idir = "-I$1";
- } else {
- $Idir = '';
- }
-
- if ( $f =~ /\.lhs$/ ) {
- $ToDo = "$Unlit $f - | $DoHsCpp $Idir | $HsP -E $HsP_opts | $HsTagsHelp $f > $tmp";
- } else {
- $ToDo = "$DoHsCpp $Idir < $f | $HsP -E $HsP_opts | $HsTagsHelp $f > $tmp";
- }
- print STDERR "$ToDo\n" if $Verbose;
- system($ToDo);
- $return_val = $?;
- die "Fatal error $return_val\n" if $return_val != 0;
-
- ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
- $atime,$mtime, $ctime,$blksize,$blocks) = stat("$tmp");
-
- print STDOUT "\f\n$f,${size}\n";
- print STDOUT `cat $tmp`;
-}
-
-unlink $tmp;
diff --git a/ghc/utils/hstags/prefix.txt b/ghc/utils/hstags/prefix.txt
deleted file mode 100644
index b67c009c49..0000000000
--- a/ghc/utils/hstags/prefix.txt
+++ /dev/null
@@ -1,9 +0,0 @@
-#
-# hstags - generating a tags file from Haskell source
-#
-# To use the script on your system, the following variable
-# needs to be set (and uncommented!), if it hasn't already
-# been set above:
-#
-#$libdir='/local/fp/lib/sparc-sun-sunos4/ghc-2.02';
-#
diff --git a/ghc/utils/parallel/AVG.pl b/ghc/utils/parallel/AVG.pl
deleted file mode 100644
index 9ec42aee2f..0000000000
--- a/ghc/utils/parallel/AVG.pl
+++ /dev/null
@@ -1,108 +0,0 @@
-#!/usr/local/bin/perl
-# (C) Hans Wolfgang Loidl, October 1995
-#############################################################################
-# Time-stamp: <Thu Oct 26 1995 18:30:54 Stardate: [-31]6498.64 hwloidl>
-#
-# Usage: AVG [options] <gr-file>
-#
-# A quich hack to get avg runtimes of different spark sites. Similar to SPLIT.
-#
-# Options:
-# -s <list> ... a perl list of spark names; the given <gr-file> is scanned
-# for each given name in turn and granularity graphs are
-# generated for each of these sparks
-# -O ... use gr2RTS and RTS2gran instead of gran-extr;
-# this generates fewer output files (only granularity graphs)
-# but should be faster and far less memory consuming
-# -h ... help; print this text.
-# -v ... verbose mode.
-#
-#############################################################################
-
-require "getopts.pl";
-
-&Getopts('hvOs:');
-
-do process_options();
-
-if ( $opt_v ) { do print_verbose_message(); }
-
-# ---------------------------------------------------------------------------
-# Init
-# ---------------------------------------------------------------------------
-
-foreach $s (@sparks) {
- # extract END events for this spark-site
- open (GET,"cat $input | tf -s $s | avg-RTS") || die "!$\n";
-}
-
-exit 0;
-
-exit 0;
-
-# -----------------------------------------------------------------------------
-
-sub process_options {
-
- if ( $opt_h ) {
- open(ME,$0) || die "Can't open myself ($0): $!\n";
- $n = 0;
- while (<ME>) {
- last if $_ =~ /^$/;
- print $_;
- $n++;
- }
- close(ME);
- exit ;
- }
-
- if ( $opt_s ) {
- $opt_s =~ s/[\(\)\[\]]//g;
- @sparks = split(/[,;. ]+/, $opt_s);
- } else {
- @sparks = ( 3, 4, 5, 6, 7, 8, 11, 12, 13, 14, 15);
- }
-
- if ( $#ARGV != 0 ) {
- print "Usage: $0 [options] <gr-file>\n;";
- print "Use -h option to get details\n";
- exit 1;
- }
-
- $gr_file = $ARGV[0];
- ($basename = $gr_file) =~ s/\.gr//;
- $rts_file = $basename . ".rts"; # "RTS";
- $gran_file = "g.ps"; # $basename . ".ps";
- #$rts_file = $gr_file;
- #$rts_file =~ s/\.gr/.rts/g;
-
- if ( $opt_o ) {
- $va_file = $opt_o;
- $va_dvi_file = $va_file;
- $va_dvi_file =~ s/\.tex/.dvi/g;
- $va_ps_file = $va_file;
- $va_ps_file =~ s/\.tex/.ps/g;
- } else {
- $va_file = "va.tex";
- $va_dvi_file = "va.dvi";
- $va_ps_file = "va.ps";
- }
-
- if ( $opt_t ) {
- $template_file = $opt_t;
- } else {
- $template_file = "TEMPL";
- }
-
- $tmp_file = ",t";
-}
-
-# -----------------------------------------------------------------------------
-
-sub print_verbose_message {
- print "Sparks: (" . join(',',@sparks) . ")\n";
- print "Files: .gr " . $gr_file . " template " . $template_file .
- " va " . $va_file . "\n";
-}
-
-# -----------------------------------------------------------------------------
diff --git a/ghc/utils/parallel/GrAnSim.el b/ghc/utils/parallel/GrAnSim.el
deleted file mode 100644
index 49330a9749..0000000000
--- a/ghc/utils/parallel/GrAnSim.el
+++ /dev/null
@@ -1,432 +0,0 @@
-;; ---------------------------------------------------------------------------
-;; Time-stamp: <Tue Jun 11 1996 18:01:28 Stardate: [-31]7643.54 hwloidl>
-;;
-;; Mode for GrAnSim profiles
-;; ---------------------------------------------------------------------------
-
-(defvar gransim-auto-hilit t
- "Automagically invoke hilit19.")
-
-(defvar grandir (getenv "GRANDIR")
- "Root of the GrAnSim installation. Executables should be in grandir/bin")
-
-(defvar hwl-hi-node-face 'highlight
- "Face to be used for specific highlighting of a node")
-
-(defvar hwl-hi-thread-face 'holiday-face
- "Face to be used for specific highlighting of a thread")
-
-;; ---------------------------------------------------------------------------
-
-(setq exec-path (cons (concat grandir "/bin") exec-path))
-
-;; Requires hilit19 for highlighting parts of a GrAnSim profile
-(cond (window-system
- (setq hilit-mode-enable-list '(not text-mode)
- hilit-background-mode 'light
- hilit-inhibit-hooks nil
- hilit-inhibit-rebinding nil);
-
- (require 'hilit19)
-))
-
-
-(setq auto-mode-alist
- (append '(("\\.gr" . gr-mode))
- auto-mode-alist))
-
-(defvar gr-mode-map (make-keymap "GrAnSim Profile Mode SetUp")
- "Keymap for GrAnSim profiles.")
-
-; (fset 'GrAnSim-mode-fiddly gr-mode-map)
-
-;(define-key gr-mode-map [wrap]
-; '("Wrap lines" . hwl-wrap))
-
-;(define-key gr-mode-map [truncate]
-; '("Truncate lines" . hwl-truncate))
-
-;(define-key global-map [C-S-down-mouse-1] 'GrAnSim-mode-fiddly)
-
-;(modify-frame-parameters (selected-frame)
-; '((menu-bar-lines . 2)))
-
-;(define-key-after gr-mode-map [menu-bar GrAnSim]
-; '("GrAnSim" . (make-sparse-keymap "GrAnSim")) 'edit)
-
-;(defvar GrAnSim-menu-map (make-sparse-keymap "GrAnSim"))
-
-(define-key gr-mode-map [menu-bar GrAnSim]
- (cons "GrAnSim" (make-sparse-keymap "GrAnSim"))) ; 'edit)
-
-(define-key gr-mode-map [menu-bar GrAnSim wrap]
- '("Wrap lines" . hwl-wrap))
-
-(define-key gr-mode-map [menu-bar GrAnSim truncate]
- '("Truncate lines" . hwl-truncate))
-
-(define-key gr-mode-map [menu-bar GrAnSim toggle-truncate]
- '("Toggle truncate/wrap" . hwl-toggle-truncate-wrap) )
-
-(define-key gr-mode-map [menu-bar GrAnSim hi-clear]
- '("Clear highlights" . hwl-hi-clear))
-
-(define-key gr-mode-map [menu-bar GrAnSim hi-thread]
- '("Highlight specific Thread" . hwl-hi-thread))
-
-(define-key gr-mode-map [menu-bar GrAnSim hi-node]
- '("Highlight specific Node" . hwl-hi-node))
-
-(define-key gr-mode-map [menu-bar GrAnSim highlight]
- '("Highlight buffer" . hilit-rehighlight-buffer))
-
-(define-key gr-mode-map [menu-bar GrAnSim narrow-event]
- '("Narrow to Event" . hwl-narrow-to-event))
-
-(define-key gr-mode-map [menu-bar GrAnSim narrow-thread]
- '("Narrow to Thread" . hwl-narrow-to-thread))
-
-(define-key gr-mode-map [menu-bar GrAnSim narrow-pe]
- '("Narrow to PE" . hwl-narrow-to-pe))
-
-
-
-; (define-key global-map [C-S-down-mouse-1] 'GrAnSim-mode-fiddly)
-
-
-(defvar gr-mode-hook nil
- "Invoked in gr mode.")
-
-
-;;; Ensure new buffers won't get this mode if default-major-mode is nil.
-;(put 'gr-mode 'mode-class 'special)
-
-(defun gr-mode ()
- "Major mode for GrAnSim profiles."
- (interactive)
- (kill-all-local-variables)
- ;(use-local-map gr-mode-map)
- (use-local-map gr-mode-map) ; This provides the local keymap.
- (setq major-mode 'gr-mode)
- (setq mode-name "GrAnSim Profile Mode")
- (setq local-abbrev-table text-mode-abbrev-table)
- (set-syntax-table text-mode-syntax-table)
- (setq truncate-lines t) ; do not wrap lines (truncates END lines!)
- (auto-save-mode -1)
- ;(setq buffer-offer-save t)
- (run-hooks 'gr-mode-hook))
-
-;; same as mh-make-local-vars
-(defun gr-make-local-vars (&rest pairs)
- ;; Take VARIABLE-VALUE pairs and make local variables initialized to the
- ;; value.
- (while pairs
- (make-variable-buffer-local (car pairs))
- (set (car pairs) (car (cdr pairs)))
- (setq pairs (cdr (cdr pairs)))))
-
-;; ----------------------------------------------------------------------
-;; Highlighting stuff (currently either hilit19 or fontlock is used)
-;; ----------------------------------------------------------------------
-
-(hilit-set-mode-patterns
- 'gr-mode
- '(;; comments
- ("--.*$" nil comment)
- ("\\+\\+.*$" nil comment)
- ;; hilight important bits in the header
- ("^Granularity Simulation for \\(.*\\)$" 1 glob-struct)
- ("^PEs[ \t]+\\([0-9]+\\)" 1 decl)
- ("^Latency[ \t]+\\([0-9]+\\)" 1 decl)
- ("Arith[ \t]+\\([0-9]+\\)" 1 decl)
- ("Branch[ \t]+\\([0-9]+\\)" 1 decl)
- ("Load[ \t]+\\([0-9]+\\)" 1 decl)
- ("Store[ \t]+\\([0-9]+\\)" 1 decl)
- ("Float[ \t]+\\([0-9]+\\)" 1 decl)
- ("Alloc[ \t]+\\([0-9]+\\)" 1 decl)
- ;; hilight PE number and time in each line
- ("^PE[ \t]+\\([0-9]+\\)" 1 glob-struct)
- (" \\[\\([0-9]+\\)\\]:" 1 define)
- ;; in this case the events are the keyword
- ; ("\\(FETCH\\|REPLY\\|RESUME\\|RESUME(Q)\\|SCHEDULE\\|SCHEDULE(Q)\\|BLOCK\\|STEALING\\|STOLEN\\|STOLEN(Q)\\)[ \t]" 1 keyword)
- ("\\(FETCH\\|BLOCK\\)[ \t]" 1 label)
- ("\\(REPLY\\|RESUME(Q)\\|SCHEDULE(Q)\\|STOLEN(Q)\\)[ \t]" 1 named-param)
- ("\\(RESUME\\|SCHEDULE\\|STOLEN\\)[ \t]" 1 msg-quote)
- ("\\(STEALING\\)[ \t]" 1 keyword)
- ("\\(START\\|END\\)[ \t]" 1 defun)
- ("\\(SPARK\\|SPARKAT\\|USED\\|PRUNED\\)[ \t]" 1 crossref)
- ("\\(EXPORTED\\|ACQUIRED\\)[ \t]" 1 string)
- ;; especially interesting are END events; hightlight runtime etc
- (",[ \t]+RT[ \t]+\\([0-9]+\\)" 1 define)
- ;; currently unused but why not?
- ("\"" ".*\"" string))
-)
-
-;; --------------------------------------------------------------------------
-;; Own fcts for selective highlighting
-;; --------------------------------------------------------------------------
-
-(defun hwl-hi-node (node)
- "Highlight node in GrAnSim profile."
- (interactive "sNode (hex): ")
- (save-excursion
- (let* ( (here (point))
- (len (length node)) )
- (goto-char (point-min))
- (while (search-forward node nil t)
- (let* ( (end (point))
- (start (- end len)) )
- (add-text-properties start end `(face ,hwl-hi-node-face))
- )
- ) )
- )
-)
-
-(defun hwl-hi-thread (task)
- "Highlight task in GrAnSim profile."
- (interactive "sTask: ")
- (save-excursion
- (let* ( (here (point))
- (len (length task))
- (se-str (format "[A-Z)]\\s-+%s\\(\\s-\\|,\\)" task))
- )
- (goto-char (point-min))
- (while (re-search-forward se-str nil t)
- (let ( (c (current-column)) )
- (if (and (> c 10) (< c 70))
- (let* ( (end (1- (point)))
- (start (- end len)) )
- (add-text-properties start end `(face ,hwl-hi-thread-face))
- ) ) )
- ) )
- )
-)
-
-(defun hwl-hi-line ()
- "Highlight the current line."
- (interactive)
- (save-excursion
- (beginning-of-line)
- (let ( (beg (point)) )
- (end-of-line)
- (add-text-properties beg (point) '(face highlight))
- )
- )
-)
-
-(defun hwl-unhi-line ()
- "Unhighlight the current line."
- (interactive)
- (save-excursion
- (beginning-of-line)
- (let ( (beg (point)) )
- (end-of-line)
- (add-text-properties beg (point) '(face nil))
- )
- )
-)
-
-; Doesn't work yet
-(defun hwl-hi-from-to (from to)
- "Highlight region between two timestamps."
- (interactive "nFrom: \nnTo:")
- (save-excursion
- (let* ( (here (point))
- (now 0)
- start end
- (separator '"+++++")
- )
- (goto-char (point-min))
- ; (re-search-forward REGEXP)
- (search-forward separator nil t)
- (forward-line)
- (while (< now from)
- (beginning-of-line)
- (forward-line)
- (forward-char 7)
- (setq beg (point))
- (search-forward "]")
- (setq time-str (buffer-substring beg (- (point) 2)))
- (setq now (string-to-number time-str))
- )
- (if (< now from)
- nil
- (setq start (point))
- (while (< now to)
- (beginning-of-line)
- (forward-line)
- (forward-char 7)
- (setq beg (point))
- (search-forward "]")
- (setq time-str (buffer-substring beg (- (point) 2)))
- (setq now (string-to-number time-str))
- )
- (if (< now to)
- nil
- (setq end (point))
- (add-text-properties start end '(face paren-match-face))
- )
- )
- ) ; let
- ) ; excursion
-)
-
-(defun hwl-hi-clear ()
- (interactive)
- (let ( (start (point-min) )
- (end (point-max)) )
- (remove-text-properties start end '(face nil))
- )
-)
-
-;; --------------------------------------------------------------------------
-;; Misc Elisp functions
-;; --------------------------------------------------------------------------
-
-(defun hwl-wrap ()
- (interactive)
- (setq truncate-lines nil)
- (hilit-recenter nil)
-)
-
-(defun hwl-truncate ()
- (interactive)
- (setq truncate-lines t)
- (hilit-recenter nil)
-)
-
-(defun hwl-toggle-truncate-wrap ()
- (interactive)
- (if truncate-lines (setq truncate-lines nil)
- (setq truncate-lines t))
- (hilit-recenter nil)
-)
-
-(defun hwl-narrow-to-pe (pe)
- (interactive "nPE: ")
- (hwl-narrow 1 pe "")
-)
-
-(defun hwl-narrow-to-thread (thread)
- (interactive "sThread: ")
- (hwl-narrow 2 thread "")
-)
-
-(defun hwl-narrow-to-event (event)
- (interactive "sEvent: ")
- (hwl-narrow 3 0 event)
-)
-
-(defun hwl-narrow (mode id str)
- ( let* ((outbuffer (get-buffer-create "*GrAnSim Narrowed*"))
- ;(from (beginning-of-buffer))
- ;(to (end-of-buffer))
- ;(to (point)) ; (region-end))
- ;(text (buffer-substring from to)) ; contains text in region
- (w (selected-window))
- ;(nh 5) ; height of new window
- ;(h (window-height w)) ; height of selcted window
- ;(h1 (if (<= h nh) (- h 1) (- h nh))) ; height of old window
- (w1 (get-buffer-window outbuffer 'visible))
-
- (infile (buffer-file-name)) ; or
- (inbuffer (current-buffer))
- (command "tf")
- ;(mode_opt (cond ((eq mode 1) "-p")
- ; ((eq mode 2) "-t")
- ; ((eq mode 3) "-e")
- ; (t "-v")))
- )
- (if w1 (message "Window *GrAnSim Narrowed* already visible")
- (split-window w nil nil))
- (switch-to-buffer-other-window outbuffer)
- (erase-buffer)
- (setq truncate-lines t)
- (gr-mode)
- ;(beginning-of-buffer)
- ;(set-mark)
- ;(end-of-buffer)
- ;(delete-region region-beginning region-end)
- (cond ((eq mode 1)
- ;(message (format "Narrowing to Processor %d" id))
- (call-process command nil outbuffer t "-p" (format "%d" id) infile ))
- ((eq mode 2)
- ;(message (format "Narrowing to Thread %d" id))
- (call-process command nil outbuffer t "-t" (format "%s" id) infile ))
- ((eq mode 3)
- ;(message (format "Narrowing to Event %s" str))
- (call-process command nil outbuffer t "-e" str infile ))
- )
- )
-)
-
-(defun hwl-command-on-buffer (prg opts file)
- (interactice "CProgram:\nsOptions:\nfFile:")
- ( let* ((outbuffer (get-buffer-create "*GrAnSim Command*"))
- (from (beginning-of-buffer))
- (to (end-of-buffer))
- ;(to (point)) ; (region-end))
- ;(text (buffer-substring from to)) ; contains text in region
- (w (selected-window))
- ;(nh 5) ; height of new window
- ;(h (window-height w)) ; height of selcted window
- ;(h1 (if (<= h nh) (- h 1) (- h nh))) ; height of old window
- (w1 (get-buffer-window outbuffer 'visible))
-
- (infile (buffer-file-name)) ; or
- (inbuffer (current-buffer))
- ;(command "tf")
- ;(mode_opt (cond ((eq mode 1) "-p")
- ; ((eq mode 2) "-t")
- ; ((eq mode 3) "-e")
- ; (t "-v")))
- )
- (if w1 (message "Window *GrAnSim Command* already visible")
- (split-window w nil nil))
- (switch-to-buffer-other-window outbuffer)
- (erase-buffer)
- (setq truncate-lines t)
- (gr-mode)
- (call-process prg nil outbuffer opts file)
- )
-)
-
-;; ToDo: Elisp Fcts for calling scripts like gr3ps etc
-
-(define-key gr-mode-map "\C-ct" 'hwl-truncate)
-(define-key gr-mode-map "\C-cw" 'hwl-wrap)
-(define-key gr-mode-map "\C-ch" 'hilit-rehighlight-buffer)
-(define-key gr-mode-map "\C-cp" 'hwl-narrow-to-pe)
-(define-key gr-mode-map "\C-ct" 'hwl-narrow-to-thread)
-(define-key gr-mode-map "\C-ce" 'hwl-narrow-to-event)
-(define-key gr-mode-map "\C-c\C-e" '(lambda () (hwl-narrow-to-event "END")))
-(define-key gr-mode-map "\C-c " 'hwl-toggle-truncate-wrap)
-(define-key gr-mode-map "\C-cN" 'hwl-hi-node)
-(define-key gr-mode-map "\C-cT" 'hwl-hi-thread)
-(define-key gr-mode-map "\C-c\C-c" 'hwl-hi-clear)
-
-;; ---------------------------------------------------------------------------
-;; Mode for threaded C files
-;; ---------------------------------------------------------------------------
-
-(setq auto-mode-alist
- (append '(("\\.hc" . hc-mode))
- auto-mode-alist))
-
-(define-derived-mode hc-mode c-mode "hc Mode"
- "Derived mode for Haskell C files."
-)
-
-(hilit-set-mode-patterns
- 'hc-mode
- '(
- ("\\(GRAN_FETCH\\|GRAN_RESCHEDULE\\|GRAN_FETCH_AND_RESCHEDULE\\|GRAN_EXEC\\|GRAN_YIELD\\)" 1 keyword)
- ("FB_" nil defun)
- ("FE_" nil define)
- ("__STG_SPLIT_MARKER" nil msg-note)
- ("^.*_ITBL.*$" nil defun)
- ("^\\(I\\|E\\|\\)FN.*$" nil define)
- )
-)
-
-; (define-key global-map [S-pause] 'hc-mode)
diff --git a/ghc/utils/parallel/Makefile b/ghc/utils/parallel/Makefile
deleted file mode 100644
index 094c5cbba1..0000000000
--- a/ghc/utils/parallel/Makefile
+++ /dev/null
@@ -1,49 +0,0 @@
-TOP=../..
-include $(TOP)/mk/boilerplate.mk
-
-PERL_PROGS = \
- grs2gr gr2qp qp2ps ghc-fool-sort ghc-unfool-sort gr2pe gr2java \
- qp2ap gr2RTS RTS2gran gran-extr gp-ext-imp tf avg-RTS SPLIT \
- AVG SN get_SN sn_filter ps-scale-y
-
-
-BASH_PROGS = gr2ps gr2jv gr2ap gr2gran
-
-#
-# One rule fits all, not particularly selective.
-#
-$(PERL_PROGS) : $(patsubst %,%.pl,$(PERL_PROGS))
-$(BASH_PROGS) : $(patsubst %,%.bash,$(BASH_PROGS))
-
-
-all :: $(PERL_PROGS) $(BASH_PROGS)
-
-$(PERL_PROGS) :
- $(RM) $@
- @echo Creating $@...
- @echo "#!"$(PERL) > $@
- @cat $@.pl >> $@
- @chmod a+x $@
-
-$(BASH_PROGS) :
- $(RM) $@
- @echo Creating $@...
- @echo "#!"$(BASH) > $@
- @cat $@.bash >> $@
- @chmod a+x $@
-
-#
-# You'll only get this with Parallel Haskell or
-# GranSim..
-#
-ifeq "$(BuildingParallel)" "YES"
-INSTALL_SCRIPTS += $(BASH_PROGS) $(PERL_PROGS)
-else
-ifeq "$(BuildingGranSim)" "YES"
-INSTALL_SCRIPTS += $(BASH_PROGS) $(PERL_PROGS)
-endif
-endif
-
-CLEAN_FILES += $(BASH_PROGS) $(PERL_PROGS)
-
-include $(TOP)/mk/target.mk
diff --git a/ghc/utils/parallel/RTS2gran.pl b/ghc/utils/parallel/RTS2gran.pl
deleted file mode 100644
index 32012afac8..0000000000
--- a/ghc/utils/parallel/RTS2gran.pl
+++ /dev/null
@@ -1,684 +0,0 @@
-#!/usr/local/bin/perl
-##############################################################################
-# Time-stamp: <Mon May 20 1996 17:22:45 Stardate: [-31]7533.41 hwloidl>
-#
-# Usage: RTS2gran <RTS-file>
-#
-# Options:
-# -t <file> ... use <file> as template file (<,> global <.> local template)
-# -p <file> ... use <file> as gnuplot .gp file (default: gran.gp)
-# -x <x-size> ... of gnuplot graph
-# -y <y-size> ... of gnuplot graph
-# -n <n> ... use <n> as number of PEs in title
-# -h ... help; print this text.
-# -v ... verbose mode.
-#
-##############################################################################
-
-# ----------------------------------------------------------------------------
-# Command line processing and initialization
-# ----------------------------------------------------------------------------
-
-$gran_dir = $ENV{'GRANDIR'};
-if ( $gran_dir eq "" ) {
- print STDERR "RTS2gran: Warning: Env variable GRANDIR is undefined\n";
-}
-
-push(@INC, $gran_dir, $gran_dir . "/bin");
-# print STDERR "INC: " . join(':',@INC) . "\n";
-
-require "getopts.pl";
-require "template.pl"; # contains read_template for parsing template file
-require "stats.pl"; # statistics package with corr and friends
-
-&Getopts('hvt:p:x:y:n:Y:Z:');
-
-$OPEN_INT = 1;
-$CLOSED_INT = 0;
-
-do process_options();
-
-if ( $opt_v ) {
- do print_verbose_message ();
-}
-
-# ----------------------------------------------------------------------------
-# The real thing
-# ----------------------------------------------------------------------------
-
-$max_y = &pre_process($input);
-
-open(INPUT,"<$input") || die "Couldn't open input file $input";
-open(OUT_CUMU,">$cumulat_rts_file_name") || die "Couldn't open output file $cumulat_rts_file_name";
-open(OUT_CUMU0,">$cumulat0_rts_file_name") || die "Couldn't open output file $cumulat0_rts_file_name";
-
-#do skip_header();
-
-$tot_total_rt = 0;
-$tot_rt = 0;
-$count = 0;
-$last_rt = 0;
-$last_x = 0;
-$last_y = ($logscale{"'g'"} ne "") ? 1 : 0;
-
-$line_no = 0;
-while (<INPUT>) {
- $line_no++;
- next if /^--/; # Comment lines start with --
- next if /^\s*$/; # Skip empty lines
- $rt = $1 if /^(\d+)/;
- $count++;
-
- if ( $opt_D ) {
- print STDERR "Error @ line $line_no: RTS file not sorted!\n";
- }
-
- #push(@all_rts,$rt);
- $sum_rt += $rt;
-
- $index = do get_index_open_int($rt,@exec_times);
- $exec_class[$index]++;
-
- if ( $last_rt != $rt ) {
- print OUT_CUMU "$rt \t" . int($last_y/$max_y) . "\n";
- print OUT_CUMU0 "$rt \t$last_y\n";
- print OUT_CUMU "$rt \t" . int($count/$max_y) . "\n";
- print OUT_CUMU0 "$rt \t$count\n";
- $last_x = $rt;
- $last_y = $count;
- }
-
- $last_rt = $rt;
-}
-print OUT_CUMU "$rt \t" . int($last_y/$max_y) . "\n";
-print OUT_CUMU0 "$rt \t$last_y\n";
-print OUT_CUMU "$rt \t" . int($count/$max_y) . "\n";
-print OUT_CUMU0 "$rt \t$count\n";
-
-close OUT_CUMU;
-close OUT_CUMU0;
-
-$tot_tasks = $count; # this is y-max in cumulat graph
-$max_rt = $rt; # this is x-max in cumulat graph
-
-$max_rt_class = &list_max(@exec_class);
-
-do write_data($gran_file_name, $OPEN_INT, $logscale{"'g'"}, $#exec_times+1,
- @exec_times, @exec_class);
-
-# ----------------------------------------------------------------------------
-# Run GNUPLOT over the data files and create figures
-# ----------------------------------------------------------------------------
-
-do gnu_plotify($gp_file_name);
-
-# ----------------------------------------------------------------------------
-
-if ( $max_y != $tot_tasks ) {
- if ( $pedantic ) {
- die "ERROR: pre-processed number of tasks ($max_y) does not match computed one ($tot_tasks)\n";
- } else {
- print STDERR "Warning: pre-processed number of tasks ($max_y) does not match computed one ($tot_tasks)\n" if $opt_v;
- }
-}
-
-exit 0;
-
-# ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-# ToDo: Put these routines into an own package
-# ----------------------------------------------------------------------------
-# Basic Operations on the intervals
-# ----------------------------------------------------------------------------
-
-sub get_index_open_int {
- local ($value,@list) = @_;
- local ($index,$right);
-
- # print "get_index: searching for index of" . $value;
- # print " in " . join(':',@list);
-
- $index = 0;
- $right = $list[$index];
- while ( ($value >= $right) && ($index < $#list) ) {
- $index++;
- $right = $list[$index];
- }
-
- return ( ($index == $#list) && ($value > $right) ) ? $index+1 : $index;
-}
-
-# ----------------------------------------------------------------------------
-
-sub get_index_closed_int {
- local ($value,@list) = @_;
- local ($index,$right);
-
- if ( ($value < $list[0]) || ($value > $list[$#list]) ) {
- return ( -1 );
- }
-
- $index = 0;
- $left = $list[$index];
- while ( ($left <= $value) && ($index < $#list) ) {
- $index++;
- $left = $list[$index];
- }
- return ( $index-1 );
-}
-
-# ----------------------------------------------------------------------------
-# Write operations
-# ----------------------------------------------------------------------------
-
-sub write_data {
- local ($file_name, $open_int, $logaxes, $n, @rest) = @_;
- local (@times) = splice(@rest,0,$n);
- local (@class) = @rest;
-
- open(GRAN,">$file_name") || die "Couldn't open file $file_name for output";
-
- if ( $open_int == $OPEN_INT ) {
-
- for ($i=0,
- $left = ( index($logaxes,"x") != -1 ? int($times[0]/2) : 0 ),
- $right = 0;
- $i < $n;
- $i++, $left = $right) {
- $right = $times[$i];
- print GRAN int(($left+$right)/2) . " " .
- ($class[$i] eq "" ? "0" : $class[$i]) . "\n";
- }
- print GRAN $times[$n-1]+(($times[$n-1]-$times[$n-2])/2) . " " .
- ($class[$n] eq "" ? "0" : $class[$n]) . "\n";
-
- } else {
-
- print GRAN ( (index($logaxes,"x") != -1) && ($times[0] == 0 ? int($times[1]/2) : ($times[$1] + $times[0])/2 ) . " " . $class[0] . "\n");
- for ($i=1; $i < $n-2; $i++) {
- $left = $times[$i];
- $right = $times[$i+1];
- print(GRAN ($left+$right)/2 . " " .
- ($class[$i] eq "" ? "0" : $class[$i]) . "\n");
- }
- print GRAN ($times[$n-1]+$times[$n-2])/2 . " " . $class[$n-2] if $n >= 2;
- }
-
- close(GRAN);
-}
-
-# ----------------------------------------------------------------------------
-
-sub write_array {
- local ($file_name,$n,@list) = @_;
-
- open(FILE,">$file_name") || die "$file_name: $!";
- for ($i=0; $i<=$#list; $i++) {
- print FILE $i . " " . ( $list[$i] eq "" ? "0" : $list[$i] ) . "\n";
- }
-
- if ( $opt_D ) {
- print "write_array: (" . join(", ",1 .. $#list) . ")\n for file $file_name returns: \n (0, $#list, &list_max(@list)\n";
- }
-
- return ( (0, $#list, &list_max(@list),
- "(" . join(", ",1 .. $#list) . ")\n") );
-}
-
-# ----------------------------------------------------------------------------
-
-sub gnu_plotify {
- local ($gp_file_name) = @_;
-
- @open_xrange = &range($OPEN_INT,$logscale{"'g'"},@exec_times);
-
- $exec_xtics = $opt_T ? &get_xtics($OPEN_INT,@exec_times) : "" ;
-
- open(GP_FILE,">$gp_file_name") ||
- die "Couldn't open gnuplot file $gp_file_name for output\n";
-
- print GP_FILE "set term postscript \"Roman\" 20\n";
- do write_gp_record(GP_FILE,
- $gran_file_name, &dat2ps_name($gran_file_name),
- "Granularity (pure exec. time)", "Number of threads",
- $logscale{"'g'"},
- @open_xrange,$max_rt_class,$exec_xtics);
-
- do write_gp_lines_record(GP_FILE,
- $cumulat_rts_file_name, &dat2ps_name($cumulat_rts_file_name),
- "Cumulative pure exec. times","% of threads",
- "",
- $max_rt, 100, "");
- # $xtics_cluster_rts as last arg?
-
- do write_gp_lines_record(GP_FILE,
- $cumulat0_rts_file_name, &dat2ps_name($cumulat0_rts_file_name),
- "Cumulative pure exec. times","Number of threads",
- $logscale{"'Cg'"},
- $max_rt, $tot_tasks, "");
- # $xtics_cluster_rts as last arg?
-
- close GP_FILE;
-
- print "Gnu plotting figures ...\n";
- system "gnuplot $gp_file_name";
-
- print "Extending thickness of impulses ...\n";
- do gp_ext($gran_file_name);
-}
-
-# ----------------------------------------------------------------------------
-
-sub gp_ext {
- local (@file_names) = @_;
- local ($file_name);
- local ($ps_file_name);
- local ($prg);
-
- #$prg = system "which gp-ext-imp";
- #print " Using script $prg for impuls extension\n";
- $prg = $ENV{GRANDIR} ? $ENV{GRANDIR} . "/bin/gp-ext-imp"
- : $ENV{HOME} . "/bin/gp-ext-imp" ;
- if ( $opt_v ) {
- print " (using script $prg)\n";
- }
-
- foreach $file_name (@file_names) {
- $ps_file_name = &dat2ps_name($file_name);
- system "$prg -w $ext_size -g $gray " .
- $ps_file_name . " " .
- $ps_file_name . "2" ;
- system "mv " . $ps_file_name . "2 " . $ps_file_name;
- }
-}
-
-# ----------------------------------------------------------------------------
-
-sub write_gp_record {
- local ($file,$in_file,$out_file,$xlabel,$ylabel,$logaxes,
- $xstart,$xend,$ymax,$xtics) = @_;
-
- if ( $xstart >= $xend ) {
- print ("WARNING: empty xrange [$xstart:$xend] changed to [$xstart:" . $xstart+1 . "]\n") if ( $pedantic || $opt_v );
- $xend = $xstart + 1;
- }
-
- if ( $ymax <=0 ) {
- $ymax = 2;
- print "WARNING: empty yrange changed to [0:$ymax]\n" if ( $pedantic || $opt_v );
- }
-
- $str = "set size " . $xsize . "," . $ysize . "\n" .
- "set xlabel \"" . $xlabel . "\"\n" .
- "set ylabel \"" . $ylabel . "\"\n" .
- ($xstart eq "" ? ""
- : "set xrange [" . int($xstart) .":" . int($xend) . "]\n") .
- ($opt_Y ?
- ("set yrange [" . (index($logaxes,"y") != -1 ? 1 : 0) . ":$opt_Y]\n") :
- ($ymax eq "" ? ""
- : "set yrange [" . (index($logaxes,"y") != -1 ? 1 : 0) .
- ":" . &list_max(2,int($ymax+$ymax/5)) . "]\n")) .
- ($xtics ne "" ? "set xtics $xtics" : "") .
- "set tics out\n" .
- "set border\n" .
- ( $nPEs!=0 ? "set title \"$nPEs PEs\"\n" : "" ) .
- "set nokey \n" .
- "set nozeroaxis\n" .
- "set format xy \"%8.8g\"\n" .
- (index($logaxes,"x") != -1 ?
- "set logscale x\n" :
- "set nologscale x\n") .
- (index($logaxes,"y") != -1 ?
- "set logscale y\n" :
- "set nologscale y\n") .
- "set output \"" . $out_file . "\"\n" .
- "plot \"" . $in_file . "\" with impulses\n\n";
- print $file $str;
-}
-
-# ----------------------------------------------------------------------------
-
-sub write_gp_lines_record {
- local ($file,$in_file,$out_file,$xlabel,$ylabel,$logaxes,
- $xend,$yend,$xtics) = @_;
-
- local ($str);
-
- $str = "set xlabel \"" . $xlabel . "\"\n" .
- "set ylabel \"" . $ylabel . "\"\n" .
- "set xrange [" . ( index($logaxes,"x") != -1 ? 1 : 0 ) . ":$xend]\n" .
- "set yrange [" . ( index($logaxes,"y") != -1 ? 1 : 0 ) .
- ($yend!=100 && $opt_Z ? ":$opt_Z]\n" : ":$yend]\n") .
- "set border\n" .
- "set nokey\n" .
- ( $xtics ne "" ? "set xtics $xtics" : "" ) .
- (index($logaxes,"x") != -1 ?
- "set logscale x\n" :
- "set nologscale x\n") .
- (index($logaxes,"y") != -1 ?
- "set logscale y\n" :
- "set nologscale y\n") .
- "set nozeroaxis\n" .
- "set format xy \"%8.8g\"\n" .
- "set output \"" . $out_file . "\"\n" .
- "plot \"" . $in_file . "\" with lines\n\n";
- print $file $str;
-}
-
-
-# ----------------------------------------------------------------------------
-
-sub write_gp_simple_record {
- local ($file,$in_file,$out_file,$xlabel,$ylabel,$logaxes,
- $xstart,$xend,$ymax,$xtics) = @_;
-
- $str = "set size " . $xsize . "," . $ysize . "\n" .
- "set xlabel \"" . $xlabel . "\"\n" .
- "set ylabel \"" . $ylabel . "\"\n" .
- ($xstart eq "" ? ""
- : "set xrange [" . int($xstart) .":" . int($xend) . "]\n") .
- ($ymax eq "" ? ""
- : "set yrange [" . (index($logaxes,"y") != -1 ? 1 : 0) .
- ":" . &list_max(2,int($ymax+$ymax/5)) . "]\n") .
- ($xtics ne "" ? "set xtics $xtics" : "") .
- "set border\n" .
- "set nokey\n" .
- "set tics out\n" .
- "set nozeroaxis\n" .
- "set format xy \"%8.8g\"\n" .
- (index($logaxes,"x") != -1 ?
- "set logscale x\n" :
- "set nologscale x\n") .
- (index($logaxes,"y") != -1 ?
- "set logscale y\n" :
- "set nologscale y\n") .
- "set output \"" . $out_file . "\"\n" .
- "plot \"" . $in_file . "\" with impulses\n\n";
- print $file $str;
-}
-
-# ----------------------------------------------------------------------------
-
-sub range {
- local ($open_int, $logaxes, @ints) = @_;
-
- local ($range, $left_margin, $right_margin);
-
- $range = $ints[$#ints]-$ints[0];
- $left_margin = 0; # $range/10;
- $right_margin = 0; # $range/10;
-
- if ( $opt_D ) {
- print "\n==> Range: logaxes are $logaxes i.e. " .
- (index($logaxes,"x") != -1 ? "matches x axis\n"
- : "DOESN'T match x axis\n");
- }
- if ( index($logaxes,"x") != -1 ) {
- if ( $open_int == $OPEN_INT ) {
- return ( ($ints[0]/2-$left_margin,
- $ints[$#ints]+($ints[$#ints]-$ints[$#ints-1])/2+$right_margin) );
- } else {
- return ( ( &list_max(1,$ints[0]-$left_margin),
- $ints[$#ints]+($ints[$#ints]-$ints[$#ints-1])/2+$right_margin) );
- }
- } else {
- if ( $open_int == $OPEN_INT ) {
- return ( ($ints[0]/2-$left_margin,
- $ints[$#ints]+($ints[$#ints]-$ints[$#ints-1])/2+$right_margin) );
- } else {
- return ( ($ints[0]-$left_margin,
- $ints[$#ints]+($ints[$#ints]-$ints[$#ints-1])/2+$right_margin) );
- }
- }
-}
-
-# ----------------------------------------------------------------------------
-
-# ----------------------------------------------------------------------------
-
-sub process_options {
- if ( $opt_h ) {
- open(ME,$0) || die "Can't open myself ($0)";
- $n = 0;
- while (<ME>) {
- last if $_ =~ /^$/;
- print $_;
- $n++;
- }
- close(ME);
-
- # system "cat $0 | awk 'BEGIN { n = 0; } \
- # /^$/ { print n; \
- # exit; } \
- # { n++; }'"
- exit ;
- }
-
- $input = $#ARGV == -1 ? "-" : $ARGV[0] ;
-
- if ( $#ARGV != 0 ) {
- #print "Usage: gran-extr [options] <sim-file>\n";
- #print "Use -h option to get details\n";
- #exit 1;
-
- }
-
- # Default settings:
- $gp_file_name = "gran.gp";
- $gran_file_name = "gran.dat";
- $cumulat_rts_file_name = "cumu-rts.dat";
- $cumulat0_rts_file_name = "cumu-rts0.dat";
- $xsize = 1;
- $ysize = 1;
-
- if ( $opt_p ) {
- $gp_file_name = $opt_p;
- } else {
- $gp_file_name = "gran.gp";
- }
-
- #if ( $opt_s ) {
- # $gp_file_name =~ s|\.|${opt_s}.|;
- # $gran_file_name =~ s|\.|${opt_s}.|;
- # $cumulat_rts_file_name =~ s|\.|${opt_s}.|;
- # $cumulat0_rts_file_name =~ s|\.|${opt_s}.|;
- #}
-
- if ( $opt_x ) {
- $xsize = $opt_x;
- } else {
- $xsize = 1;
- }
-
- if ( $opt_y ) {
- $ysize = $opt_y;
- } else {
- $ysize = 1;
- }
-
- if ( $opt_t ) {
- do read_template($opt_t,$input);
- }
-
-}
-
-# ----------------------------------------------------------------------------
-
-sub print_verbose_message {
-
- print "-" x 70 . "\n";
- print "Setup: \n";
- print "-" x 70 . "\n";
- print "\nFilenames: \n";
- print " Input file: $input\n";
- print " Gran files: $gran_file_name $gran_global_file_name $gran_local_file_name\n";
- print " Comm files: $comm_file_name $comm_global_file_name $comm_local_file_name\n";
- print " Sparked threads file: $spark_file_name $spark_local_file_name $spark_global_file_name\n";
- print " Heap file: $ha_file_name\n";
- print " GNUPLOT file name: $gp_file_name Correlation file name: $corr_file_name\n";
- print " Cumulative RT file name: $cumulat_rts_file_name ($cumulat0_rts_file_name) \n Cumulative HA file name: $cumulat_has_file_name\n";
- print " Cluster RT file name: $clust_rts_file_name \n Cluster HA file name: $clust_has_file_name\n";
- print " Cumulative runtimes file name: $cumulat_rts_file_name\n";
- print " Cumulative heap allocations file name $cumulat_has_file_name\n";
- print " Cluster run times file name: $clust_rts_file_name\n";
- print " Cluster heap allocations file name: $clust_has_file_name\n";
- print " PE load file name: $pe_file_name\n";
- print " Site size file name: $sn_file_name\n";
- print "\nBoundaries: \n";
- print " Gran boundaries: (" . join(',',@exec_times) . ")\n";
- print " Comm boundaries: (" . join(',',@comm_percs) . ")\n";
- print " Sparked threads boundaries: (" . join(',',@sparks) . ")\n";
- print " Heap boundaries: (" . join(',',@has) .")\n";
- print "\nOther pars: \n";
- print " Left margin: $left_margin Right margin: $right_margin\n";
- print " GP-extension: $ext_size GP xsize: $xsize GP ysize: $ysize\n";
- print " Gray scale: $gray Smart x-tics is " . ($opt_T ? "ON" : "OFF") .
- " Percentage y-axis is " . ($opt_P ? "ON" : "OFF") . "\n";
- print " Log. scaling assoc list: ";
- while (($key,$value) = each %logscale) {
- print "$key: $value, ";
- }
- print "\n";
- print " Active template file: $templ_file\n" if $opt_t;
- print "-" x 70 . "\n";
-}
-
-# ----------------------------------------------------------------------------
-
-sub pre_process {
- local ($file) = @_;
-
- open(PIPE,"wc -l $input |") || die "Couldn't open pipe";
-
- while (<PIPE>) {
- if (/^\s*(\d+)/) {
- $res = $1;
- } else {
- die "Error in pre-processing: Last line of $file does not match RTS!\n";
- }
- }
- close(PIPE);
-
- return ($res-1);
-}
-
-# ----------------------------------------------------------------------------
-
-
-# ----------------------------------------------------------------------------
-#
-# Old version (eventually delete it)
-# New version is in template.pl
-#
-# sub read_template {
-# local ($f);
-#
-# if ( $opt_v ) {
-# print "Reading template file $templ_file_name ...\n";
-# }
-#
-# ($f = ($input eq "-" ? "stdin" : $input)) =~ s/.rts//;
-#
-# open(TEMPLATE,"cat $templ_file_name | sed -e 's/\$0/$f/' |")
-# || die "Couldn't open file $templ_file_name";
-#
-# while (<TEMPLATE>) {
-# next if /^\s*$/ || /^--/;
-# if (/^\s*G[:,;.\s]+([^\n]+)$/) {
-# $list_str = $1;
-# $list_str =~ s/[\(\)\[\]]//g;
-# @exec_times = split(/[,;. ]+/, $list_str);
-# } elsif (/^\s*F[:,;.\s]+([^\n]+)$/) {
-# $list_str = $1;
-# $list_str =~ s/[\(\)\[\]]//g;
-# @fetch_times = split(/[,;. ]+/, $list_str);
-# } elsif (/^\s*A[:,;.\s]+([^\n]+)$/) {
-# $list_str = $1;
-# $list_str =~ s/[\(\)\[\]]//g;
-# @has = split(/[,;. ]+/, $list_str);
-# } elsif (/^\s*C[:,;.\s]+([^\n]+)$/) {
-# $list_str = $1;
-# $list_str =~ s/[\(\)\[\]]//g;
-# @comm_percs = split(/[,;. ]+/, $list_str);
-# } elsif (/^\s*S[:,;.\s]+([^\n]+)$/) {
-# $list_str = $1;
-# $list_str =~ s/[\(\)\[\]]//g;
-# @sparks = split(/[,;. ]+/, $list_str);
-# } elsif (/^\s*g[:,;.\s]+([\S]+)$/) {
-# ($gran_file_name,$gran_global_file_name, $gran_local_file_name) =
-# &mk_global_local_names($1);
-# } elsif (/^\s*f[:,;.\s]+([\S]+)$/) {
-# ($ft_file_name,$ft_global_file_name, $ft_local_file_name) =
-# &mk_global_local_names($1);
-# } elsif (/^\s*c[:,;.\s]+([\S]+)$/) {
-# ($comm_file_name, $comm_global_file_name, $comm_local_file_name) =
-# &mk_global_local_names($1);
-# } elsif (/^\s*s[:,;.\s]+([\S]+)$/) {
-# ($spark_file_name, $spark_global_file_name, $spark_local_file_name) =
-# &mk_global_local_names($1);
-# } elsif (/^\s*a[:,;.\s]+([\S]+)$/) {
-# ($ha_file_name, $ha_global_file_name, $ha_local_file_name) =
-# &mk_global_local_names($1);
-# } elsif (/^\s*p[:,;.\s]+([\S]+)$/) {
-# $gp_file_name = $1;
-# $ps_file_name = &dat2ps_name($gp_file_name);
-#
-# } elsif (/^\s*Xcorr[:,;.\s]+([\S]+)$/) {
-# $corr_file_name = $1;
-# } elsif (/^\s*Xcumulat-rts[:,;.\s]+([\S]+)$/) {
-# $cumulat_rts_file_name = $1;
-# ($cumulat0_rts_file_name = $1) =~ s/\./0./;
-# } elsif (/^\s*Xcumulat-has[:,;.\s]+([\S]+)$/) {
-# $cumulat_has_file_name = $1;
-# } elsif (/^\s*Xcumulat-fts[:,;.\s]+([\S]+)$/) {
-# $cumulat_fts_file_name = $1;
-# } elsif (/^\s*Xcumulat-cps[:,;.\s]+([\S]+)$/) {
-# $cumulat_cps_file_name = $1;
-# } elsif (/^\s*Xclust-rts[:,;.\s]+([\S]+)$/) {
-# $clust_rts_file_name = $1;
-# } elsif (/^\s*Xclust-has[:,;.\s]+([\S]+)$/) {
-# $clust_has_file_name = $1;
-# } elsif (/^\s*Xclust-fts[:,;.\s]+([\S]+)$/) {
-# $clust_fts_file_name = $1;
-# } elsif (/^\s*Xclust-cps[:,;.\s]+([\S]+)$/) {
-# $clust_cps_file_name = $1;
-# } elsif (/^\s*Xpe[:,;.\s]+([\S]+)$/) {
-# $pe_file_name = $1;
-# } elsif (/^\s*Xsn[:,;.\s]+([\S]+)$/) {
-# $sn_file_name = $1;
-#
-# } elsif (/^\s*XRTS[:,;.\s]+([\S]+)$/) {
-# $rts_file_name = $1;
-# } elsif (/^\s*XHAS[:,;.\s]+([\S]+)$/) {
-# $has_file_name = $1;
-# } elsif (/^\s*XFTS[:,;.\s]+([\S]+)$/) {
-# $fts_file_name = $1;
-# } elsif (/^\s*XLSPS[:,;.\s]+([\S]+)$/) {
-# $lsps_file_name = $1;
-# } elsif (/^\s*XGSPS[:,;.\s]+([\S]+)$/) {
-# $gsps_file_name = $1;
-# } elsif (/^\s*XCPS[:,;.\s]+([\S]+)$/) {
-# $cps_file_name = $1;
-# } elsif (/^\s*XCCPS[:,;.\s]+([\S]+)$/) {
-# $ccps_file_name = $1;
-#
-# } elsif (/^\s*\-[:,;.\s]+([\S]+)$/) {
-# $input = $1;
-# } elsif (/^\s*L[:,;\s]+(.*)$/) {
-# $str = $1;
-# %logscale = ('g',"xy",'a',"xy",'Cg',"xy",'Ca',"xy",'Yp',"y",'Ys',"y") , next if $str eq ".";
-# $str =~ s/[\(\)\[\]]//g;
-# %logscale = split(/[,;. ]+/, $str);
-# } elsif (/^\s*i[:,;.\s]+([\S]+)$/) {
-# $gray = $1;
-# } elsif (/^\s*k[:,;.\s]+([\S]+)$/) {
-# $no_of_clusters = $1;
-# } elsif (/^\s*e[:,;.\s]+([\S]+)$/) {
-# $ext_size = $1;
-# } elsif (/^\s*v.*$/) {
-# $verbose = 1;
-# } elsif (/^\s*T.*$/) {
-# $opt_T = 1;
-# }
-# }
-# close(TEMPLATE);
-# }
diff --git a/ghc/utils/parallel/SN.pl b/ghc/utils/parallel/SN.pl
deleted file mode 100644
index bc33e2a60c..0000000000
--- a/ghc/utils/parallel/SN.pl
+++ /dev/null
@@ -1,280 +0,0 @@
-#!/usr/local/bin/perl
-# (C) Hans Wolfgang Loidl, November 1995
-#############################################################################
-# Time-stamp: <Sun Nov 5 1995 00:23:45 Stardate: [-31]6545.08 hwloidl>
-#
-# Usage: SN [options] <gr-file>
-#
-# Create a summary of spark names that occur in gr-file (only END events in
-# gr-file are necessary). Creates a gnuplot impulses graph (spark names by
-# number of threads) as summary.
-#
-# Options:
-# -h ... help; print this text.
-# -v ... verbose mode.
-#
-#############################################################################
-
-$gran_dir = $ENV{'GRANDIR'};
-if ( $gran_dir eq "" ) {
- print STDERR "SN: Warning: Env variable GRANDIR is undefined\n";
-}
-
-push(@INC, $gran_dir, $gran_dir . "/bin");
-# print STDERR "INC: " . join(':',@INC) . "\n";
-
-require "getopts.pl";
-require "par-aux.pl";
-require "stats.pl";
-
-&Getopts('hv');
-
-do process_options();
-
-if ( $opt_v ) { do print_verbose_message(); }
-
-# ---------------------------------------------------------------------------
-# Init
-# ---------------------------------------------------------------------------
-
-chop($date = `date`);
-chop($stardate = `stardate`);
-
-open (IN,"<$input") || die "$!: $input";
-$n = 0;
-$is_end=0;
-while (<IN>) {
- $is_end = 1 if /END\s+(\w+).*SN\s+(\d+).*RT\s*(\d+)/;
- next unless $is_end;
- $n++;
- $sn = $2;
- $rt = $3;
- #$sn_dec = hex($sn);
- $num_sns{$sn}++;
- $rts_sns{$sn} += $rt;
- #do inc ($sn_dec);
- $is_end=0;
-}
-close (IN);
-
-@sorted_keys=sort {$a<=>$b} keys(%num_sns);
-#$max_val=&list_max(@sorted_keys);
-
-open (SUM,">$summary") || die "$!: $summary";
-
-print SUM "# Generated by SN at $date $stardate\n";
-print SUM "# Input file: $input\n";
-print SUM "#" . "-"x77 . "\n";
-print SUM "Total number of threads: $n\n";
-print SUM "# Format: SN: Spark Site N: Number of threads AVG: average RT\n";
-# . "RTS: Sum of RTs ";
-
-foreach $k (@sorted_keys) {
- $num = $num_sns{$k};
- $rts = $rts_sns{$k};
- $avg = $rts/$num;
- #print SUM "SN: $k \tN: $num \tRTS: $rts \tAVG: $avg\n";
- print SUM "$k \t$num \t$avg\n";
-}
-close (SUM);
-
-open (OUT,">$output") || die "$!: $output";
-print OUT "# Generated by SN at $date $stardate\n";
-print OUT "# Input file: $input\n";
-print OUT "#" . "-"x77 . "\n";
-
-$max_val=0;
-foreach $k (@sorted_keys) {
- $num = $num_sns{$k};
- $max_val = $num if $num > $max_val;
- print OUT "$k\t$num\n";
-}
-close (OUT);
-
-do write_gp($gp_file,$ps_file);
-
-print "Gnu plotting figures ...\n";
-system "gnuplot $gp_file";
-
-print "Extending thickness of impulses ...\n";
-$ext_size = 100;
-$gray = 0.3;
-do gp_ext($ps_file);
-
-exit (0);
-
-# +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-sub inc {
- local ($sn) = @_;
- local (@k);
-
- @k = keys(%num_sns);
- if ( &is_elem($sn, @k) ) {
- $num_sns{$sn}++;
- } else {
- $num_sns{$sn} = 1;
- }
-}
-
-# ----------------------------------------------------------------------------
-
-sub is_elem {
- local ($x,@list) = @_;
- local ($found);
-
- for ($found = 0, $y = shift(@list);
- $#list == -1 || $found;
- $found = ($x == $y), $y = shift(@list)) {}
-
- return ($found);
-}
-
-# ----------------------------------------------------------------------------
-
-# -----------------------------------------------------------------------------
-
-sub process_options {
-
- if ( $opt_h ) {
- open(ME,$0) || die "Can't open myself ($0): $!\n";
- $n = 0;
- while (<ME>) {
- last if $_ =~ /^$/;
- print $_;
- $n++;
- }
- close(ME);
- exit ;
- }
-
- if ( $opt_s ) {
- $opt_s =~ s/[\(\)\[\]]//g;
- @sparks = split(/[,;. ]+/, $opt_s);
- } else {
- @sparks = ( 3, 4, 5, 6, 7, 8, 11, 12, 13, 14, 15);
- }
-
- if ( $#ARGV != 0 ) {
- print "Usage: $0 [options] <gr-file>\n;";
- print "Use -h option to get details\n";
- exit 1;
- }
-
- $input = $ARGV[0];
- ($ps_file = $input) =~ s/\.gr/-SN.ps/;
- ($gp_file = $input) =~ s/\.gr/-SN.gp/;
- ($summary = $input) =~ s/\.gr/-SN.sn/;
-
- #($basename = $gr_file) =~ s/\.gr//;
- #$rts_file = $basename . ".rts"; # "RTS";
- #$gran_file = "g.ps"; # $basename . ".ps";
- #$rts_file = $gr_file;
- #$rts_file =~ s/\.gr/.rts/g;
-
- if ( $opt_o ) {
- $output = $opt_o;
- } else {
- ($output = $input) =~ s/\.gr/-SN.dat/;
- }
-
- if ( $opt_e ) {
- $ext_size = $opt_e;
- } else {
- $ext_size = 100;
- }
-
- if ( $opt_i ) {
- $gray = $opt_i;
- } else {
- $gray = 0;
- }
-}
-
-# -----------------------------------------------------------------------------
-
-sub print_verbose_message {
- print "Input: $input \tOutput: $output\n";
-}
-
-# -----------------------------------------------------------------------------
-
-# ToDo: Takes these from global module:
-
-# ----------------------------------------------------------------------------
-
-sub gp_ext {
- local (@file_names) = @_;
- local ($file_name);
- local ($ps_file_name);
- local ($prg);
-
- #$prg = system "which gp-ext-imp";
- #print " Using script $prg for impuls extension\n";
- $prg = $ENV{GRANDIR} ? $ENV{GRANDIR} . "/bin/gp-ext-imp"
- : $ENV{HOME} . "/bin/gp-ext-imp" ;
- if ( $opt_v ) {
- print " (using script $prg)\n";
- }
-
- foreach $file_name (@file_names) {
- $ps_file_name = $file_name; # NB change to orig !!!!&dat2ps_name($file_name);
- system "$prg -w $ext_size -g $gray " .
- $ps_file_name . " " .
- $ps_file_name . "2" ;
- system "mv " . $ps_file_name . "2 " . $ps_file_name;
- }
-}
-
-# ----------------------------------------------------------------------------
-
-sub write_gp {
- local ($gp_file,$ps_file) = @_;
- local ($str);
-
- $xsize = 1;
- $ysize = 1;
- $xlabel = "Spark sites";
- $ylabel = "Number of threads";
- $xstart = &list_min(@sorted_keys);
- $xend = &list_max(@sorted_keys);
- $ymax = $max_val;
- $xtics = ""; "(" . join(',',@sorted_keys) . ")\n";
- $in_file = $output;
- $out_file = $ps_file;
-
- open (GP,">$gp_file") || die "$!: $gp_file";
- print GP "set term postscript \"Roman\" 20\n";
-
- # identical to the part in write_gp_record of RTS2gran
-
- $str = "set size " . $xsize . "," . $ysize . "\n" .
- "set xlabel \"" . $xlabel . "\"\n" .
- "set ylabel \"" . $ylabel . "\"\n" .
- ($xstart eq "" ? ""
- : "set xrange [" . int($xstart) .":" . int($xend) . "]\n") .
- ($opt_Y ?
- ("set yrange [" . (index($logaxes,"y") != -1 ? 1 : 0) . ":$opt_Y]\n") :
- ($ymax eq "" ? ""
- : "set yrange [" . (index($logaxes,"y") != -1 ? 1 : 0) .
- ":" . &list_max(2,int($ymax+$ymax/5)) . "]\n")) .
- ($xtics ne "" ? "set xtics $xtics" : "") .
- "set tics out\n" .
- "set border\n" .
- ( $nPEs!=0 ? "set title \"$nPEs PEs\"\n" : "" ) .
- "set nokey \n" .
- "set nozeroaxis\n" .
- "set format xy \"%8.8g\"\n" .
- (index($logaxes,"x") != -1 ?
- "set logscale x\n" :
- "set nologscale x\n") .
- (index($logaxes,"y") != -1 ?
- "set logscale y\n" :
- "set nologscale y\n") .
- "set output \"" . $out_file . "\"\n" .
- "plot \"" . $in_file . "\" with impulses\n\n";
- print GP $str;
- close (GP);
-}
-
-# ----------------------------------------------------------------------------
diff --git a/ghc/utils/parallel/SPLIT.pl b/ghc/utils/parallel/SPLIT.pl
deleted file mode 100644
index b4fe46f5b0..0000000000
--- a/ghc/utils/parallel/SPLIT.pl
+++ /dev/null
@@ -1,379 +0,0 @@
-#!/usr/local/bin/perl
-# (C) Hans Wolfgang Loidl, July 1995
-#############################################################################
-# Time-stamp: <Thu Oct 26 1995 18:23:00 Stardate: [-31]6498.62 hwloidl>
-#
-# Usage: SPLIT [options] <gr-file>
-#
-# Generate a set of granularity graphs out of the GrAnSim profile <gr-file>.
-# The granularity graphs are put into subdirs of the structure:
-# <basename of gr-file>-<spark-name>
-#
-# Options:
-# -s <list> ... a perl list of spark names; the given <gr-file> is scanned
-# for each given name in turn and granularity graphs are
-# generated for each of these sparks
-# -O ... use gr2RTS and RTS2gran instead of gran-extr;
-# this generates fewer output files (only granularity graphs)
-# but should be faster and far less memory consuming
-# -d <dir> ... use <dir> as basename for the sub-directories
-# -o <file> ... use <file> as basename for the generated latex files;
-# the overall result is in <file>.ps
-# -t <file> ... use <file> as gran-extr type template file
-# ('.' for local template, ',' for global template)
-# -A ... surpress generation of granularity profiles for overall .gr
-# -h ... help; print this text.
-# -v ... verbose mode.
-#
-#############################################################################
-
-require "getopts.pl";
-
-&Getopts('hvOAd:o:s:t:');
-
-do process_options();
-
-if ( $opt_v ) { do print_verbose_message(); }
-
-# ---------------------------------------------------------------------------
-# Init
-# ---------------------------------------------------------------------------
-
-$latex = "/usr/local/tex/bin/latex2e"; # or "/usr/local/tex/bin/latex2e"
-
-do all() if !$opt_A;
-
-foreach $s (@sparks) {
- if ( -f $tmp_file ) { system "rm -f $tmp_file"; }
- system "tf -H -s $s $gr_file > $tmp_file"
- || die "Can't open pipe: tf -s $s $gr_file > $tmp_file\n";
-
- if ( $opt_d ) {
- $dir = $opt_d;
- } else {
- $dir = $gr_file;
- }
- $dir =~ s/\.gr//g;
- $dir .= "-$s";
-
- if ( ! -d $dir ) {
- mkdir($dir,"755"); # system "mkdir $dir";
- system "chmod u+rwx $dir";
- }
-
- system "mv $tmp_file $dir/$gr_file";
- chdir $dir;
- do print_template();
- do print_va("Title",$s);
- if ( -f $va_ps_file ) {
- local ($old) = $va_ps_file;
- $old =~ s/\.ps/-o.ps/g;
- system "mv $va_ps_file $old";
- }
- if ( $opt_O ) {
- system "gr2RTS -o $rts_file $gr_file; " .
- "RTS2gran -t $template_file $rts_file; " .
- "$latex $va_file; dvips $va_dvi_file > $va_ps_file";
- } else {
- system "gran-extr -t $template_file $gr_file; " .
- "$latex $va_file; dvips $va_dvi_file > $va_ps_file";
- }
- chdir ".."; # system "cd ..";
-}
-
-exit 0;
-
-# -----------------------------------------------------------------------------
-
-sub all {
-
- $dir = $gr_file;
- $dir =~ s/\.gr//g;
- $dir .= "-all";
-
- if ( ! -d $dir ) {
- mkdir($dir,"755"); # system "mkdir $dir";
- system "chmod u+rwx $dir";
- }
-
- system "cp $gr_file $dir/$gr_file";
- chdir $dir;
- do print_template();
- do print_va("All","all");
- if ( -f $va_ps_file ) {
- local ($old) = $va_ps_file;
- $old =~ s/\.ps/-o.ps/g;
- system "mv $va_ps_file $old";
- }
- if ( $opt_O ) {
- system "gr2RTS -o $rts_file $gr_file; " .
- "RTS2gran -t $template_file $rts_file; " .
- "$latex $va_file; dvips $va_dvi_file > $va_ps_file";
- } else {
- system "gran-extr -t $template_file $gr_file; " .
- "$latex $va_file; dvips $va_dvi_file > $va_ps_file";
- }
- chdir ".."; # system "cd ..";
-}
-
-# ---------------------------------------------------------------------------
-
-sub print_template {
-
- open (TEMPL,">$template_file") || die "Can't open $template_file\n";
-
- print TEMPL <<EOF;
--- Originally copied from the master template: GrAn/bin/TEMPL
--- Intervals for pure exec. times
-G: (1000, 2000, 3000, 4000, 5000, 10000, 20000, 30000, 40000, 50000, 100000, 200000, 300000)
--- Intervals for communication (i.e. fetch) times
-F: (1000, 2000, 3000, 4000, 5000, 10000, 20000, 30000, 40000, 50000, 100000, 200000, 300000)
--- Intervals for communication percentages
-C: (0, 1, 2, 5, 8, 10, 20, 30, 40, 50, 100)
--- Intervals for no. of sparks
-S: (1, 2, 5)
--- Intervals for heap allocations
-A: (10,20,30,40,50,100,200,300,400,500,1000,2000,3000)
--- A: (100, 50000, 66000, 100000)
-
-
-g: g.dat
-f: f.dat
-c: c.dat
-s: s.dat
-a: a.dat
-
--- Select file name corr coeff file
-Xcorr: CORR
-
--- Select file names for GNUPLOT data files for cumulative runtime and
--- cluster graphs
-Xcumulat-rts: cumu-rts.dat
-Xcumulat-fts: cumu-fts.dat
-Xcumulat-has: cumu-has.dat
-Xcumulat-cps: cumu-cps.dat
-Xclust-rts: clust-rts.dat
-Xclust-has: clust-has.dat
-Xclust-cps: clust-cps.dat
-
--- Select file names for GNUPLOT data files for per proc. runnable time
--- and per spark site runtime
-Xpe: pe.dat
-Xsn: sn.dat
-
--- Select file names for sorted lists of runtimes, heap allocs, number of
--- local and global sparks and communication percentage
-XRTS: RTS
-XFTS: FTS
-XHAS: HAS
-XLSPS: LSPS
-XGSPS: GSPS
-XCPS: CPS
-XCCPS: CPS
-
--- Std log scaling
-L: .
--- ('g',"xy",'Cg',"xy",'Ca',"xy")
-
--- Gray level of impulses in the graph (0=black)
-i: 0.3
-
--- Number of clusters
-k: 2
-
--- Width of impulses (needed for gp-ext-imp)
-e: 150
-
--- Input file
--- -: soda.gr
-EOF
-
- close(TEMPL);
-}
-
-# -----------------------------------------------------------------------------
-# NB: different file must be generated for $opt_O and default setup.
-# -----------------------------------------------------------------------------
-
-sub print_va {
- local ($title, $spark) = @_;
-
- open (VA,">$va_file") || die "Can't open $va_file\n";
-
- if ( $opt_O ) {
- print VA <<EOF;
-% Originally copied from master va-file: grasp/tests/va.tex
-\\documentstyle[11pt,psfig]{article}
-
-% Page Format
-\\topmargin=0cm %0.5cm
-\\textheight=24cm %22cm
-\\footskip=0cm
-\\oddsidemargin=0cm %0.75cm
-\\evensidemargin=0cm %0.75cm
-\\rightmargin=0cm %0.75cm
-\\leftmargin=0cm %0.75cm
-\\textwidth=16cm %14.5cm
-
-\\title{SPLIT}
-\\author{Me}
-\\date{Today}
-
-\\pssilent
-
-\\begin{document}
-
-\\pagestyle{empty}
-\%\\maketitle
-
-\\nopagebreak
-
-\\begin{figure}[t]
-\\begin{center}
-\\begin{tabular}{c}
-\\centerline{\\psfig{angle=270,width=7cm,file=$gran_file}}
-\\end{tabular}
-\\end{center}
-\\caption{Granularity {\\bf $spark}}
-\\end{figure}
-
-\\begin{figure}[t]
-\\begin{center}
-\\begin{tabular}{cc}
-\\psfig{angle=270,width=7cm,file=cumu-rts.ps} &
-\\psfig{angle=270,width=7cm,file=cumu-rts0.ps}
-\\end{tabular}
-\\end{center}
-\\caption{Cumulative Execution Times {\\bf $spark}}
-\\end{figure}
-
-\\end{document}
-EOF
- } else {
- print VA <<EOF;
-% Originally copied from master va-file: grasp/tests/va.tex
-\\documentstyle[11pt,psfig]{article}
-
-% Page Format
-\\topmargin=0cm %0.5cm
-\\textheight=24cm %22cm
-\\footskip=0cm
-\\oddsidemargin=0cm %0.75cm
-\\evensidemargin=0cm %0.75cm
-\\rightmargin=0cm %0.75cm
-\\leftmargin=0cm %0.75cm
-\\textwidth=16cm %14.5cm
-
-\\title{$title; Spark: $spark}
-\\author{}
-\\date{}
-
-\\begin{document}
-
-\\pagestyle{empty}
-%\\maketitle
-
-\\nopagebreak
-
-\\begin{figure}[t]
-\\begin{center}
-\\begin{tabular}{cc}
-\\psfig{angle=270,width=7cm,file=$gran_file} &
-\\psfig{angle=270,width=7cm,file=a.ps}
-\\end{tabular}
-\\end{center}
-\\caption{Granularity \\& Heap Allocations {\\bf $spark}}
-\\end{figure}
-
-\\begin{figure}[t]
-\\begin{center}
-\\begin{tabular}{cc}
-\\psfig{angle=270,width=7cm,file=f.ps} &
-\\psfig{angle=270,width=7cm,file=c.ps}
-\\end{tabular}
-\\end{center}
-\\caption{Fetching Profile {\\bf $spark}}
-\\end{figure}
-
-\\begin{figure}[t]
-\\begin{center}
-\\begin{tabular}{cc}
-\\psfig{angle=270,width=7cm,file=cumu-rts.ps} &
-\\psfig{angle=270,width=7cm,file=cumu-rts0.ps}
-\\end{tabular}
-\\end{center}
-\\caption{Cumulative Execution Times {\\bf $spark}}
-\\end{figure}
-
-\\end{document}
-EOF
-}
- close (VA);
-}
-
-# -----------------------------------------------------------------------------
-
-sub process_options {
-
- if ( $opt_h ) {
- open(ME,$0) || die "Can't open myself ($0): $!\n";
- $n = 0;
- while (<ME>) {
- last if $_ =~ /^$/;
- print $_;
- $n++;
- }
- close(ME);
- exit ;
- }
-
- if ( $opt_s ) {
- $opt_s =~ s/[\(\)\[\]]//g;
- @sparks = split(/[,;. ]+/, $opt_s);
- } else {
- @sparks = ( 3, 4, 5, 6, 7, 8, 11, 12, 13, 14, 15);
- }
-
- if ( $#ARGV != 0 ) {
- print "Usage: $0 [options] <gr-file>\n;";
- print "Use -h option to get details\n";
- exit 1;
- }
-
- $gr_file = $ARGV[0];
- ($basename = $gr_file) =~ s/\.gr//;
- $rts_file = $basename . ".rts"; # "RTS";
- $gran_file = "g.ps"; # $basename . ".ps";
- #$rts_file = $gr_file;
- #$rts_file =~ s/\.gr/.rts/g;
-
- if ( $opt_o ) {
- $va_file = $opt_o;
- $va_dvi_file = $va_file;
- $va_dvi_file =~ s/\.tex/.dvi/g;
- $va_ps_file = $va_file;
- $va_ps_file =~ s/\.tex/.ps/g;
- } else {
- $va_file = "va.tex";
- $va_dvi_file = "va.dvi";
- $va_ps_file = "va.ps";
- }
-
- if ( $opt_t ) {
- $template_file = $opt_t;
- } else {
- $template_file = "TEMPL";
- }
-
- $tmp_file = ",t";
-}
-
-# -----------------------------------------------------------------------------
-
-sub print_verbose_message {
- print "Sparks: (" . join(',',@sparks) . ")\n";
- print "Files: .gr " . $gr_file . " template " . $template_file .
- " va " . $va_file . "\n";
-}
-
-# -----------------------------------------------------------------------------
diff --git a/ghc/utils/parallel/avg-RTS.pl b/ghc/utils/parallel/avg-RTS.pl
deleted file mode 100644
index 4f25d55f80..0000000000
--- a/ghc/utils/parallel/avg-RTS.pl
+++ /dev/null
@@ -1,15 +0,0 @@
-#!/usr/local/bin/perl
-
-$n=0;
-$sum=0;
-$last=0;
-while (<>) {
- next unless /^\d+/;
- @c = split;
- $sum += $c[0];
- $last = $c[0];
- $n++;
-}
-
-print "Average Runtimes: n=$n; sum=$sum; avg=" . ($sum/$n) . "; max=$last\n";
-
diff --git a/ghc/utils/parallel/get_SN.pl b/ghc/utils/parallel/get_SN.pl
deleted file mode 100644
index e9426855bf..0000000000
--- a/ghc/utils/parallel/get_SN.pl
+++ /dev/null
@@ -1,40 +0,0 @@
-#!/usr/local/bin/perl
-#############################################################################
-
-#do get_SN($ARGV[0]);
-
-#exit 1;
-
-# ---------------------------------------------------------------------------
-
-sub get_SN {
- local ($file) = @_;
- local ($id,$idx,$sn);
-
- open (FILE,$file) || die "get_SN: Can't open file $file\n";
-
- $line_no=0;
- while (<FILE>) {
- next unless /END/;
- # PE 0 [3326775]: END 0, SN 0, ST 0, EXP F, BB 194, HA 1464, RT 983079, BT 1449032 (7), FT 0 (0), LS 0, GS 27, MY T
-
- if (/^PE\s*(\d+) \[(\d+)\]: END ([0-9a-fx]+), SN (\d+)/) {
- $line_no++;
- $idx = $3;
- $id = hex($idx);
- $sn = $4;
- #print STDERR "Id: $id ($idx) --> $sn\n";
- $id2sn{$id} = $sn;
- }
- }
-
- # print STDERR "get_SN: $line_no lines processed\n";
- close (FILE);
-
- # print STDERR "Summary: " . "="x15 . "\n";
- # foreach $key (keys %id2sn) {
- # print STDERR "> $key --> $id2sn{$key}\n";
- #}
-}
-
-1;
diff --git a/ghc/utils/parallel/ghc-fool-sort.pl b/ghc/utils/parallel/ghc-fool-sort.pl
deleted file mode 100644
index dfa65a1875..0000000000
--- a/ghc/utils/parallel/ghc-fool-sort.pl
+++ /dev/null
@@ -1,23 +0,0 @@
-##############################################################################
-#
-# Usage: fool-sort
-#
-# Takes a pure (i.e. no header lines) quasi-parallel profile (a .qp file) from
-# stdin and inserts a counter as second field to force sort not to change the
-# ordering of lines with the same time stamp. The result is written to stdout.
-#
-##############################################################################
-
-$last_time = 0;
-while (<STDIN>) {
- ($time, @rest) = split;
- if ( $time == $last_time ) {
- $x = ++$count;
- } else {
- $x = $count = 0;
- }
- print $time, " ", $x, " ", join(' ',@rest), "\n";
- $last_time = $time;
-}
-
-exit 0;
diff --git a/ghc/utils/parallel/ghc-unfool-sort.pl b/ghc/utils/parallel/ghc-unfool-sort.pl
deleted file mode 100644
index 90da222a5a..0000000000
--- a/ghc/utils/parallel/ghc-unfool-sort.pl
+++ /dev/null
@@ -1,16 +0,0 @@
-##############################################################################
-#
-# Usage: unfool-sort
-#
-# Reads stdin, elimininates the second field (a dummy counter that has been
-# inserted by fool-sort) of each line and writes the result to stdout.
-# See documentation of fool-sort.
-#
-##############################################################################
-
-while (<STDIN>) {
- ($time, $dummy, @rest) = split;
- print join(' ',$time,@rest) . "\n";
-}
-
-exit 0;
diff --git a/ghc/utils/parallel/gp-ext-imp.pl b/ghc/utils/parallel/gp-ext-imp.pl
deleted file mode 100644
index fa7c4e06d8..0000000000
--- a/ghc/utils/parallel/gp-ext-imp.pl
+++ /dev/null
@@ -1,86 +0,0 @@
-#!/usr/local/bin/perl
-# #############################################################################
-#
-# Usage: gp-ext-imp [options] [<input-file>] [<output-file>]
-#
-# A small script to produce half-useful bar graphs from the PostScript
-# output produced by gnuplot.
-# Translation is done in the X axis automatically, and should
-# be `good enough' for graphs with smallish numbers of bars.
-#
-# Original version: Bryan O'Sullivan <bos@dcs.glasgow.ac.uk> 09.94
-# New and improved version: Hans Wolfgang Loidl <hwloidl@dcs.glasgow.ac.uk>
-#
-# Options:
-# -w <width> ... width of vertical bars
-# -g <gray-level> ... set gray-level (between 0 and 1; 0 means black)
-# -m <move> ... move the graph <move> pixels to the right
-# -h ... help; print this text
-# -v ... verbose mode
-#
-# #############################################################################
-
-require "getopts.pl";
-
-&Getopts('hvm:w:g:');
-
-if ( $opt_h ) {
- open(ME,$0) || die "Can't open myself ($0)";
- $n = 0;
- while (<ME>) {
- last if $_ =~ /^$/;
- print $_;
- $n++;
- }
- close(ME);
-
- exit ;
-}
-
-$size = $opt_w ? $opt_w : 200;
-$gray = $opt_g ? $opt_g : 0;
-$move = $opt_m ? $opt_m : 150;
-
-$from = $#ARGV >= 0 ? $ARGV[0] : "-";
-$to = $#ARGV >= 1 ? $ARGV[1] : "-";
-
-if ( $opt_v ) {
- print 70 x "-" . "\n";
- print "\nSetup: \n";
- print " Input file: $from Output file: $to\n";
- print " Width: $size Gray level: $gray Move is " .
- ($opt_m ? "ON" : "OFF") . " with value $move\n";
- print 70 x "-" . "\n";
-}
-
-open(FROM, "<$from") || die "$from: $!";
-open(TO, ">$to") || die "$to: $!";
-
-$l = -1;
-
-foreach (<FROM>) {
- if ($l >= 0) {
- $l--;
- }
- if ($l == 0) {
- if ( $opt_m ) {
- # This seems to shift everything a little to the right;
- print TO "$move 0 translate\n";
- }
- print TO "$gray setgray\n";
- print TO "$size setlinewidth\n";
- }
- if (/^LT0$/) {
- $l = 3;
- } elsif (/^LT1$/) {
- print TO "-150 0 translate\n";
- }
- print TO;
-}
-
-
-
-
-
-
-
diff --git a/ghc/utils/parallel/gr2RTS.pl b/ghc/utils/parallel/gr2RTS.pl
deleted file mode 100644
index c609334c28..0000000000
--- a/ghc/utils/parallel/gr2RTS.pl
+++ /dev/null
@@ -1,138 +0,0 @@
-#!/usr/local/bin/perl
-# (C) Hans Wolfgang Loidl, July 1995
-##############################################################################
-# Time-stamp: <Thu Oct 26 1995 18:40:10 Stardate: [-31]6498.68 hwloidl>
-#
-# Usage: gr2RTS [options] <sim-file>
-#
-# Options:
-# -o <file> ... write output to <file>
-# -h ... help; print this text.
-# -v ... verbose mode.
-#
-##############################################################################
-
-# ----------------------------------------------------------------------------
-# Command line processing and initialization
-# ----------------------------------------------------------------------------
-
-require "getopts.pl";
-
-&Getopts('hvo:');
-
-do process_options();
-
-if ( $opt_v ) {
- do print_verbose_message ();
-}
-
-# ----------------------------------------------------------------------------
-# The real thing
-# ----------------------------------------------------------------------------
-
-open(INPUT,"<$input") || die "Couldn't open input file $input";
-open(OUTPUT,"| sort -n > $output") || die "Couldn't open output file $output";
-
-#do skip_header();
-
-$tot_total_rt = 0;
-$tot_rt = 0;
-
-$line_no = 0;
-while (<INPUT>) {
- next if /^--/; # Comment lines start with --
- next if /^\s*$/; # Skip empty lines
- $line_no++;
- @fields = split(/[:,]/,$_);
- $has_end = 0;
-
- foreach $elem (@fields) {
- foo : {
- $pe = $1, $end = $2 , last foo if $elem =~ /^\s*PE\s+(\d+)\s+\[(\d+)\].*$/;
- $tn = $1, $has_end = 1 , last foo if $elem =~ /^\s*END\s+(\w+).*$/;
- # $tn = $1 , last foo if $elem =~ /^\s*TN\s+(\w+).*$/;
- $sn = $1 , last foo if $elem =~ /^\s*SN\s+(\d+).*$/;
- $start = $1 , last foo if $elem =~ /^\s*ST\s+(\d+).*$/;
- $is_global = $1 , last foo if $elem =~ /^\s*EXP\s+(T|F).*$/;
- $bbs = $1 , last foo if $elem =~ /^\s*BB\s+(\d+).*$/;
- $ha = $1 , last foo if $elem =~ /^\s*HA\s+(\d+).*$/;
- $rt = $1 , last foo if $elem =~ /^\s*RT\s+(\d+).*$/;
- $bt = $1, $bc = $2 , last foo if $elem =~ /^\s*BT\s+(\d+)\s+\((\d+)\).*$/;
- $ft = $1, $fc = $2 , last foo if $elem =~ /^\s*FT\s+(\d+)\s+\((\d+)\).*$/;
- $lsp = $1 , last foo if $elem =~ /^\s*LS\s+(\d+).*$/;
- $gsp = $1 , last foo if $elem =~ /^\s*GS\s+(\d+).*$/;
- $my = $1 , last foo if $elem =~ /^\s*MY\s+(T|F).*$/;
- }
- }
-
- next unless $has_end == 1;
-
- $total_rt = $end - $start;
- $tot_total_rt += $total_rt;
- $tot_rt += $rt;
-
- print OUTPUT "$rt\n";
- $sum_rt += $rt;
- $max_rt = $rt if $rt > $max_rt;
-}
-
-close INPUT;
-close OUTPUT;
-
-# Hack to fake a filter
-if ( $output eq $filter_output ) {
- system "cat $output";
- system "rm $output";
-}
-
-exit 0;
-
-# ---------------------------------------------------------------------------
-
-sub process_options {
- if ( $opt_h ) {
- open(ME,$0) || die "Can't open myself ($0)";
- $n = 0;
- while (<ME>) {
- last if $_ =~ /^$/;
- print $_;
- $n++;
- }
- close(ME);
-
- # system "cat $0 | awk 'BEGIN { n = 0; } \
- # /^$/ { print n; \
- # exit; } \
- # { n++; }'"
- exit ;
- }
-
- $input = $#ARGV == -1 ? "-" : $ARGV[0] ;
-
- if ( $#ARGV != 0 ) {
- #print "Usage: gran-extr [options] <sim-file>\n";
- #print "Use -h option to get details\n";
- #exit 1;
-
- }
-
- $filter_output = $ENV{'TMPDIR'} . "./,gr2RTS-out";
- if ( $opt_o ) {
- $output = $opt_o;
- } else {
- if ( $input eq "-" ) {
- $output = $filter_output;
- } else {
- $output = $input; # "RTS";
- $output =~ s/\.gr$/.rts/g;
- } #
- }
-}
-
-# ----------------------------------------------------------------------------
-
-sub print_verbose_message {
- print "Input file: $input\t Output file: $output\n";
-}
-
-# ----------------------------------------------------------------------------
diff --git a/ghc/utils/parallel/gr2ap.bash b/ghc/utils/parallel/gr2ap.bash
deleted file mode 100644
index 7818fe112b..0000000000
--- a/ghc/utils/parallel/gr2ap.bash
+++ /dev/null
@@ -1,124 +0,0 @@
-#!/usr/local/bin/bash
-##############################################################################
-# Time-stamp: <Wed Jul 24 1996 20:53:36 Stardate: [-31]7859.14 hwloidl>
-#
-# Usage: gr2ap [options] <gr-file>
-#
-# Create a per-thread activity graph from a GrAnSim (or GUM) profile.
-# Transform the log file of a GrAnSim run (a .gr file) into a quasi-parallel
-# profile (a .qp file) using gr2qp and then into a PostScript file using qp2ap.
-# The generated PostScript file shows one horizontal line for each task. The
-# thickness of the line indicates the state of the thread:
-# thick ... active, medium ... suspended, thin ... fetching remote data
-#
-# Options:
-# -o <file> ... write .ps file to <file>
-# -m ... create mono PostScript file instead a color one.
-# -O ... optimise i.e. try to minimise the size of the .ps file.
-# -v ... be talkative.
-# -h ... print help message (this header).
-#
-##############################################################################
-
-progname="`basename $0`"
-args="$*"
-
-verb=0
-help=0
-mono=""
-apfile=""
-optimise=""
-scale=""
-width=""
-
-getopts "hvmo:s:w:OD" name
-while [ "$name" != "?" ] ; do
- case $name in
- h) help=1;;
- v) verb=1;;
- m) mono="-m";;
- o) apfile="$OPTARG";;
- s) scale="-s $OPTARG";;
- w) width="-w $OPTARG";;
- O) optimise="-O";;
- D) debug="-D";;
- esac
- getopts "hvmo:s:w:OD" name
-done
-
-opts="$mono $optimise $scale $width"
-
-shift $[ $OPTIND - 1 ]
-
-if [ $help -eq 1 ]
- then no_of_lines=`cat $0 | awk 'BEGIN { n = 0; } \
- /^$/ { print n; \
- exit; } \
- { n++; }'`
- echo "`head -$no_of_lines $0`"
- exit
-fi
-
-
-if [ -z "$1" ]
- then echo "Usage: $progname [options] file[.gr]"
- echo "Use -h option for details"
- exit 1;
-fi
-
-f="`basename $1 .gr`"
-grfile="$f".gr
-qpfile="${TMPDIR:-.}/$f".qp
-ppfile="${TMPDIR:-.}/$f".pp
-
-if [ -z "$apfile" ]
- then apfile="$f"_ap.ps
-fi
-
-if [ $verb -eq 1 ]
- then echo "Input file: $grfile"
- echo "Quasi-parallel file: $qpfile"
- echo "PostScript file: $apfile"
- echo "Options forwarded to qp2ap: $opts"
- if [ "$mono" = "-m" ]
- then echo "Producing monochrome PS file"
- else echo "Producing color PS file"
- fi
- if [ "$debug" = "-D" ]
- then echo "Debugging is turned ON"
- else echo "Debugging is turned OFF"
- fi
-fi
-
-
-# unset noclobber
-
-if [ ! -f "$grfile" ]
- then
- echo "$grfile does not exist"
- exit 1
- else
- # rm -f "$qpfile" "$apfile"
- prog=`head -1 "$grfile" | sed -e 's/Granularity Simulation for //'`
- echo "$prog" >| "$qpfile"
- if [ $verb -eq 1 ]
- then echo "Executed program: $prog"
- fi
- date >> "$qpfile"
- #date="`date`" # This is the date of running the script
- date="`tail +2 $grfile | head -1 | sed -e 's/Start time: //'`"
- cat "$grfile" | gr2qp >> "$qpfile"
- # Sorting is part of gr2qp now.
- # | ghc-fool-sort | sort -n +0 -1 | ghc-unfool-sort >> "$qpfile"
- # max=`tail -2 "$qpfile" | awk '!/^Number of threads:/ { print $1; }'`
- xmax=`tail -1 "$qpfile" | awk '{ print $2; }'`
- ymax=`tail -1 "$qpfile" | awk '{ print $8; }'`
- if [ $verb -eq 1 ]
- then echo "Total runtime: $xmax"
- echo "Total number of tasks: $ymax"
- fi
- tail +3 "$qpfile" | qp2ap $opts "$xmax" "$ymax" "$prog" "$date" >| "$apfile"
- rm -f "$qpfile"
- # Old: qp2ap.pl $mono $max "$prog" "$date" < "$qpfile" > "$apfile"
-fi
-
diff --git a/ghc/utils/parallel/gr2gran.bash b/ghc/utils/parallel/gr2gran.bash
deleted file mode 100644
index d281d2c5bc..0000000000
--- a/ghc/utils/parallel/gr2gran.bash
+++ /dev/null
@@ -1,113 +0,0 @@
-#!/usr/local/bin/bash
-##############################################################################
-# Last modified: Time-stamp: <95/08/01 02:21:56 hwloidl>
-#
-# Usage: gr2gran [options] <sim-file>
-#
-# Create granularity graphs for the GrAnSim profile <sim-file>. This creates
-# a bucket statistics and a cumulative runtimes graph.
-# This script is derived from the much more complex gran-extr script, which
-# also produces such graphs and much more information, too.
-#
-# Options:
-# -t <file> ... use <file> as template file (<,> global <.> local template)
-# -p <file> ... use <file> as gnuplot .gp file (default: gran.gp)
-# -x <x-size> ... of gnuplot graph
-# -y <y-size> ... of gnuplot graph
-# -n <n> ... use <n> as number of PEs in title
-# -o <file> ... keep the intermediate <file> (sorted list of all runtimes)
-# -h ... help; print this text.
-# -v ... verbose mode.
-#
-##############################################################################
-
-progname="`basename $0`"
-args="$*"
-
-help=0
-verb=0
-template=""
-plotfile=""
-x=""
-y=""
-n=""
-rtsfile=""
-keep_rts=0
-
-getopts "hvt:p:x:y:n:o:" name
-while [ "$name" != "?" ] ; do
- case $name in
- h) help=1;;
- v) verb=1;;
- t) template="-t $OPTARG";;
- p) plotfile="-p $OPTARG";;
- x) x="-x $OPTARG";;
- y) y="-y $OPTARG";;
- n) n="-n $OPTARG";;
- o) rtsfile="$OPTARG";;
- esac
- getopts "hvt:p:x:y:n:o:" name
-done
-
-shift $[ $OPTIND - 1 ]
-
-if [ $help -eq 1 ]
- then no_of_lines=`cat $0 | awk 'BEGIN { n = 0; } \
- /^$/ { print n; \
- exit; } \
- { n++; }'`
- echo "`head -$no_of_lines $0`"
- exit
-fi
-
-if [ -z "$1" ]
- then echo "Usage: $progname [options] file[.gr]"
- echo "Use -h option for details"
- exit 1;
-fi
-
-f="`basename $1 .gr`"
-grfile="${f}.gr"
-if [ -z "$rtsfile" ]
- then rtsfile="${f}.rts"
- rtsopt="-o $rtsfile"
- else rtsopt="-o $rtsfile"
- keep_rts=1
-fi
-
-opts_RTS="$rtsopt "
-opts_ps="$template $plotfile $x $y $n "
-
-if [ $verb -eq 1 ]
- then echo "Input file: $grfile"
- if [ ${keep_rts} -eq 1 ]
- then echo "Intermediate file: $rtsfile (kept after termination)"
- else echo "Intermediate file: $rtsfile (discarded at end)"
- fi
- verb_opt="-v "
- opts_RTS="${opts_RTS} $verb_opt "
- opts_ps="${opts_ps} $verb_opt "
- echo "Options for gr2RTS: ${opts_RTS}"
- echo "Options for RTS2gran: ${opts_ps}"
-fi
-
-
-# unset noclobber
-if [ ! -f "$grfile" ]
- then
- echo "$grfile does not exist"
- exit 1
- else
- # rm -f "$rtsfile"
- if [ $verb -eq 1 ]
- then echo "gr2RTS ..."
- fi
- gr2RTS ${opts_RTS} $grfile
- if [ $verb -eq 1 ]
- then echo "RTS2gran ..."
- fi
- RTS2gran ${opts_ps} $rtsfile
- if [ ${keep_rts} -ne 1 ]
- then rm -f $rtsfile
- fi
-fi
diff --git a/ghc/utils/parallel/gr2java.pl b/ghc/utils/parallel/gr2java.pl
deleted file mode 100644
index acd0b5e631..0000000000
--- a/ghc/utils/parallel/gr2java.pl
+++ /dev/null
@@ -1,322 +0,0 @@
-#!/usr/local/bin/perl
-##############################################################################
-#
-# Usage: gr2java [options]
-#
-# Filter that transforms a GrAnSim profile (a .gr file) at stdin to
-# a quasi-parallel profile (a .qp file). It is the common front-end for most
-# visualization tools (except gr2pe). It collects running,
-# runnable and blocked tasks in queues of different `colours', whose meaning
-# is:
-# G ... green; queue of all running tasks
-# A ... amber; queue of all runnable tasks
-# R ... red; queue of all blocked tasks
-# Y ... cyan; queue of fetching tasks
-# C ... crimson; queue of tasks that are being stolen
-# B ... blue; queue of all sparks
-#
-# Options:
-# -i <int> ... info level from 1 to 7; number of queues to count (see qp3ps)
-# -I <str> ... count tasks that are in one of the given queues; encoding:
-# 'a' ... active (running)
-# 'r' ... runnable
-# 'b' ... blocked
-# 'f' ... fetching
-# 'm' ... migrating
-# 's' ... sparks
-# (e.g. -I "arb" counts sum of active, runnable, blocked tasks)
-# -c ... check consistency of data (e.g. no neg. number of tasks)
-# -v ... be talkative.
-# -h ... print help message (this header).
-#
-##############################################################################
-
-require "getopts.pl";
-
-&Getopts('hvDSci:I:');
-
-do process_options();
-
-if ( $opt_v ) {
- do print_verbose_message();
-}
-
-# ---------------------------------------------------------------------------
-# Init
-# ---------------------------------------------------------------------------
-
-$max = 0;
-$pmax = 0;
-$ptotal = 0;
-$n = 0;
-
-$active = 0;
-$runnable = 0;
-$blocked = 0;
-$fetching = 0;
-$migrating = 0;
-$sparks = 0;
-
-$improved_sort_option = $opt_S ? "-S" : "";
-
-open (FOOL,"| ghc-fool-sort $improved_sort_option | sort -n +0 -1 | ghc-unfool-sort") || die "FOOL";
-
-$in_header = 9;
-while(<>) {
- if ( $in_header == 9 ) {
- if (/^=/) {
- $gum_style_gr = 1;
- $in_header = 0;
- } else {
- $gum_style_gr = 0;
- $in_header = 1;
- }
-
- }
- if (/^\++$/) {
- $in_header=0;
- next;
- }
- next if $in_header;
- next if /^$/;
- next if /^=/;
- chop;
- ($PE, $pe, $time, $act, $tid, $rest) = split;
- $time =~ s/[\[\]:]//g;
- # next if $act eq 'REPLY';
- chop($tid) if $act eq 'END';
- $from = $queue{$tid};
- $extra = "";
- if ($act eq 'START') {
- $from = '*';
- $to = 'G';
- $n++;
- if ( $n > $pmax ) { $pmax = $n; }
- $ptotal++;
- } elsif ($act eq 'START(Q)') {
- $from = '*';
- $to = 'A';
- $n++;
- if ( $n > $pmax ) { $pmax = $n; }
- $ptotal++;
- } elsif ($act eq 'STEALING') {
- $to = 'C';
- } elsif ($act eq 'STOLEN') {
- $to = 'G';
- } elsif ($act eq 'STOLEN(Q)') {
- $to = 'A';
- } elsif ($act eq 'FETCH') {
- $to = 'Y';
- } elsif ($act eq 'REPLY') {
- $to = 'R';
- } elsif ($act eq 'BLOCK') {
- $to = 'R';
- } elsif ($act eq 'RESUME') {
- $to = 'G';
- $extra = " 0 0x0";
- } elsif ($act eq 'RESUME(Q)') {
- $to = 'A';
- $extra = " 0 0x0";
- } elsif ($act eq 'END') {
- $to = '*';
- $n--;
- if ( $opt_c && $n < 0 ) {
- print STDERR "Error at time $time: neg. number of tasks: $n\n";
- }
- } elsif ($act eq 'SCHEDULE') {
- $to = 'G';
- } elsif ($act eq 'DESCHEDULE') {
- $to = 'A';
- # The following are only needed for spark profiling
- } elsif (($act eq 'SPARK') || ($act eq 'SPARKAT')) {
- $from = '*';
- $to = 'B';
- } elsif ($act eq 'USED') {
- $from = 'B';
- $to = '*';
- } elsif ($act eq 'PRUNED') {
- $from = 'B';
- $to = '*';
- } elsif ($act eq 'EXPORTED') {
- $from = 'B';
- $to = 'B';
- } elsif ($act eq 'ACQUIRED') {
- $from = 'B';
- $to = 'B';
- } else {
- print STDERR "Error at time $time: unknown event $act\n";
- }
- $queue{$tid} = $to;
-
- if ( $from eq '' ) {
- print STDERRR "Error at time $time: process $tid has no from queue\n";
- }
- if ($to ne $from) {
- print FOOL $time, " ", $pe, " ",
- $from, $to, "\n";
- }
-
- if ($to ne $from) {
- # Compare with main loop in qp3ps
- if ($from eq '*') {
- } elsif ($from eq 'G') {
- --$active;
- } elsif ($from eq 'A') {
- --$runnable;
- } elsif ($from eq 'R') {
- --$blocked;
- } elsif ($from eq 'B') {
- --$sparks;
- } elsif ($from eq 'C') {
- --$migrating;
- } elsif ($from eq 'Y') {
- --$fetching;
- } else {
- print STDERR "Illegal from char: $from at $time\n";
- }
-
- if ($to eq '*') {
- } elsif ($to eq 'G') {
- ++$active;
- } elsif ($to eq 'A') {
- ++$runnable;
- } elsif ($to eq 'R') {
- ++$blocked;
- } elsif ($to eq 'B') {
- ++$sparks;
- } elsif ($to eq 'C') {
- ++$migrating;
- } elsif ($to eq 'Y') {
- ++$fetching;
- } else {
- print STDERR "Illegal to char: $to at $time\n";
- }
-
- }
-
- $curr = &count();
- if ( $curr > $max ) {
- $max = $curr;
- }
-
- if ( 0 ) {
- print STDERR "%% $time: (act,runnable,blocked,fetch,mig,sp) = " .
- "($active, $runnable, $blocked, $fetching, $migrating, $sparks)".
- " max = $max\n" ;
- }
-
- #print STDERR "Sparks @ $time: $sparks \tCurr: $curr \tMax: $max \n" if $opt_D;
-
- if ( $time > $tmax ) {
- $tmax = $time;
- }
- delete $queue{$tid} if $to eq '*';
-
-}
-
-print "Time: ", $tmax, " Max_selected_tasks: ", $max,
- " Max_running_tasks: ", $pmax, " Total_tasks: ", $ptotal, "\n";
-
-close(FOOL);
-
-exit 0;
-
-# +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-# Copied from qp3ps and slightly modified (we don't keep a list for each queue
-# but just compute the max value we get out of all calls to count during the
-# execution of the script).
-# -----------------------------------------------------------------------------
-
-# -----------------------------------------------------------------------------
-
-sub queue_on {
- local ($queue) = @_;
-
- return index($show,$queue)+1;
-}
-
-# -----------------------------------------------------------------------------
-
-sub count {
- local ($res);
-
- $res = (($queue_on_a) ? $active : 0) +
- (($queue_on_r) ? $runnable : 0) +
- (($queue_on_b) ? $blocked : 0) +
- (($queue_on_f) ? $fetching : 0) +
- (($queue_on_m) ? $migrating : 0) +
- (($queue_on_s) ? $sparks : 0);
-
- return $res;
-}
-
-# -----------------------------------------------------------------------------
-# DaH 'oH lo'lu'Qo'
-# -----------------------------------------------------------------------------
-
-sub set_values {
- local ($samples,
- $active,$runnable,$blocked,$fetching,$sparks,$migrating) = @_;
-
- $G[$samples] = queue_on_a ? $active : 0;
- $A[$samples] = queue_on_r ? $runnable : 0;
- $R[$samples] = queue_on_b ? $blocked : 0;
- $Y[$samples] = queue_on_f ? $fetching : 0;
- $B[$samples] = queue_on_s ? $sparks : 0;
- $C[$samples] = queue_on_m ? $migrating : 0;
-}
-
-# -----------------------------------------------------------------------------
-
-sub process_options {
- if ( $opt_h ) {
- open(ME,$0) || die "Can't open myself ($0): $!\n";
- $n = 0;
- while (<ME>) {
- last if $_ =~ /^$/;
- print $_;
- $n++;
- }
- close(ME);
- exit ;
- }
-
- $show = "armfb";
-
- if ( $opt_i ) {
- $show = "a" if info_level == 1;
- $show = "ar" if info_level == 2;
- $show = "arb" if info_level == 3;
- $show = "arfb" if info_level == 4;
- $show = "armfb" if info_level == 5;
- $show = "armfbs" if info_level == 6;
- }
-
- if ( $opt_I ) {
- $show = $opt_I;
- }
-
- if ( $opt_v ){
- $verbose = 1;
- }
-
- $queue_on_a = &queue_on("a");
- $queue_on_r = &queue_on("r");
- $queue_on_b = &queue_on("b");
- $queue_on_f = &queue_on("f");
- $queue_on_s = &queue_on("s");
- $queue_on_m = &queue_on("m");
-}
-
-sub print_verbose_message {
-
- print STDERR "Info-str: $show\n";
- print STDERR "The following queues are turned on: " .
- ( $queue_on_a ? "active, " : "") .
- ( $queue_on_r ? "runnable, " : "") .
- ( $queue_on_b ? "blocked, " : "") .
- ( $queue_on_f ? "fetching, " : "") .
- ( $queue_on_m ? "migrating, " : "") .
- ( $queue_on_s ? "sparks" : "") .
- "\n";
-}
diff --git a/ghc/utils/parallel/gr2jv.bash b/ghc/utils/parallel/gr2jv.bash
deleted file mode 100644
index 7eeacfe556..0000000000
--- a/ghc/utils/parallel/gr2jv.bash
+++ /dev/null
@@ -1,123 +0,0 @@
-#!/usr/local/bin/bash
-##############################################################################
-# Time-stamp: <Wed Jul 24 1996 20:38:02 Stardate: [-31]7859.09 hwloidl>
-#
-# Usage: gr3jv [options] <gr-file>
-#
-# Create a per-thread activity graph from a GrAnSim (or GUM) profile.
-# Transform the log file of a GrAnSim run (a .gr file) into a quasi-parallel
-# profile (a .qp file) using gr3qp and then into a PostScript file using qp3ap.
-# The generated PostScript file shows one horizontal line for each task. The
-# thickness of the line indicates the state of the thread:
-# thick ... active, medium ... suspended, thin ... fetching remote data
-#
-# Options:
-# -o <file> ... write .ps file to <file>
-# -m ... create mono PostScript file instead a color one.
-# -O ... optimise i.e. try to minimise the size of the .ps file.
-# -v ... be talkative.
-# -h ... print help message (this header).
-#
-##############################################################################
-
-progname="`basename $0`"
-args="$*"
-
-verb=0
-help=0
-mono=""
-apfile=""
-optimise=""
-scale=""
-width=""
-
-getopts "hvmo:s:w:OD" name
-while [ "$name" != "?" ] ; do
- case $name in
- h) help=1;;
- v) verb=1;;
- m) mono="-m";;
- o) apfile="$OPTARG";;
- s) scale="-s $OPTARG";;
- w) width="-w $OPTARG";;
- O) optimise="-O";;
- D) debug="-D";;
- esac
- getopts "hvmo:s:w:OD" name
-done
-
-opts="$mono $optimise $scale $width"
-
-shift $[ $OPTIND - 1 ]
-
-if [ $help -eq 1 ]
- then no_of_lines=`cat $0 | awk 'BEGIN { n = 0; } \
- /^$/ { print n; \
- exit; } \
- { n++; }'`
- echo "`head -$no_of_lines $0`"
- exit
-fi
-
-
-if [ -z "$1" ]
- then echo "Usage: $progname [options] file[.gr]"
- echo "Use -h option for details"
- exit 1;
-fi
-
-f="`basename $1 .gr`"
-grfile="$f".gr
-qpfile="$f".qp
-ppfile="$f".pp
-jvfile="$f".jv
-
-if [ -z "$apfile" ]
- then apfile="$f"-ap.ps
-fi
-
-if [ $verb -eq 1 ]
- then echo "Input file: $grfile"
- echo "Quasi-parallel file: $qpfile"
- echo "PostScript file: $apfile"
- echo "Options forwarded to qp3ap: $opts"
- if [ "$mono" = "-m" ]
- then echo "Producing monochrome PS file"
- else echo "Producing color PS file"
- fi
- if [ "$debug" = "-D" ]
- then echo "Debugging is turned ON"
- else echo "Debugging is turned OFF"
- fi
-fi
-
-
-# unset noclobber
-
-if [ ! -f "$grfile" ]
- then
- echo "$grfile does not exist"
- exit 1
- else
- # rm -f "$qpfile" "$apfile"
- prog=`head -1 "$grfile" | sed -e 's/Granularity Simulation for //'`
- echo "$prog" >| "$jvfile"
- if [ $verb -eq 1 ]
- then echo "Executed program: $prog"
- fi
- date >> "$jvfile"
- #date="`date`" # This is the date of running the script
- date="`tail +2 $grfile | head -1 | sed -e 's/Start-Time: //'`"
- cat "$grfile" | gr2java >> "$jvfile"
- # Sorting is part of gr2qp now.
- # | ghc-fool-sort | sort -n +0 -1 | ghc-unfool-sort >> "$qpfile"
- # max=`tail -2 "$qpfile" | awk '!/^Number of threads:/ { print $1; }'`
- xmax=`tail -1 "$jvfile" | awk '{ print $2; }'`
- ymax=`tail -1 "$jvfile" | awk '{ print $8; }'`
- if [ $verb -eq 1 ]
- then echo "Total runtime: $xmax"
- echo "Total number of tasks: $ymax"
- fi
- # Old: qp2ap.pl $mono $max "$prog" "$date" < "$qpfile" > "$apfile"
-fi
-
diff --git a/ghc/utils/parallel/gr2pe.pl b/ghc/utils/parallel/gr2pe.pl
deleted file mode 100644
index 6026300758..0000000000
--- a/ghc/utils/parallel/gr2pe.pl
+++ /dev/null
@@ -1,1434 +0,0 @@
-#!/usr/local/bin/perl
-# (C) Hans Wolfgang Loidl, November 1994
-# ############################################################################
-# Time-stamp: <Fri Jun 14 1996 20:21:17 Stardate: [-31]7659.03 hwloidl>
-#
-# Usage: gr2pe [options] <gr-file>
-#
-# Create per processor activity profile (as ps-file) from a given gr-file.
-#
-# Options:
-# -o <file> ... output file (ps file) has name <file>
-# -m ... produce monochrome output
-# -M ... produce a migration graph
-# -S ... produce a spark graph in a separate file (based on the no. of
-# sparks rather than the no. of runnable threads)
-# -t ... produce trace of runnable, blocked, fetching threads
-# -i <n> ... ``infinity'' for number of blocked tasks (default: 20)
-# all values larger than that are shown with the same width
-# -C ... do consistency check at each event (mainly for debugging)
-# -h ... print help message (this text)
-# -v ... be talkative
-#
-# ############################################################################
-
-# die "This script is still under development -- HWL\n";
-
-# ----------------------------------------------------------------------------
-# Command line processing and initialization
-# ----------------------------------------------------------------------------
-
-require "getopts.pl";
-
-&Getopts('hvDCMNmSGti:o:l:p:');
-
-do process_options();
-
-if ( $opt_v ) {
- do print_verbose_message();
-}
-
-# ----------------------------------------------------------------------------
-# Global Variables
-# ----------------------------------------------------------------------------
-
-$RUNNING = "RUNNING";
-$RUNNABLE = "RUNNABLE";
-$BLOCKED = "BLOCKED";
-$START = "START";
-$END = "END";
-
-# Modes for hline
-#$LITERATE = 1;
-#$NORMALIZING = 2;
-
-%GRAY = (
- $RUNNING, 0.6,
- $RUNNABLE, 0.3,
- $BLOCKED, 0,
- $START, 0,
- $END, 0.5);
-
-# Special value showing that no task is running on $pe if in $running[$pe]
-$NO_ID = -1;
-$NO_LAST_BG = $NO_LAST_BLOCKED = $NO_LAST_START = -1;
-
-# The number of PEs we have
-$nPEs = 32;
-
-# Unit (in pts) of the width for BLOCKED and RUNNABLE line segments
-$width_unit = 1;
-
-# Width of line for RUNNING
-$running_width = 1;
-
-# Offset of BLOCKED and RUNNABLE lines from the center line
-$offset = 10;
-
-# Left and right border of the picture; Width of the picture
-$left_border = 0;
-$right_border = 700;
-$total_width = $right_border - $left_border;
-$x_scale = 1;
-
-# Height of the picture measured from y-val of first to y-val of last PE
-$lower_border = 10;
-$upper_border = 490;
-$total_height = $upper_border - $lower_border;
-$y_scale = 1;
-
-# Constant from where shrinking of x-values (+scaling as usual) is enabled
-$very_big = 1E8;
-
-# Factor by which the x values are shrunk (if very big)
-$shrink_x = 10000;
-
-# Set format of output of numbers
-$# = "%.2g";
-
-# Width of stripes in migration graph
-$tic_width = 2;
-
-# If no spark profile should be generate we count the number of spark events
-# in the profile to inform the user about existing spark information
-if ( !$opt_S ) {
- $spark_events = 0;
-}
-
-# ----------------------------------------------------------------------------
-# The real thing starts here
-# ----------------------------------------------------------------------------
-
-open (IN,"<$input") || die "$input: $!\n";
-open (OUT,">$output") || die "$output: $!\n";
-open (OUT_MIG,">$output_mig") || die "$output_mig: $!\n" if $opt_M;
-open (OUT_SP,">$output_sp") || die "$output_sp: $!\n" if $opt_S;
-# open (OUT_B,">$output_b") || die "$output_b: $!\n";
-# open (OUT_R,">$output_r") || die "$output_r: $!\n";
-
-open(OUT_RA, ">$RUNNABLE_file") || die "$RUNNABLE_file: $!\n" if $opt_t;
-print OUT_RA "# Number of Runnable tasks on all PEs $i\n" if $opt_t;
-open(OUT_BA, ">$BLOCKED_file") || die "$BLOCKED_file: $!\n" if $opt_t;
-print OUT_BA "# Number of Blocked tasks on all PEs $i\n" if $opt_t;
-open(OUT_FA, ">$FETCHING_file") || die "$FETCHING_file: $!\n" if $opt_t;
-print OUT_FA "# Number of Fetching tasks on all PEs $i\n" if $opt_t;
-
-($pname,$pars,$nPEs,$lat) = &skip_header(IN);
-
-
-# Fill in the y_val table for all PEs
-$offset = (&generate_y_val_table($nPEs)/2);
-
-$x_min = 0;
-$x_max = &get_x_max($input);
-$y_max = $total_height;
-#$y_max = $y_val[$nPEs-1] + offset;
-
-$is_very_big = $x_max > $very_big;
-
-# Max width allowed when drawing lines for BLOCKED, RUNNABLE tasks
-$max_width = $offset;
-
-# General init
-do init($nPEs);
-
-do write_prolog(OUT,$x_max,$y_max);
-do write_prolog(OUT_MIG,$x_max,$y_max) if $opt_M;
-do write_prolog(OUT_SP,$x_max,$y_max) if $opt_S;
-# do write_prolog(OUT_B,$x_max,$y_max);
-# do write_prolog(OUT_R,$x_max,$y_max);
-
-while (<IN>) {
- next if /^$/; # Omit empty lines;
- next if /^--/; # Omit comment lines;
-
- ($event, $time, $id, $pe) = &get_line($_);
- $x_max_ = $time if $time > $x_max_;
-
- print OUT_RA "TIME: $time PEs: " . join(", ",@runnable) .
- " SUM: " . &list_sum(@runnable) . "\n" if $opt_t;
- print OUT_BA "TIME: $time PEs: " . join(", ",@blocked) .
- " SUM: " . &list_sum(@blocked) . "\n" if $opt_t;
- print OUT_FA "TIME: $time PEs: " . join(", ",@fetching) .
- " SUM: " . &list_sum(@fetching) . "\n" if $opt_t;
-
- foo : {
- ($event eq "START") && do {
- # do draw_tic($pe, $time, $START);
- do draw_bg($pe, $time);
- $last_bg[$pe] = $time;
- $running[$pe] = $id;
- # $where{$id} = $pe + 1;
- last foo;
- };
- ($event eq "START(Q)") && do {
- #do draw_segment($pe, $time, $RUNNABLE);
- do draw_bg($pe, $time);
- $last_bg[$pe] = $time;
- #$last_runnable[$pe] = $time;
- $runnable[$pe]++;
- # $where{$id} = $pe + 1;
- last foo;
- };
- ($event eq "STEALING") && do {
- do draw_bg($pe, $time);
- $last_bg[$pe] = $time;
- $runnable[$pe]--;
- $where{$id} = $pe + 1;
- if ( $opt_M ) {
- $when{$id} = $time;
- do draw_tic($pe, $time, $event);
- }
- last foo;
- };
- ($event eq "STOLEN") && do {
- # do draw_tic($pe, $time, $START);
- do draw_bg($pe, $time);
- $last_bg[$pe] = $time;
- $running[$pe] = $id;
- if ( $where{$id} ) {
- # Ok
- } else {
- $warn++;
- print "WARNING: No previous location for STOLEN task $id found!" .
- " Check the gr file!\n";
- }
- if ( $opt_M ) {
- do draw_tic($pe, $time, $event);
- do draw_arrow($where{$id}-1,$pe,$when{$id},$time);
- }
- last foo;
- };
- ($event eq "STOLEN(Q)") && do {
- #do draw_segment($pe, $time, $RUNNABLE);
- do draw_bg($pe, $time);
- $last_bg[$pe] = $time;
- #$last_runnable[$pe] = $time;
- $runnable[$pe]++;
- if ( $where{$id} ) {
- # Ok
- } else {
- $warn++;
- print "WARNING: No previous location for STOLEN(Q) task $id found!" .
- " Check the gr file!\n";
- }
- if ( $opt_M ) {
- do draw_tic($pe, $time, $event);
- do draw_arrow($where{$id}-1,$pe,$when{$id},$time);
- }
- last foo;
- };
- ($event eq "BLOCK") && do {
- do draw_bg($pe, $time);
- $last_bg[$pe] = $time;
- do draw_segment($pe, $time, $BLOCKED) unless $blocked[$pe] == 0 ;
- $last_blocked[$pe] = $time;
- #do draw_segment($pe, $time, $RUNNING);
- $blocked[$pe]++;
- $running[$pe] = $NO_ID;
- last foo;
- };
- ($event eq "RESUME") && do {
- # do draw_tic($pe, $time, $START);
- do draw_bg($pe, $time);
- $last_bg[$pe] = $time;
- do draw_segment($pe, $time, $BLOCKED);
- $last_blocked[$pe] = $time;
- $blocked[$pe]--;
- $running[$pe] = $id;
- last foo;
- };
- ($event eq "RESUME(Q)") && do {
- #do draw_segment($pe, $time, $RUNNABLE);
- do draw_bg($pe, $time);
- $last_bg[$pe] = $time;
- do draw_segment($pe, $time, $BLOCKED);
- $last_blocked[$pe] = $time;
- #$last_runnable[$pe] = $time;
- $blocked[$pe]--;
- $runnable[$pe]++;
- last foo;
- };
- ($event eq "END") && do {
- # do draw_tic($pe, $time, $END);
- do draw_bg($pe, $time);
- $last_bg[$pe] = $time;
- $running[$pe] = $NO_ID;
- # do draw_segment($pe, $time, $RUNNING);
- # $last_blocked[$pe] = $time;
- last foo;
- };
- ($event eq "SCHEDULE") && do {
- # do draw_tic($pe, $time);
- $last_start[$pe] = $time;
- do draw_bg($pe, $time);
- $last_bg[$pe] = $time;
- $runnable[$pe]--;
- $running[$pe] = $id;
- last foo;
- };
- # NB: Check these; they are not yet tested
- ($event eq "FETCH") && do {
- # Similar to BLOCK; but don't draw a block segment
- do draw_bg($pe, $time);
- $last_bg[$pe] = $time;
- #do draw_segment($pe, $time, $BLOCKED) unless $blocked[$pe] == 0 ;
- #$last_blocked[$pe] = $time;
- #$blocked[$pe]++;
- $fetching[$pe]++;
- $running[$pe] = $NO_ID;
- last foo;
- };
- ($event eq "REPLY") && do {
- do draw_bg($pe, $time);
- $last_bg[$pe] = $time;
- #do draw_segment($pe, $time, $BLOCKED);
- #$last_blocked[$pe] = $time;
- #$blocked[$pe]--;
- $fetching[$pe]--;
- $blocked[$pe]++;
- last foo;
- };
- # These are only processed if a spark pofile is generated, too
- (($event eq "SPARK") || ($event eq "SPARKAT") || ($event eq "ACQUIRED")) && do {
- if ( !opt_S ) {
- $spark_events++;
- last foo;
- }
- do draw_sp_bg($pe, $time);
- $last_sp_bg[$pe] = $time;
- $sparks[$pe]++;
- last foo;
- };
-
- (($event eq "USED") || ($event eq "PRUNED") || ($event eq "EXPORTED")) && do {
- if ( !opt_S ) {
- $spark_events++;
- last foo;
- }
- do draw_sp_bg($pe, $time);
- $last_sp_bg[$pe] = $time;
- $sparks[$pe]--;
- if ( $sparks[$pe]<0 ) {
- print STDERR "Error: Neg. number of sparks @ $time\n";
- }
- last foo;
- };
-
- $warn++;
- print "WARNING: Unknown event: $event\n";
- }
- do check_consistency() if $opt_M;
-}
-
-do write_epilog(OUT,$x_max,$y_max);
-do write_epilog(OUT_MIG,$x_max,$y_max) if $opt_M;
-do write_epilog(OUT_SP,$x_max,$y_max) if $opt_S;
-# do write_epilog(OUT_B,$x_max,$y_max);
-# do write_epilog(OUT_R,$x_max,$y_max);
-
-close(IN);
-close(OUT);
-# close(OUT_B);
-# close(OUT_R);
-
-close(OUT_MIG) if $opt_M;
-close(OUT_SP) if $opt_S;
-close(OUT_BA) if $opt_t;
-close(OUT_RA) if $opt_t;
-close(OUT_FA) if $opt_t;
-
-#for ($i=0; $i<$nPEs; $i++) {
-# close($OUT_BA[$i]);
-# close($OUT_RA[$i]);
-#}
-
-if ($x_max != $x_max_ ) {
- print STDERR "WARNING: Max time ($x_max_) is different from time of last event ($x_max)\n";
-}
-
-print "Number of suppressed warnings: $warn\n" if $warn>0;
-print "FYI: The file $input contains $spark_events lines of spark information\n" if !opt_S && ($spark_events>0);
-
-system "gzip -f1 $RUNNABLE_file" if $opt_t;
-system "gzip -f1 $BLOCKED_file" if $opt_t;
-system "gzip -f1 $FETCHING_file" if $opt_t;
-
-system "fortune -s" if $opt_v;
-
-exit 0;
-
-# ----------------------------------------------------------------------------
-# This translation is mainly taken from gr2qp.awk
-# This subroutine returns the event found on the current line together with
-# the relevant information for that event. The possible EVENTS are:
-# START, STARTQ, STOLEN, BLOCK, RESUME, RESUMEQ, END, SCHEDULE
-# ----------------------------------------------------------------------------
-
-sub get_line {
- local ($line) = @_;
- local ($f, @fs);
- local ($event, $time, $id, $pe);
-
- @fs = split(/[:\[\]\s]+/,$line);
- $event = $fs[3];
- $time = $fs[2];
- $id = $fs[4];
- $pe = $fs[1];
-
- print OUT "% > " . $_ if $opt_D;
- print OUT "% EVENT = $event; TIME = $time; ID = $id; PE = $pe\n" if $opt_D;
- print OUT "% --> this task comes from PE " . ($where{$id}-1) . "\n" if $opt_D && $event eq "STOLEN";
-
- return ($event, $time, $id, $pe);
-
- # if ($fs[3] eq "START") {
- # partprofile = 0;
- # print (substr($3,2,length($3)-3))," *G 0 0x" $5;
- # }
- # if ($fs[3] eq "START(Q)") {
- # print (substr($3,2,length($3)-3))," *A 0 0x" $5;
- # }
-
- # if ($fs[3] eq "STOLEN") {
- # print (substr($3,2,length($3)-3))," AG 0 0x" $5;
- # }
-
- # if ($fs[3] eq "BLOCK") {
- # print (substr($3,2,length($3)-3))," GR 0 0x" $5;
- # }
- # if ($fs[3] eq "RESUME") {
- # print (substr($3,2,length($3)-3))," RG 0 0x" $5, "0 0x0";
- # }
- # if ($fs[3] eq "RESUME(Q)") {
- # print (substr($3,2,length($3)-3))," RA 0 0x" $5, "0 0x0";
- # }
- # if ($fs[3] eq "END") {
- # if (partprofile) {
- # p rint (substr($9,1,length($9)-1))," *G 0 0x" (substr($5,1,length($5)-1));
- # p rint (substr($3,2,length($3)-3))," G* 0 0x" (substr($5,1,length($5)-1));
- # } else {
- # print (substr($3,2,length($3)-3))," G* 0 0x" (substr($5,1,length($5)-1));
- # }
- # }
- # if ($fs[3] eq "SCHEDULE") {
- # print (substr($3,2,length($3)-3))," AG 0 0x" $5;
- # }
-
-}
-
-# ----------------------------------------------------------------------------
-
-sub check_consistency {
- local ($i);
-
- for ($i=0; $i<$nPEs; $i++) {
- if ( $runnable[$i] < 0 ) {
- print "INCONSISTENCY: PE $i: Size of runnable queue: $runnable[$i] at time $time\n";
- $runnable[$i] = 0 ;
- }
- if ( $blocked[$i] < 0 ) {
- print "INCONSISTENCY: PE $i: Size of blocked queue: $blocked[$i] at time $time\n";
- $blocked[$i] = 0 ;
- }
- }
-}
-
-# ----------------------------------------------------------------------------
-
-sub get_width {
- local ($n, $type) = @_;
-
- $warn++ if $n <0;
- print "WARNING: Neg. number of tasks in $type queue: $n!!\n" if $n <0;
- $n = 0 if $n <0;
- return ( ($type eq $RUNNING) ? ($running_width * $width_unit) :
- &min($max_width, $n * $width_unit) );
-}
-
-# ----------------------------------------------------------------------------
-# Use an intensity between 0 (empty runnable queue) and 1 (`full' runnable
-# queue) to abstract from monchrome/color values
-# The concrete grayshade/color is computed via PS macros.
-# ----------------------------------------------------------------------------
-
-sub get_intensity {
- local ($n) = @_;
-
- print "SEVERE WARNING: get_intensity: Negative size of runnable queue\n" if $n<0;
-
- if ($n >= $inf_block) {
- return 1.0;
- } else {
- return ($n+1)/$inf_block;
- }
-}
-
-# ----------------------------------------------------------------------------
-
-sub get_sp_intensity {
- local ($n) = @_;
-
- print "SEVERE WARNING: get_sp_intensity: Negative size of sparks queue\n" if $n<0;
-
- if ($n >= $inf_block) {
- return 1.0;
- } else {
- return ($n+1)/$inf_block;
- }
-}
-
-# ----------------------------------------------------------------------------
-
-sub get_shade {
- local ($n) = @_;
-
-
- if ($n > $inf_block) {
- return 0.2;
- } else {
- return 0.8 - ($n/$inf_block);
- }
-}
-
-# ----------------------------------------------------------------------------
-
-sub max {
- local($x, $y) = @_;
-
- return ($x>$y ? $x : $y);
-}
-
-# ----------------------------------------------------------------------------
-
-sub min {
- local($x, $y) = @_;
-
- return ($x<$y ? $x : $y);
-}
-
-# ----------------------------------------------------------------------------
-
-sub list_sum {
- local (@list) = @_;
-
- local ($sum);
-
- foreach $x (@list) {
- $sum += $x;
- }
-
- return ($sum);
-}
-
-# ----------------------------------------------------------------------------
-# Drawing functions.
-# Put on top of funtions that directly generate PostScript.
-# ----------------------------------------------------------------------------
-
-sub draw_segment {
- local ($pe, $time, $type) = @_;
- local ($x, $y, $width, $gray);
-
- if ( $type eq $BLOCKED ) {
- if ( $last_blocked[$pe] == $NO_LAST_BLOCKED ) { return; };
- $width = &get_width($blocked[$pe], $type);
- if ( $width == 0 ) { return; };
- $y = $stripes_low[$pe] + int($width/2 + 0.5);
- $x = $last_blocked[$pe];
-
- if ( $is_very_big ) {
- $x = int($x/$shrink_x) + 1; # rounded up
- }
-
- # $gray = 0.5; # Ignoring gray level; doesn't change!
- do ps_draw_hline(OUT,$x,$y,$time,$width);
- } else {
- die "ERROR: Unknow type of line: $type in draw segment\n";
- }
-
- if ($x < 0 || $y<0) {
- die "Impossiple arguments for ps_draw_hline: ($x,$y); type=$type\n";
- }
- if ($width<0 || $width>$max_width || $gray <0 || $gray > 1) {
- die "Impossible arguments to ps_draw_hline: width=$width; gray=$gray\n";
- }
-}
-
-# ----------------------------------------------------------------------------
-
-sub draw_tic {
- local ($pe, $time, $event) = @_;
- local ($x, $y, $lit);
-
- $ystart = $stripes_low[$pe];
- $yend = $stripes_high[$pe];
- $x = $time;
- if ( $event eq "STEALING" ) {
- $lit = 0; # i.e. FROM
- } elsif ( ( $event eq "STOLEN") || ( $event eq "STOLEN(Q)" ) ) {
- $lit = 1; # i.e. TO
- } else {
- die "ERROR: Wrong event $event in draw_tic\n";
- }
-
- if ( $is_very_big ) {
- $x = int($x/$shrink_x) + 1; # rounded up
- }
-
- if ($x < 0 || $ystart<0 || $yend<0) {
- die "Impossiple arguments for ps_draw_tic: ($x,$ystart,$yend); PE=$pe\n";
- }
- do ps_draw_tic(OUT_MIG,$x,$ystart,$yend,$lit);
-}
-
-# ----------------------------------------------------------------------------
-
-sub draw_bg {
- local ($pe,$time) = @_;
- local ($x_start, $x_end, $intensity, $secondary_intensity);
-
- if ( $last_bg[$pe] == $NO_LAST_BG ) {
- print OUT "% Omitting BG: NO LAST BG\n" if $opt_D;
- return;
- }
- if ( $running[$pe] == $NO_ID ) {
- print OUT "% BG: NO RUNNING PE -> idle bg\n" if $opt_D;
- # return;
- }
- $x_start = $last_bg[$pe];
- $x_end = $time;
- $intensity = ( $running[$pe] == $NO_ID ?
- 0 :
- &get_intensity($runnable[$pe]) );
- $secondary_intensity = ( $running[$pe] == $NO_ID ?
- 0 :
- &get_intensity($fetching[$pe]) );
- do ps_draw_bg(OUT,$x_start, $x_end, $stripes_low[$pe], $stripes_high[$pe],
- $intensity,$secondary_intensity);
-
- if ( $opt_M ) {
- do ps_draw_hline(OUT_MIG, $x_start, $stripes_low[$pe], $x_end,
- $mig_width);
- }
-
-}
-
-# ----------------------------------------------------------------------------
-# Variant of draw_bg; used for spark profile
-# ----------------------------------------------------------------------------
-
-sub draw_sp_bg {
- local ($pe,$time) = @_;
- local ($x_start, $x_end, $intensity, $secondary_intensity);
-
- if ( $last_sp_bg[$pe] == $NO_LAST_BG ) {
- print OUT_SP "% Omitting BG: NO LAST BG\n" if $opt_D;
- return;
- }
- $x_start = $last_sp_bg[$pe];
- $x_end = $time;
- $intensity = ( $sparks[$pe] <= 0 ?
- 0 :
- &get_sp_intensity($sparks[$pe]) );
- $secondary_intensity = 0;
- do ps_draw_bg(OUT_SP,$x_start, $x_end, $stripes_low[$pe], $stripes_high[$pe],
- $intensity,$secondary_intensity);
-
-}
-
-# ----------------------------------------------------------------------------
-
-sub draw_arrow {
- local ($from_pe,$to_pe,$send_time,$arrive_time) = @_;
- local ($ystart,$yend);
-
- $ystart = $stripes_high[$from_pe];
- $yend = $stripes_low[$to_pe];
- do ps_draw_arrow(OUT_MIG,$send_time,$arrive_time,$ystart,$yend);
-}
-
-# ----------------------------------------------------------------------------
-# Normalize the x value s.t. it fits onto the page without scaling.
-# The global values $left_border and $right_border and $total_width
-# determine the borders
-# of the graph.
-# This fct is only called from within ps_... fcts. Before that the $x values
-# are always times.
-# ----------------------------------------------------------------------------
-
-sub normalize {
- local ($x) = @_;
-
- return (($x-$xmin)/($x_max-$x_min) * $total_width + $left_border);
-}
-
-# ----------------------------------------------------------------------------
-# PostScript generation functions.
-# Lowest level of writing output file.
-# Now there is only normalizing mode supported.
-# The following is out of date:
-# $mode can be $LITERATE i.e. assuming scaling has been done
-# or $NORMALIZING i.e. no scaling has been done so far (do it in
-# macros for drawing)
-# ----------------------------------------------------------------------------
-
-sub ps_draw_hline {
- local ($OUT,$xstart,$y,$xend,$width) = @_;
- local ($xlen);
-
- print $OUT "% HLINE From: ($xstart,$y) to ($xend,$y) (i.e. len=$xlen) with width $width gray $gray\n" if $opt_D;
-
- if ( ! $opt_N ) {
- $xstart = &normalize($xstart);
- $xend = &normalize($xend);
- }
-
- $xlen = $xend - $xstart;
-
- printf $OUT ("%d %d %d %d L\n",$xstart,$y,$xlen,$width);
- # ( $mode == $LITERATE ? " L\n" : " N\n");
-
- # Old version:
- # print $OUT "newpath\n";
- # print $OUT "$GRAY{$type} setgray\n";
- # print $OUT $xend . " " . $y . " " . $xstart . " " . $y . " " . $width .
- # " line\n";
- # print $OUT "stroke\n";
-}
-
-# ----------------------------------------------------------------------------
-
-sub ps_draw_vline {
- local ($OUT,$x,$ystart,$yend,$width) = @_;
-
- print $OUT "% VLINE From: ($x,$ystart) to ($x,$yend) with width $width\n" if $opt_D;
-
- if ( ! $opt_N ) {
- $x = &normalize($x);
- }
-
- print $OUT "newpath\n";
- print $OUT "0 setgray\n"; # constant gray level
- printf $OUT ("%d %d %d %d %.1g line\n",
- $x,$yend ,$x,$ystart,$width);
- print $OUT "stroke\n";
-}
-
-# ----------------------------------------------------------------------------
-
-sub ps_draw_tic {
- local ($OUT,$x,$ystart,$yend,$lit) = @_;
-
- print $OUT "% TIC at ($x,$ystart-$yend)\n" if $opt_D;
-
- if ( ! $opt_N ) {
- $x = &normalize($x);
- }
-
- printf $OUT ("%d %d %d %d T\n",$x,$ystart,$yend,$lit);
-
- # Old version without PostScript macro /tic:
- # print $OUT "newpath\n";
- # print $OUT "ticwidth setlinewidth\n" .
- # $x . " " . $y . " ticlen sub moveto\n" .
- # $x . " " . $y . " ticlen add lineto\n";
- #print $OUT "stroke\n";
-}
-
-# ----------------------------------------------------------------------------
-
-sub ps_draw_arrow {
- local ($OUT,$xstart,$xend,$ystart,$yend) = @_;
-
- print $OUT "% ARROW from ($xstart,$ystart) to ($xend,$yend)\n" if $opt_D;
-
- if ( ! $opt_N ) {
- $xstart = &normalize($xstart);
- $xend = &normalize($xend);
- }
-
- printf $OUT ("%d %d %d %d A\n",$xstart,$ystart,$xend,$yend);
-}
-
-# ----------------------------------------------------------------------------
-
-sub ps_draw_bg {
- local ($OUT,$xstart, $xend, $ystart, $yend,
- $intensity, $secondary_intensity) = @_;
- local ($xlen, $ylen);
-
- print $OUT "% Drawing bg for PE $pe from $xstart to $xend" .
- " (intensity: $intensity, $secondary_intensity)\n" if $opt_D;
-
- if ( ! $opt_N ) {
- $xstart = &normalize($xstart);
- $xend = &normalize($xend);
- }
-
- $xlen = $xend - $xstart;
- $ylen = $yend - $ystart;
-
- printf $OUT ("%d %d %d %d %.2g %.2g R\n",
- $xstart,$ystart,$xlen,$ylen,$intensity,$secondary_intensity);
-
- # Old version without PostScript macro /rect:
- #print $OUT "newpath\n";
- #print $OUT " $x_start $y_start moveto\n";
- #print $OUT " $x_end $y_start lineto\n";
- #print $OUT " $x_end $y_end lineto\n";
- #print $OUT " $x_start $y_end lineto\n";
- #print $OUT "closepath\n";
- #print $OUT "$gray setgray\n";
- #print $OUT "fill\n";
-}
-
-# ----------------------------------------------------------------------------
-# Initialization and such
-# ----------------------------------------------------------------------------
-
-sub write_prolog {
- local ($OUT, $x_max, $y_max) = @_;
- local ($date, $dist, $y, $i);
-
- $date = &get_date();
-
- if ( $opt_N ) {
- $x_scale = $total_width/$x_max;
- $y_scale = $total_height/$y_max;
- }
-
- # $tic_width = 2 * $x_max/$total_width; constant now
- # $tic_len = 4 * $y_max/$total_height;
-
- print $OUT "%!PS-Adobe-2.0\n";
- print $OUT "%%BoundingBox: \t0 0 560 800\n";
- print $OUT "%%Title: \t$pname $pars\n";
- print $OUT "%%Creator: \tgr2pe\n";
- print $OUT "%%CreationDate: \t$date\n";
- # print $OUT "%%Orientation: \tSeascape\n";
- print $OUT "%%EndComments\n";
-
- # print $OUT "%%BeginSetup\n";
- # print $OUT "%%PageOrientation: \tSeascape\n";
- # print $OUT "%%EndSetup\n";
-
- print $OUT "%/runlineto {1.5 setlinewidth lineto} def\n";
- print $OUT "%/suspendlineto {0.5 setlinewidth lineto} def\n";
- print $OUT "%/run { newpath moveto 1.5 setlinewidth lineto stroke} def\n";
- print $OUT "%/suspend { newpath moveto 0.5 setlinewidth lineto stroke} def\n";
- print $OUT "\n";
- print $OUT "/total-len $x_max def\n";
- print $OUT "/show-len $total_width def\n";
- print $OUT "/normalize { show-len mul total-len div } def\n";
- print $OUT "/x-normalize { exch show-len mul total-len div exch } def\n";
- print $OUT "/str-len 12 def\n";
- #print $OUT "/prt-n { str-len string cvs show } def" .
- # " % print top-of-stack integer\n";
- print $OUT "/prt-n { cvi str-len string cvs \n" .
- " dup stringwidth pop \n" .
- " currentpoint pop 780 gt { 10 sub } { 2 div } ifelse \n" .
- " neg 0 rmoveto \n" .
- " show } def \n" .
- " % print top-of-stack integer centered at the current point\n";
- print $OUT "/ticwidth $tic_width def\n";
- print $OUT "%/ticlen $tic_len def % actually half of the tic-length\n";
- print $OUT "/T % Draw a tic mark\n" .
- " { % Operands: x, y-start, y-end of tic, from/to flag \n" .
- " newpath\n" .
- " 0 eq { " . ( $opt_m ? " 0.2 setgray }"
- : " 0 0.7 0.2 setrgbcolor }" ) .
- " { " . ( $opt_m ? " 0.8 setgray }"
- : " 0.7 0 0.2 setrgbcolor }" ) . " ifelse\n" .
- " ticwidth setlinewidth\n" .
- " 3 copy pop moveto\n" .
- " exch pop lineto\n" .
- " stroke\n" .
- " } def\n";
- # " 3 copy pop x-normalize moveto\n" .
- # " exch pop x-normalize lineto\n" .
- # " stroke\n" .
- # " } def\n";
- print $OUT "/blocked-gray 0 def\n";
- print $OUT "/idle-gray 1 def\n";
- print $OUT "/blocked-color { 0.2 0.1 0.8 } def\n";
- print $OUT "/idle-color { 0.8 0.1 0.2 } def\n";
- print $OUT "/idle-color-fetch { 0.5 0.6 0.4 } def\n";
- print $OUT "/L % Draw a line (for blocked tasks)\n" .
- " { % Operands: (x,y)-start xlen width\n" .
- " newpath \n" .
- ( $opt_m ? " blocked-gray setgray\n" :
- " blocked-color setrgbcolor\n") .
- " setlinewidth 3 copy pop moveto 0 rlineto pop pop stroke} def\n";
- print $OUT "/N % Draw a normalized line\n" .
- " { % Operands: (x,y)-start xlen width\n" .
- " newpath \n" .
- ( $opt_m ? " blocked-gray setgray\n" :
- " blocked-color setrgbcolor\n") .
- " setlinewidth 3 copy pop x-normalize moveto normalize 0 rlineto pop pop stroke} def\n";
- print $OUT "% /L line def\n";
- print $OUT "/printText { 0 0 moveto (GrAnSim) show } def\n";
- if ( $opt_m ) {
- print $OUT "/logo { gsave \n" .
- " translate \n" .
- " .95 -.05 0 " .
- " { setgray printText 1 -.5 translate } for \n" .
- " 1 setgray printText\n" .
- " grestore } def\n";
- } else {
- print $OUT "/logo { gsave \n" .
- " translate \n" .
- " .95 -.05 0\n" .
- " { dup 1 exch sub 0 exch setrgbcolor printText 1 -.5 translate } for \n" .
- " 1 0 0 setrgbcolor printText\n" .
- " grestore} def\n";
- }
-
- print $OUT "/asciilogo { 5 sub moveto HB16 setfont (GrAnSim) show } def\n";
- print $OUT "/starside \n" .
- " {starlen 0 lineto currentpoint translate \n" .
- " -144 rotate } def\n";
-
- print $OUT "/star \n" .
- " { moveto \n" .
- " currentpoint translate \n" .
- " 4 {starside} repeat \n" .
- " closepath \n" .
- " gsave \n" .
- " .7 setgray fill \n" .
- " grestore \n" .
- " % stroke \n" .
- " } def \n";
- #print $OUT "/get-shade % compute shade from intensity\n" .
- # " { pop 1 exch sub 0.6 mul 0.2 add } def\n";
- if ( $opt_m ) {
- print $OUT "/from 0.2 def\n";
- print $OUT "/to 0.8 def\n";
- print $OUT "/get-shade % compute shade from intensity\n" .
- " { pop dup 0 eq { pop idle-gray }\n " .
- " { 1 exch sub to from sub mul from add } ifelse } def\n";
- " { pop 1 exch sub to from sub mul from add } def\n";
- } else {
- print $OUT "/from 0.5 def\n";
- print $OUT "/to 0.9 def\n";
- }
- print $OUT "/epsilon 0.01 def\n";
- print $OUT "/from-blue 0.7 def\n";
- print $OUT "/to-blue 0.95 def\n";
- print $OUT "/m 1 def\n";
- print $OUT "/magnify { m mul dup 1 gt { pop 1 } if } def\n";
- print $OUT "%\n" .
- "% show no. of runnable threads and the current degree of fetching\n" .
- "%\n" .
- "/get-color % compute color from intensity\n" .
- " { 4 mul dup % give more weight to second intensity\n" .
- " 0 eq { pop 0 exch } \n" .
- " { from-blue to-blue sub mul from-blue add dup \n" .
- " 1 gt { pop 1 } if exch } ifelse \n" .
- " dup 0 eq { pop pop idle-color }\n" .
- " { 1 exch sub to from sub mul from add % green val is top of stack\n" .
- " exch 0 3 1 roll } ifelse } def\n";
-
- print $OUT "%\n";
- print $OUT "% show no. of runable threads only\n";
- print $OUT "%\n";
- print $OUT "/get-color-runnable % compute color from intensity\n";
- print $OUT "{ pop dup 0 eq { pop idle-color }\n";
- print $OUT " { 1 exch sub to from sub mul from add % green val is top of stack\n";
- print $OUT " 0.2 0 3 1 roll } ifelse } def\n";
-
- print $OUT "%\n";
- print $OUT "% show no. of fetching threads only\n";
- print $OUT "%\n";
- print $OUT "/get-color-fetch % compute color from intensity\n";
- print $OUT "{ exch pop dup 0 eq { pop idle-color-fetch }\n";
- print $OUT " { 1 exch sub to from sub mul from add % blue val is top of stack\n";
- print $OUT " 0.2 0.6 3 2 roll } ifelse } def\n";
-
- #print $OUT "/get-color % compute color from intensity\n" .
- # " { dup 0 eq { pop idle-color }\n" .
- # " { 1 exch sub to from sub mul from add 0 exch 0 } ifelse } def\n";
- # " { dup 0.4 le { 0.4 exch sub 0.2 add 2 mul 0 0 setrgbcolor} " .
- # " { 1 exch sub 0.4 add 0 exch 0 setrgbcolor} ifelse \n" .
- print $OUT "/R % Draw a rectangle \n" .
- " { % Operands: x y xlen ylen i j \n" .
- " % (x,y) left lower start point of rectangle\n" .
- " % xlen length of rec in x direction\n" .
- " % ylen length of rec in y direction\n" .
- " % i intensity of rectangle [0,1] \n" .
- " % j intensity blue to indicate fetching\n" .
- " % (ignored in mono mode)\n" .
- ( $opt_m ? " get-shade setgray\n"
- : " get-color-runnable setrgbcolor\n" ) .
- " newpath\n" .
- " 4 copy pop pop moveto\n" .
- " 1 index 0 rlineto\n" .
- " 0 index 0 exch rlineto\n" .
- " 1 index neg 0 rlineto\n" .
- " 0 index neg 0 exch rlineto\n" .
- " pop pop pop pop\n" .
- " closepath\n" .
- " fill % Note: No stroke => no border\n" .
- " } def\n";
- print $OUT "% /R rect def\n";
- print $OUT "%/A % Draw an arrow (for migration graph)\n" .
- "% { % Operands: x y x' y' \n" .
- "% % (x,y) start point \n" .
- "% % (x',y') end point \n" .
- ( $opt_m ? "% 0 setgray\n" : "% 0 0 0 setrgbcolor\n" ) .
- "% 1 setlinewidth\n" .
- "% newpath 4 2 roll x-normalize moveto x-normalize lineto stroke } def\n";
-
- print $OUT "/A % No arrows \n" .
- " { pop pop pop pop } def\n";
- print $OUT "-90 rotate\n";
-
- print $OUT "-785 30 translate\n";
- print $OUT "/HE10 /Helvetica findfont 10 scalefont def\n";
- print $OUT "/HE12 /Helvetica findfont 12 scalefont def\n";
- print $OUT "/HE14 /Helvetica findfont 14 scalefont def\n";
- print $OUT "/TI16 /Times-Italic findfont 16 scalefont def\n";
- print $OUT "/HB16 /Helvetica-Bold findfont 16 scalefont def\n";
- print $OUT "% " . "-" x 77 . "\n";
-
- print $OUT "newpath\n";
- print $OUT "0 8.000000 moveto\n";
- print $OUT "0 525.000000 760.000000 525.000000 8.000000 arcto\n";
- print $OUT "4 {pop} repeat\n";
- print $OUT "760.000000 525.000000 760.000000 0 8.000000 arcto\n";
- print $OUT "4 {pop} repeat\n";
- print $OUT "760.000000 0 0 0 8.000000 arcto\n";
- print $OUT "4 {pop} repeat\n";
- print $OUT "0 0 0 525.000000 8.000000 arcto\n";
- print $OUT "4 {pop} repeat\n";
- print $OUT "0.500000 setlinewidth\n";
- print $OUT "stroke\n";
- print $OUT "newpath\n";
- print $OUT "4.000000 505.000000 moveto\n";
- print $OUT "4.000000 521.000000 752.000000 521.000000 4.000000 arcto\n";
- print $OUT "4 {pop} repeat\n";
- print $OUT "752.000000 521.000000 752.000000 501.000000 4.000000 arcto\n";
- print $OUT "4 {pop} repeat\n";
- print $OUT "752.000000 501.000000 4.000000 501.000000 4.000000 arcto\n";
- print $OUT "4 {pop} repeat\n";
- print $OUT "4.000000 501.000000 4.000000 521.000000 4.000000 arcto\n";
- print $OUT "4 {pop} repeat\n";
- print $OUT "0.500000 setlinewidth\n";
- print $OUT "stroke\n";
-
- print $OUT "% ----------------------------------------------------------\n";
- print $OUT "% Print pallet\n";
- print $OUT "% NOTE: the values for the tics must correspond to start and\n";
- print $OUT "% end values in /get-color\n";
- print $OUT "gsave \n";
- print $OUT "340 508 translate\n";
- print $OUT "0.0 0.05 1.00 \n";
- print $OUT " { \n";
- print $OUT " dup dup \n";
- print $OUT " from epsilon sub gt exch \n";
- print $OUT " from epsilon add lt \n";
- print $OUT " and\n";
- print $OUT " { newpath " .
- ($opt_m ? "0 setgray " : "0 0 0 setrgbcolor ") .
- "0 0 moveto 0 -3 rlineto stroke } if\n";
- print $OUT " dup dup \n";
- print $OUT " to epsilon 2 mul sub gt exch \n";
- print $OUT " to epsilon 2 mul add lt \n";
- print $OUT " and\n";
- print $OUT " { newpath " .
- ($opt_m ? "0 setgray " : "0 0 0 setrgbcolor ") .
- "10 0 moveto 0 -3 rlineto stroke } if\n";
- print $OUT ($opt_m ? " setgray\n" : " 0 exch 0 setrgbcolor\n");
- print $OUT " newpath\n";
- print $OUT " 0 0 moveto\n";
- print $OUT " 10 0 rlineto\n";
- print $OUT " 0 10 rlineto\n";
- print $OUT " -10 0 rlineto\n";
- print $OUT " closepath\n";
- print $OUT " fill\n";
- print $OUT " 10 0 translate \n";
- print $OUT " } for\n";
- print $OUT "grestore\n";
-
- print $OUT "% Print pallet for showing fetch\n";
- print $OUT "% NOTE: the values for the tics must correspond to start and\n";
- print $OUT "% end values in /get-color\n";
- print $OUT "%gsave \n";
- print $OUT "%340 508 translate\n";
- print $OUT "%0.0 0.05 1.00 \n";
- print $OUT "%{ \n";
- print $OUT "% dup dup \n";
- print $OUT "% from epsilon sub gt exch \n";
- print $OUT "% from epsilon add lt \n";
- print $OUT "% and\n";
- print $OUT "% { newpath 0 0 0 setrgbcolor 0 0 moveto 0 -3 rlineto stroke } if\n";
- print $OUT "% dup dup \n";
- print $OUT "% to epsilon 2 mul sub gt exch \n";
- print $OUT "% to epsilon 2 mul add lt \n";
- print $OUT "% and\n";
- print $OUT "% { newpath 0 0 0 setrgbcolor 10 0 moveto 0 -3 rlineto stroke } if\n";
- print $OUT "% 0.2 exch 0.6 exch setrgbcolor \n";
- print $OUT "% newpath\n";
- print $OUT "% 0 0 moveto\n";
- print $OUT "% 10 0 rlineto\n";
- print $OUT "% 0 10 rlineto\n";
- print $OUT "% -10 0 rlineto\n";
- print $OUT "% closepath\n";
- print $OUT "% fill\n";
- print $OUT "% 10 0 translate \n";
- print $OUT "% } for\n";
- print $OUT "% grestore\n";
-
- print $OUT "% Print double pallet\n";
- print $OUT "% NOTE: the values for the tics must correspond to start and\n";
- print $OUT "% end values in /get-color\n";
- print $OUT "% gsave \n";
- print $OUT "% 340 500 translate\n";
- print $OUT "% 0.0 0.05 1.00 \n";
- print $OUT "% { \n";
- print $OUT "% 0 exch 0 setrgbcolor \n";
- print $OUT "% newpath\n";
- print $OUT "% 0 0 moveto\n";
- print $OUT "% 10 0 rlineto\n";
- print $OUT "% 0 10 rlineto\n";
- print $OUT "% -10 0 rlineto\n";
- print $OUT "% closepath\n";
- print $OUT "% fill\n";
- print $OUT "% 10 0 translate \n";
- print $OUT "% } for\n";
- print $OUT "% grestore\n";
- print $OUT "% gsave \n";
- print $OUT "% 340 510 translate\n";
- print $OUT "% 0.0 0.05 1.00 \n";
- print $OUT "% { \n";
- print $OUT "% dup dup \n";
- print $OUT "% from epsilon sub gt exch \n";
- print $OUT "% from epsilon add lt \n";
- print $OUT "% and\n";
- print $OUT "% { newpath 0 0 0 setrgbcolor 0 3 moveto 0 -6 rlineto stroke } if\n";
- print $OUT "% dup dup \n";
- print $OUT "% to epsilon 2 mul sub gt exch \n";
- print $OUT "% to epsilon 2 mul add lt \n";
- print $OUT "% and\n";
- print $OUT "% { newpath 0 0 0 setrgbcolor 10 3 moveto 0 -6 rlineto stroke } if\n";
- print $OUT "% 0.7 exch 0 setrgbcolor \n";
- print $OUT "% newpath\n";
- print $OUT "% 0 0 moveto\n";
- print $OUT "% 10 0 rlineto\n";
- print $OUT "% 0 10 rlineto\n";
- print $OUT "% -10 0 rlineto\n";
- print $OUT "% closepath\n";
- print $OUT "% fill\n";
- print $OUT "% 10 0 translate \n";
- print $OUT "% } for\n";
- print $OUT "% grestore\n";
- print $OUT "% ----------------------------------------------------------\n";
- print $OUT "HE14 setfont\n";
- print $OUT "100.000000 508.000000 moveto\n";
- print $OUT "($pname PEs: $nPEs Lat.: $lat ) show\n";
-
- print $OUT "($date) dup stringwidth pop 750.000000 exch sub 508.000000 moveto show\n";
- print $OUT ( $opt_m ? "5 512 asciilogo\n" : "5 512 logo\n");
- print $OUT "% 100 500 moveto\n";
-
- print $OUT "0 20 translate\n";
-
- print $OUT "HE14 setfont\n";
- for ($i=0; $i<$nPEs; $i++) {
- $dist = $stripes_high[$i] - $stripes_low[$i];
- $y = $stripes_low[$i] + $dist/2;
- # print $OUT "/starlen $dist def\n";
- # print $OUT "gsave 2 $y star grestore\n";
- print $OUT " 2 " . ($stripes_low[$i]+1) . " moveto ($i) show\n";
- }
-
- print $OUT "20 0 translate\n";
-
- print $OUT "% Print x-axis:\n";
- print $OUT "1 setlinewidth\n";
- print $OUT "0 -5 moveto total-len normalize 0 rlineto stroke\n";
- print $OUT "gsave\n" .
- "[2 4] 1 setdash\n" .
- "0 0 moveto 0 $total_height rlineto stroke\n" .
- "% $x_max 0 moveto 0 $total_height rlineto stroke\n" .
- "grestore\n";
- print $OUT "0 total-len 10 div total-len\n" .
- " { dup normalize dup -5 moveto 0 -2 rlineto stroke % tic\n" .
- " -17 moveto HE10 setfont round prt-n % print label \n" .
- " } for \n";
-
-
- print $OUT "$x_scale $y_scale scale\n";
-
- print $OUT "% ++++++++++++++++++++++++++++++++++++++++++++++++++\n\n";
-
- if ( $opt_D ) {
- print $OUT "% Debugging info : \n";
-
- print $OUT "% Offset is: $offset\n";
-
- print $OUT "% y_val table: \n";
- for ($i=0; $i<$nPEs; $i++) {
- print $OUT "% y_val of $i: $y_val[$i]\n";
- }
-
- print $OUT "% x-max: $x_max; y-max: $y_max\n";
- print $OUT "% Info from header: Prg: $pname; PEs: $nPEs; Lat.: $lat\n";
-
- print $OUT "% ++++++++++++++++++++++++++++++++++++++++++++++++++\n\n";
- }
-}
-
-# ----------------------------------------------------------------------------
-
-sub write_epilog {
- local ($OUT,$x_max, $y_max) = @_;
- local($x_scale,$y_scale);
-
- print $OUT "showpage\n";
-}
-
-# ----------------------------------------------------------------------------
-
-sub get_x_max {
- local ($file) = @_;
- local ($last_line, @fs);
-
- open (TMP,"tail -1 $file |") || die "tail -1 $file | : $!\n";
- while (<TMP>) {
- $last_line = $_;
- }
- close(TMP);
-
- @fs = split(/[:\[\]\s]+/,$last_line);
-
- return $fs[2];
-}
-
-# ----------------------------------------------------------------------------
-#
-#sub get_date {
-# local ($now,$today,@lt);
-#
-# @lt = localtime(time);
-# $now = join(":",reverse(splice(@lt,0,3)));
-# $today = join(".",splice(@lt,0,3));
-#
-# return $now . " on " . $today;
-#}
-#
-# ----------------------------------------------------------------------------
-
-sub get_date {
- local ($date);
-
- open (DATE,"date |") || die ("$!");
- while (<DATE>) {
- $date = $_;
- }
- close (DATE);
-
- return ($date);
-}
-
-# -----------------------------------------------------------------------------
-
-sub generate_y_val_table {
- local ($nPEs) = @_;
- local($i, $y, $dist);
-
- $dist = int($total_height/$nPEs);
- for ($i=0, $y=1; $i<$nPEs; $i++, $y+=$dist) {
- $y_val[$i] = $y + $lower_border;
- $stripes_low[$i] = $y;
- $stripes_high[$i] = $y+$dist-2;
- }
-
- # print $OUT "10 5 translate\n";
-
- return ($dist);
-}
-
-# ----------------------------------------------------------------------------
-
-sub init {
- local ($nPEs) = @_;
- local($i);
-
- for ($i=0; $i<$nPEs; $i++) {
- if ( $opt_S ) {
- $sparks[$i] = 0;
- }
- $blocked[$i] = 0;
- $runnable[$i] = 0;
- $fetching[$i] = 0;
- $running[$i] = $NO_ID;
- if ( $opt_S ) {
- $last_sp_bg[$i] = $NO_LAST_BG;
- }
- $last_bg[$i] = $NO_LAST_BG;
- $last_start[$i] = $NO_LAST_START;
- $last_blocked[$i] = $NO_LAST_BLOCKED;
- $last_runnable[$i] = 0;
- #open($OUT_RA[$i], "PE". $i . ".dat") || die "PE".$i."-R.dat: $!\n";
- #print $OUT_RA[$i] "# Number of Runnable tasks on PE $i\n";
- #open($OUT_BA[$i], "PE". $i . ".dat") || die "PE".$i."-B.dat: $!\n";
- #print $OUT_BA[$i] "# Number of Blocked tasks on PE $i\n";
- }
-
-}
-
-
-# ----------------------------------------------------------------------------
-
-sub skip_header {
- local ($FILE) = @_;
- local($prg, $pars, $nPEs, $lat, $fetch, $in_header);
-
- $in_header = 9;
- while (<$FILE>) {
- if ( $in_header = 9 ) {
- if (/^=/) {
- $gum_style_gr = 1;
- $in_header = 0;
- $prg = "????"; #
- $pars = "-b??????"; #
- $nPEs = $opt_p ? $opt_p : 1; #
- $lat = $opt_l ? $opt_l : 1;
- return ($prg, $pars, $nPEs, $lat);
- } else {
- $gum_style_gr = 0;
- $in_header = 1;
- }
-
- }
- $prg = $1, $pars = $2 if /^Granularity Simulation for\s+(\w+)\s+(.*)$/;
- $nPEs = $1 if /^PEs\s+(\d+)/;
- $lat = $1, $fetch = $2 if /^Latency\s+(\d+)[^F]+Fetch\s+(\d+)/;
- die "Can't process GranSim-Light profiles!\n" if /^GrAnSim-Light$/i;
-
- last if /^\+\+\+\+\+/;
- }
-
- return ($prg, $pars, $nPEs, $lat);
-}
-
-# ----------------------------------------------------------------------------
-
-sub process_options {
-
- if ( $opt_h ) {
- open(ME,$0) || die "Can't open myself ($0): $!\n";
- $n = 0;
- while (<ME>) {
- last if $_ =~ /^$/;
- print $_;
- $n++;
- }
- close(ME);
- exit ;
- }
-
- if ( $#ARGV != 0 ) {
- print "Usage: $0 [options] <gr-file>\n";
- print "Use -h option to get details\n";
- exit 1;
- }
-
- $input = $ARGV[0] ;
- $input =~ s/\.gr//;
- $input .= ".gr";
-
- if ( $opt_o ) {
- ($output = $opt_o) =~ s/\.ps// ;
- $output_b = $output . "_peb.ps";
- $output_r = $output . "_per.ps";
- $output_mig = $output . "_mig.ps" if $opt_M;
- $output_sp = $output . "_sp.ps" if $opt_S;
- $output = $output . "_pe.ps";
- #($output_b = $opt_o) =~ s/\./-b./ ;
- #($output_r = $opt_o) =~ s/\./-r./ ;
- #($output_mig = $opt_o) =~ s/\./-mig./ if $opt_M;
- #($output_sp = $opt_o) =~ s/\./-sp./ if $opt_S;
- } else {
- ($output = $input) =~ s/\.gr// ;
- $output_b = $output . "_peb.ps";
- $output_r = $output . "_per.ps";
- $output_mig = $output . "_mig.ps" if $opt_M;
- $output_sp = $output . "_sp.ps" if $opt_S;
- $output = $output . "_pe.ps";
- }
-
- if ( $opt_v ){
- $verbose = 1;
- }
-
- if ( $opt_i ) {
- $inf_block = $opt_i;
- } else {
- $inf_block = 20;
- }
-
- $RUNNABLE_file = $input;
- $RUNNABLE_file =~ s/\.gr//;
- $RUNNABLE_file .= "-R";
-
- $BLOCKED_file = $input;
- $BLOCKED_file =~ s/\.gr//;
- $BLOCKED_file .= "-B";
-
- $FETCHING_file = $input;
- $FETCHING_file =~ s/\.gr//;
- $FETCHING_file .= "-F";
-}
-
-# ----------------------------------------------------------------------------
-
-sub print_verbose_message {
-
- print "Input file: $input\n";
- print "Output files: $output, $output_b, $output_r; ".
- ($opt_M ? "Migration: $output_mig" : "") .
- ($opt_S ? "Sparks: $output_sp" : "") .
- "\n";
-}
-
-# ----------------------------------------------------------------------------
-# Junk from draw_segment:
-#
-# if ( $type eq $RUNNING ) {
-# die "ERROR: This version should never draw a RUNNING segment!";
-# $y = $y_val[$pe];
-# $x = $last_start[$pe];
-# $width = &get_width(0, $type);
-# # $gray = 0;
-#
-# if ( $is_very_big ) {
-# $x = int($x/$shrink_x) + 1; # rounded up
-# }
-#
-# do ps_draw_hline(OUT_B,$x,$y,$time,$width);
-# do ps_draw_hline(OUT_R,$x,$y,$time,$width);
-#
-# } elsif ( $type eq $RUNNABLE ) {
-# die "ERROR: This version should never draw a RUNNABLE segment (shades are used instead)!";
-# $y = $y_val[$pe] + $offset;
-# $x = $last_runnable[$pe];
-# $width = &get_width($runnable[$pe], $type);
-#
-# if ( $is_very_big ) {
-# $x = int($x/$shrink_x) + 1; # rounded up
-# }
-#
-# # $gray = 0.5;
-# do ps_draw_hline(OUT_R,$x,$y,$time,$width);
diff --git a/ghc/utils/parallel/gr2ps.bash b/ghc/utils/parallel/gr2ps.bash
deleted file mode 100644
index 4d4d3da3e6..0000000000
--- a/ghc/utils/parallel/gr2ps.bash
+++ /dev/null
@@ -1,169 +0,0 @@
-#!/usr/local/bin/bash
-##############################################################################
-# Time-stamp: <Wed Jul 24 1996 22:11:13 Stardate: [-31]7859.41 hwloidl>
-#
-# Usage: gr2ps [options] <gr-file>
-#
-# Create an overall activity graph from a GrAnSim (or GUM) profile.
-# Transform the log file of a GrAnSim run (a .gr file) into a quasi-parallel
-# profile (a .qp file) using gr2qp and then into a PostScript file using qp2ps.
-# The generated PostScript file shows essentially the number of running,
-# runnable and blocked tasks during the execution of the program.
-#
-# Options:
-# -o <file> ... write .ps file to <file>
-# -I <str> ... queues to be displayed (in the given order) with the encoding
-# 'a' ... active (running)
-# 'r' ... runnable
-# 'b' ... blocked
-# 'f' ... fetching
-# 'm' ... migrating
-# 's' ... sparks
-# (e.g. -I "arb" shows active, runnable, blocked tasks)
-# -i <int> ... info level from 1 to 7; number of queues to display
-# -m ... create mono PostScript file instead a color one.
-# -O ... optimise the produced .ps w.r.t. size
-# NB: With this option info is lost. If there are several values
-# with same x value only the first one is printed, all
-# others are dropped.
-# -s <str> ... print <str> in the top right corner of the generated graph
-# -S ... improved version of sorting events
-# -l <int> ... length of slice in the .ps file; (default: 100)
-# small value => less memory consumption of .ps file & script
-# -d ... Print date instead of average parallelism
-# -v ... be talkative.
-# -h ... print help message (this header).
-#
-##############################################################################
-
-progname="`basename $0`"
-args="$*"
-
-verb=0
-help=0
-mono=""
-psfile=""
-debug=""
-optimise=""
-info_level=""
-info_mask=""
-string=""
-length=""
-force_date=""
-hack=""
-
-getopts "hvmDCOHSdl:s:o:i:I:" name
-while [ "$name" != "?" ] ; do
- case $name in
- h) help=1;;
- v) verb=1;;
- m) mono="-m";;
- D) debug="-D";;
- C) check="-C";;
- O) optimise="-O";;
- d) force_date="-d";;
- H) hack="-H";;
- S) improved_sort="-S";;
- s) string="-s $OPTARG";;
- l) length="-l $OPTARG";;
- i) info_level="-i $OPTARG";;
- I) info_mask="-I $OPTARG";;
- o) psfile=$OPTARG;;
- esac
- getopts "hvmDCOHSdl:s:o:i:I:" name
-done
-
-opts_qp="$debug $info_level $info_mask $improved_sort "
-opts_ps="$debug $check $optimise $mono $string $length $info_level $info_mask $force_date $hack "
-
-shift $[ $OPTIND - 1 ]
-
-if [ $help -eq 1 ]
- then no_of_lines=`cat $0 | awk 'BEGIN { n = 0; } \
- /^$/ { print n; \
- exit; } \
- { n++; }'`
- echo "`head -$no_of_lines $0`"
- exit
-fi
-
-if [ -z "$1" ]
- then echo "Usage: $progname [options] file[.gr]"
- echo "Use -h option for details"
- exit 1;
-fi
-
-f="`basename $1 .gr`"
-grfile="$f".gr
-qpfile="${TMPDIR:-.}/$f".qp
-ppfile="${TMPDIR:-.}/$f".pp
-
-if [ -z "$psfile" ]
- then psfile="$f".ps
-fi
-
-if [ $verb -eq 1 ]
- then echo "Input file: $grfile"
- echo "Quasi-parallel file: $qpfile"
- echo "PP file: $ppfile"
- echo "PostScript file: $psfile"
- if [ -n "$mono" ]
- then echo "Producing monochrome PS file"
- else echo "Producing color PS file"
- fi
- if [ -n "$optimise" ]
- then echo "Optimisation is ON"
- else echo "Optimisation is OFF"
- fi
- if [ -n "$debug" ]
- then echo "Debugging is turned ON"
- else echo "Debugging is turned OFF"
- fi
- if [ -n "$improved_sort" ]
- then echo "Improved sort is turned ON"
- else echo "Improved sort is turned OFF"
- fi
- verb_opt="-v "
- opts_qp="${opts_qp} $verb_opt "
- opts_ps="${opts_ps} $verb_opt "
- echo "Options for gr2qp: ${opts_qp}"
- echo "Options for qp2ps: ${opts_ps}"
-fi
-
-
-# unset noclobber
-if [ ! -f "$grfile" ]
- then
- echo "$grfile does not exist"
- exit 1
- else
- rm -f "$qpfile" "$psfile"
- prog=`head -1 "$grfile" | sed -e 's/Granularity Simulation for //'`
- echo "$prog" >| "$qpfile"
- if [ $verb -eq 1 ]
- then echo "Executed program: $prog"
- fi
- date >> "$qpfile"
- #date="`date`" # This is the date of running the script
- date="`tail +2 $grfile | head -1 | sed -e 's/Start time: //'`"
- cat "$grfile" | gr2qp ${opts_qp} >> "$qpfile"
- # Sorting is part of gr2qp now.
- # | ghc-fool-sort | sort -n +0 -1 | ghc-unfool-sort >> "$qpfile"
- # max=`tail -2 "$qpfile" | awk '!/^Number of threads:/ { print $1; }'`
- xmax=`tail -1 "$qpfile" | awk '{ print $2; }'`
- ymax=`tail -1 "$qpfile" | awk '{ print $4; }'`
- if [ $verb -eq 1 ]
- then echo "Total runtime: $xmax"
- echo "Maximal number of tasks: $ymax"
- fi
- tail +3 "$qpfile" | qp2ps ${opts_ps} "$xmax" "$ymax" "$prog" "$date" >| "$psfile"
- rm -f "$qpfile"
- if [ $verb -eq 1 ]
- then echo "Scaling (maybe): ps-scale-y $psfile "
- fi
- ps-scale-y "$psfile"
-fi
-
-
-
-
diff --git a/ghc/utils/parallel/gr2qp.pl b/ghc/utils/parallel/gr2qp.pl
deleted file mode 100644
index e87f21b1e4..0000000000
--- a/ghc/utils/parallel/gr2qp.pl
+++ /dev/null
@@ -1,329 +0,0 @@
-#!/usr/local/bin/perl
-##############################################################################
-# Time-stamp: <Wed Jul 24 1996 20:35:01 Stardate: [-31]7859.07 hwloidl>
-#
-# Usage: gr2qp [options]
-#
-# Filter that transforms a GrAnSim profile (a .gr file) at stdin to
-# a quasi-parallel profile (a .qp file). It is the common front-end for most
-# visualization tools (except gr2pe). It collects running,
-# runnable and blocked tasks in queues of different `colours', whose meaning
-# is:
-# G ... green; queue of all running tasks
-# A ... amber; queue of all runnable tasks
-# R ... red; queue of all blocked tasks
-# Y ... cyan; queue of fetching tasks
-# C ... crimson; queue of tasks that are being stolen
-# B ... blue; queue of all sparks
-#
-# Options:
-# -i <int> ... info level from 1 to 7; number of queues to count (see qp3ps)
-# -I <str> ... count tasks that are in one of the given queues; encoding:
-# 'a' ... active (running)
-# 'r' ... runnable
-# 'b' ... blocked
-# 'f' ... fetching
-# 'm' ... migrating
-# 's' ... sparks
-# (e.g. -I "arb" counts sum of active, runnable, blocked tasks)
-# -c ... check consistency of data (e.g. no neg. number of tasks)
-# -v ... be talkative.
-# -h ... print help message (this header).
-#
-##############################################################################
-
-require "getopts.pl";
-
-&Getopts('hvDSci:I:');
-
-do process_options();
-
-if ( $opt_v ) {
- do print_verbose_message();
-}
-
-# ---------------------------------------------------------------------------
-# Init
-# ---------------------------------------------------------------------------
-
-$max = 0;
-$pmax = 0;
-$ptotal = 0;
-$n = 0;
-
-$active = 0;
-$runnable = 0;
-$blocked = 0;
-$fetching = 0;
-$migrating = 0;
-$sparks = 0;
-
-$improved_sort_option = $opt_S ? "-S" : "";
-
-open (FOOL,"| ghc-fool-sort $improved_sort_option | sort -n +0 -1 | ghc-unfool-sort") || die "FOOL";
-
-$in_header = 9;
-while(<>) {
- if ( $in_header == 8 ) {
- $start_time = $1 if /^Start-Time: (.*)$/;
- $in_header = 0;
- next;
- }
- if ( $in_header == 9 ) {
- if (/^=/) {
- $gum_style_gr = 1;
- $in_header = 8;
- next;
- } else {
- $gum_style_gr = 0;
- $in_header = 1;
- }
-
- }
- if (/^\++$/) {
- $in_header=0;
- next;
- }
- next if $in_header;
- next if /^$/;
- next if /^=/;
- chop;
- ($PE, $pe, $time, $act, $tid, $rest) = split;
- $time =~ s/[\[\]:]//g;
- # next if $act eq 'REPLY';
- chop($tid) if $act eq 'END';
- $from = $queue{$tid};
- $extra = "";
- if ($act eq 'START') {
- $from = '*';
- $to = 'G';
- $n++;
- if ( $n > $pmax ) { $pmax = $n; }
- $ptotal++;
- } elsif ($act eq 'START(Q)') {
- $from = '*';
- $to = 'A';
- $n++;
- if ( $n > $pmax ) { $pmax = $n; }
- $ptotal++;
- } elsif ($act eq 'STEALING') {
- $to = 'C';
- } elsif ($act eq 'STOLEN') {
- $to = 'G';
- } elsif ($act eq 'STOLEN(Q)') {
- $to = 'A';
- } elsif ($act eq 'FETCH') {
- $to = 'Y';
- } elsif ($act eq 'REPLY') {
- $to = 'R';
- } elsif ($act eq 'BLOCK') {
- $to = 'R';
- } elsif ($act eq 'RESUME') {
- $to = 'G';
- $extra = " 0 0x0";
- } elsif ($act eq 'RESUME(Q)') {
- $to = 'A';
- $extra = " 0 0x0";
- } elsif ($act eq 'END') {
- $to = '*';
- $n--;
- if ( $opt_c && $n < 0 ) {
- print STDERR "Error at time $time: neg. number of tasks: $n\n";
- }
- } elsif ($act eq 'SCHEDULE') {
- $to = 'G';
- } elsif ($act eq 'DESCHEDULE') {
- $to = 'A';
- # The following are only needed for spark profiling
- } elsif (($act eq 'SPARK') || ($act eq 'SPARKAT')) {
- $from = '*';
- $to = 'B';
- } elsif ($act eq 'USED') {
- $from = 'B';
- $to = '*';
- } elsif ($act eq 'PRUNED') {
- $from = 'B';
- $to = '*';
- } elsif ($act eq 'EXPORTED') {
- $from = 'B';
- $to = 'B';
- } elsif ($act eq 'ACQUIRED') {
- $from = 'B';
- $to = 'B';
- } else {
- print STDERR "Error at time $time: unknown event $act\n";
- }
- $queue{$tid} = $to;
-
- if ( $from eq '' ) {
- print STDERRR "Error at time $time: process $tid has no from queue\n";
- }
- if ($to ne $from) {
- print FOOL $time, " ",
- $from, $to, " 0 0x", $tid, $extra, "\n";
- }
-
- if ($to ne $from) {
- # Compare with main loop in qp3ps
- if ($from eq '*') {
- } elsif ($from eq 'G') {
- --$active;
- } elsif ($from eq 'A') {
- --$runnable;
- } elsif ($from eq 'R') {
- --$blocked;
- } elsif ($from eq 'B') {
- --$sparks;
- } elsif ($from eq 'C') {
- --$migrating;
- } elsif ($from eq 'Y') {
- --$fetching;
- } else {
- print STDERR "Illegal from char: $from at $time\n";
- }
-
- if ($to eq '*') {
- } elsif ($to eq 'G') {
- ++$active;
- } elsif ($to eq 'A') {
- ++$runnable;
- } elsif ($to eq 'R') {
- ++$blocked;
- } elsif ($to eq 'B') {
- ++$sparks;
- } elsif ($to eq 'C') {
- ++$migrating;
- } elsif ($to eq 'Y') {
- ++$fetching;
- } else {
- print STDERR "Illegal to char: $to at $time\n";
- }
-
- }
-
- $curr = &count();
- if ( $curr > $max ) {
- $max = $curr;
- }
-
- if ( 0 ) {
- print STDERR "%% $time: (act,runnable,blocked,fetch,mig,sp) = " .
- "($active, $runnable, $blocked, $fetching, $migrating, $sparks)".
- " max = $max\n" ;
- }
-
- #print STDERR "Sparks @ $time: $sparks \tCurr: $curr \tMax: $max \n" if $opt_D;
-
- if ( $time > $tmax ) {
- $tmax = $time;
- }
- delete $queue{$tid} if $to eq '*';
-
-}
-
-print "Time: ", $tmax, " Max_selected_tasks: ", $max,
- " Max_running_tasks: ", $pmax, " Total_tasks: ", $ptotal, "\n";
-
-close(FOOL);
-
-exit 0;
-
-# +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-# Copied from qp3ps and slightly modified (we don't keep a list for each queue
-# but just compute the max value we get out of all calls to count during the
-# execution of the script).
-# -----------------------------------------------------------------------------
-
-# -----------------------------------------------------------------------------
-
-sub queue_on {
- local ($queue) = @_;
-
- return index($show,$queue)+1;
-}
-
-# -----------------------------------------------------------------------------
-
-sub count {
- local ($res);
-
- $res = (($queue_on_a) ? $active : 0) +
- (($queue_on_r) ? $runnable : 0) +
- (($queue_on_b) ? $blocked : 0) +
- (($queue_on_f) ? $fetching : 0) +
- (($queue_on_m) ? $migrating : 0) +
- (($queue_on_s) ? $sparks : 0);
-
- return $res;
-}
-
-# -----------------------------------------------------------------------------
-# DaH 'oH lo'lu'Qo'
-# -----------------------------------------------------------------------------
-
-sub set_values {
- local ($samples,
- $active,$runnable,$blocked,$fetching,$sparks,$migrating) = @_;
-
- $G[$samples] = queue_on_a ? $active : 0;
- $A[$samples] = queue_on_r ? $runnable : 0;
- $R[$samples] = queue_on_b ? $blocked : 0;
- $Y[$samples] = queue_on_f ? $fetching : 0;
- $B[$samples] = queue_on_s ? $sparks : 0;
- $C[$samples] = queue_on_m ? $migrating : 0;
-}
-
-# -----------------------------------------------------------------------------
-
-sub process_options {
- if ( $opt_h ) {
- open(ME,$0) || die "Can't open myself ($0): $!\n";
- $n = 0;
- while (<ME>) {
- last if $_ =~ /^$/;
- print $_;
- $n++;
- }
- close(ME);
- exit ;
- }
-
- $show = "armfb";
-
- if ( $opt_i ) {
- $show = "a" if info_level == 1;
- $show = "ar" if info_level == 2;
- $show = "arb" if info_level == 3;
- $show = "arfb" if info_level == 4;
- $show = "armfb" if info_level == 5;
- $show = "armfbs" if info_level == 6;
- }
-
- if ( $opt_I ) {
- $show = $opt_I;
- }
-
- if ( $opt_v ){
- $verbose = 1;
- }
-
- $queue_on_a = &queue_on("a");
- $queue_on_r = &queue_on("r");
- $queue_on_b = &queue_on("b");
- $queue_on_f = &queue_on("f");
- $queue_on_s = &queue_on("s");
- $queue_on_m = &queue_on("m");
-}
-
-sub print_verbose_message {
-
- print STDERR "Info-str: $show\n";
- print STDERR "The following queues are turned on: " .
- ( $queue_on_a ? "active, " : "") .
- ( $queue_on_r ? "runnable, " : "") .
- ( $queue_on_b ? "blocked, " : "") .
- ( $queue_on_f ? "fetching, " : "") .
- ( $queue_on_m ? "migrating, " : "") .
- ( $queue_on_s ? "sparks" : "") .
- "\n";
-}
diff --git a/ghc/utils/parallel/gran-extr.pl b/ghc/utils/parallel/gran-extr.pl
deleted file mode 100644
index 509da499d6..0000000000
--- a/ghc/utils/parallel/gran-extr.pl
+++ /dev/null
@@ -1,2114 +0,0 @@
-#!/usr/local/bin/perl
-##############################################################################
-# Last modified: Time-stamp: <Sat Oct 28 1995 23:49:48 Stardate: [-31]6509.75 hwloidl>
-# (C) Hans Wolfgang Loidl
-#
-# Usage: gran-extr [options] [<sim-file>]
-#
-# Takes a file <sim-file> generated by running the GrAnSim simulator and
-# produces data files that should be used as input for gnuplot.
-# This script produces figures for:
-# runtime of tasks
-# percentage of communication
-# heap allocation
-# number of created sparks
-# cumulative no. of tasks over runtime
-# Furthermore, it computes the correlation between runtime and heap allocation.
-#
-# Options:
-# -g <file> ... filename of granularity file to be produced; should end with
-# .dat; -global and -local will be automatically inserted for
-# other versions.
-# -c <file> ... filename of communication file to be produced; should end with
-# .dat; -global and -local will be automatically inserted for
-# other versions.
-# -s <file> ... filename of sparked-threads file to be produced; should end w/
-# .dat; -global and -local will be automatically inserted for
-# other versions.
-# -a <file> ... filename of heap alloc. file to be produced; should end with
-# .dat;
-# -f <file> ... filename of communication time file to be produced;
-# should end with .dat;
-# -p <file> ... filename of GNUPLOT file that is prouced and executed.
-# -G <LIST> ... provide a list of boundaries for the Intervals used in the
-# granularity figure; must be a Perl list e.g. (10, 20, 50)
-# this is interpreted as being open to left and right.
-# -C <LIST> ... provide a list of boundaries for the Intervals used in the
-# communication figure; must be a Perl list e.g. (10, 20, 50)
-# this is interpreted as being closed to left and right.
-# -S <LIST> ... provide a list of boundaries for the Intervals used in the
-# sparked-threads figure; must be a Perl list e.g. (10, 20, 50)
-# this is interpreted as being closed to left and right.
-# -A <LIST> ... provide a list of boundaries for the Intervals used in the
-# heap alloc figure; must be a Perl list e.g. (10, 20, 50)
-# this is interpreted as being closed to left and right.
-# -F <LIST> ... provide a list of boundaries for the Intervals used in the
-# comm. time figure; must be a Perl list e.g. (10, 20, 50)
-# this is interpreted as being open to left and right.
-# -l <int> ... left margin in the produced figures.
-# -r <int> ... right margin in the produced figures.
-# -x <int> ... enlargement of figure along x-axis.
-# -y <int> ... enlargement of figure along y-axis.
-# -e <int> ... thickness of impulses in figure.
-# -i <rat> ... set the gray level of the impulses to <rat>; <rat> must be
-# between 0 and 1 with 0 meaning black.
-# -k <n> ... number of klusters (oops, clusters, I mean ;)
-# -P ... print percentage of threads rather than absolute number of
-# threads on the y axis
-# -t <file> ... use template <file> for interval settings and file names
-# Syntax of a line in the template file:
-# <flag>: <arg>
-# -T ... use smart xtics rather than GNUPLOT default x-axis naming.
-# -L ... use logarithmic scale for all figures.
-# -W ... print warnings
-# -m ... generate monchrome output
-# -h ... help; print this text.
-# -v ... verbose mode.
-#
-##############################################################################
-
-# ----------------------------------------------------------------------------
-# Command line processing and initialization
-# ----------------------------------------------------------------------------
-
-require "getopts.pl";
-
-&Getopts('hvWTPDmt:L:g:f:c:s:a:p:G:F:C:S:A:l:r:x:y:e:i:k:');
-
-do process_options();
-
-$OPEN_INT = 1;
-$CLOSED_INT = 0;
-
-if ( $opt_v ) {
- do print_verbose_message ();
-}
-
-# ----------------------------------------------------------------------------
-# The real thing
-# ----------------------------------------------------------------------------
-
-open(INPUT,"<$input") || die "Couldn't open input file $input";
-
-do skip_header();
-
-$tot_total_rt = 0;
-$tot_rt = 0;
-$tot_bt = 0;
-$tot_ft = 0;
-$tot_it = 0;
-$gum_style_gr = 0;
-
-$line_no = 0;
-while (<INPUT>) {
- next if /^--/; # Comment lines start with --
- next if /^\s*$/; # Skip empty lines
- $line_no++;
- @fields = split(/[:,]/,$_);
- $has_end = 0;
-
- foreach $elem (@fields) {
- foo : {
- $pe = $1, $end = $2 , last foo if $elem =~ /^\s*PE\s+(\d+)\s+\[(\d+)\].*$/;
- $tn = $1, $has_end = 1 , last foo if $elem =~ /^\s*END\s+(\w+).*$/;
- # $tn = $1 , last foo if $elem =~ /^\s*TN\s+(\w+).*$/;
- $sn = $1 , last foo if $elem =~ /^\s*SN\s+(\d+).*$/;
- $start = $1 , last foo if $elem =~ /^\s*ST\s+(\d+).*$/;
- $is_global = $1 , last foo if $elem =~ /^\s*EXP\s+(T|F).*$/;
- $bbs = $1 , last foo if $elem =~ /^\s*BB\s+(\d+).*$/;
- $ha = $1 , last foo if $elem =~ /^\s*HA\s+(\d+).*$/;
- $rt = $1 , last foo if $elem =~ /^\s*RT\s+(\d+).*$/;
- $bt = $1, $bc = $2 , last foo if $elem =~ /^\s*BT\s+(\d+)\s+\((\d+)\).*$/;
- $ft = $1, $fc = $2 , last foo if $elem =~ /^\s*FT\s+(\d+)\s+\((\d+)\).*$/;
- $lsp = $1 , last foo if $elem =~ /^\s*LS\s+(\d+).*$/;
- $gsp = $1 , last foo if $elem =~ /^\s*GS\s+(\d+).*$/;
- $my = $1 , last foo if $elem =~ /^\s*MY\s+(T|F).*$/;
- }
- }
-
- next unless $has_end == 1;
-
- $total_rt = $end - $start;
- $ready_time = $total_rt - $rt - $bt - $ft;
-
- # ------------------------------------------------------------------------
- # Accumulate runtime, block time, fetch time and ready time over all threads
- # ------------------------------------------------------------------------
-
- $tot_total_rt += $total_rt;
- $tot_rt += $rt;
- $tot_bt += $bt;
- $tot_ft += $ft;
- $tot_it += $ready_time;
-
- # ------------------------------------------------------------------------
- # Gather statistics about `load' on the PEs
- # ------------------------------------------------------------------------
-
- print "WARNING: ready time of thread is <0: $ready_time\n" if $pedantic && ($ready_time <0);
- $pe_load[$pe] += $ready_time;
-
- if ( $opt_D ) {
- print "Adding $ready_time to the load time of PE no. $pe yielding $pe_load[$pe]\n";
- }
-
- # ------------------------------------------------------------------------
- # Gather statistics about the size of a spark site
- # ------------------------------------------------------------------------
-
- $site_size[$sn] += $rt;
-
- if ( $opt_D ) {
- print "Adding $rt to the size of site $sn yielding $site_size[$sn]\n";
- }
-
- # ------------------------------------------------------------------------
- # Gather statistics about pure exec time
- # ------------------------------------------------------------------------
-
- push(@all_rts,$rt);
- $sum_rt += $rt;
- $max_rt = $rt if $rt > $max_rt;
-
- $index = do get_index_open_int($rt,@exec_times);
- $exec_class[$index]++;
-
- if ( $is_global eq 'T' ) {
- $exec_global_class[$index]++;
- } else {
- $exec_local_class[$index]++;
- }
-
- # ------------------------------------------------------------------------
- # Gather statistics about communication time (absolute time rather than %)
- # ------------------------------------------------------------------------
-
- # Note: Communicatin time is fetch time
-
- push(@all_fts,$ft);
- $sum_ft += $ft;
- $max_ft = $ft if $ft > $max_ft;
-
- $index = do get_index_open_int($ft,@fetch_times);
- $fetch_class[$index]++;
-
- if ( $is_global eq 'T' ) {
- $fetch_global_class[$index]++;
- } else {
- $fetch_local_class[$index]++;
- }
-
- # ------------------------------------------------------------------------
- # Gather statistics about communication percentage
- # ------------------------------------------------------------------------
-
- $comm_perc = ( $total_rt == 0 ? 100 : (100 * $ft)/$total_rt );
-
- push(@all_comm_percs,$comm_perc);
- $sum_comm_perc += $comm_perc;
- $max_comm_perc = $comm_perc if $comm_perc > $max_comm_perc;
-
- $index = do get_index_closed_int( $comm_perc, @comm_percs );
- if ( $index != -1 ) {
- $comm_class[$index]++;
- } else {
- print "WARNING: value " . $comm_perc . " not in range (t_rt=$total_rt; ft=$ft)\n" if $pedantic;
- $outside++;
- }
-
- if ( $is_global eq 'T' ) {
- if ( $index != -1 ) {
- $comm_global_class[$index]++;
- } else {
- $outside_global++;
- }
- } else {
- if ( $index != -1 ) {
- $comm_local_class[$index]++;
- } else {
- $outside_local++;
- }
- }
-
- # ------------------------------------------------------------------------
- # Gather statistics about locally sparked threads
- # ------------------------------------------------------------------------
-
- push(@all_local_sparks,$lsp);
- $sum_local_sp += $lsp;
- $max_local_sp = $lsp if $lsp > $max_local_sp;
-
- $index = do get_index_open_int($lsp,@sparks);
- $spark_local_class[$index]++;
-
- # ------------------------------------------------------------------------
- # Gather statistics about globally sparked threads
- # ------------------------------------------------------------------------
-
- push(@all_global_sparks,$gsp);
- $sum_global_sp += $gsp;
- $max_global_sp = $gsp if $gsp > $max_global_sp;
-
- $index = do get_index_open_int($gsp,@sparks);
- $spark_global_class[$index]++;
-
- # ------------------------------------------------------------------------
- # Add the above two entries to get the total number of sparks
- # ------------------------------------------------------------------------
-
- $sp = $lsp + $gsp;
-
- push(@all_sparks,$sp);
- $sum_sp += $sp;
- $max_sp = $sp if $sp > $max_sp;
-
- $index = do get_index_open_int($sp,@sparks);
- $spark_class[$index]++;
-
- # ------------------------------------------------------------------------
- # Gather statistics about heap allocations
- # ------------------------------------------------------------------------
-
- push(@all_has,$ha);
- $sum_ha += $ha;
- $max_ha = $ha if $ha > $max_ha;
-
- $index = do get_index_open_int($ha,@has);
- $ha_class[$index]++;
-
- # do print_line($start,$end,$is_global,$bbs,$ha,$rt,$bt,$bc,$ft,$fc,$my);
-}
-
-print STDERR "You don't want to engage me for a file with just $line_no lines, do you?(N)\n" , exit (-1) if $line_no <= 1;
-
-# ----------------------------------------------------------------------------
-
-do write_pie_chart();
-
-# ----------------------------------------------------------------------------
-# Statistics
-# ----------------------------------------------------------------------------
-
-if ( $opt_D ) {
- print "Lengths:\n" .
- " all_rts: $#all_rts;\n" .
- " all_comm_percs: $#all_comm_percs;\n" .
- " all_sparks: $#all_sparks; \n" .
- " all_local_sparks: $#all_local_sparks; \n" .
- " all_global_sparks: $#all_global_sparks; \n" .
- " all_has: $#all_has\n" .
- " all_fts: $#all_fts;\n";
-
-
- print "No of elems in all_rts: $#all_rts with sum $sum_rt\n";
- print "No of elems in all_comm_percs: $#all_rts with sum $sum_comm_perc\n";
- print "No of elems in all_has: $#all_has with sum $sum_ha\n";
- print "No of elems in all_fts: $#all_fts with sum $sum_ft\n";
-
-}
-
-do do_statistics($line_no);
-
-# Just for debugging
-# ..................
-
-if ( $opt_D ) {
- open(FILE,">LOG") || die "Couldn't open file LOG\n";
- printf FILE "All total runtimes (\@all_rts:)\n";
- printf FILE "[";
- printf FILE join(", ",@all_rts);
- printf FILE "]\n";
- printf FILE " Mean, std. dev: $mean_rt, $std_dev_rt\n";
- printf FILE 70 x "-" . "\n";
- printf FILE "All communication times (\@all_fts:)\n";
- printf FILE "[";
- printf FILE join(", ",@all_fts);
- printf FILE "]\n";
- printf FILE " Mean, std. dev: $mean_ft, $std_dev_ft\n";
- printf FILE 70 x "-" . "\n";
- printf FILE "All communication percentages (\@all_comm_percs:)\n";
- printf FILE "[";
- printf FILE join(", ",@all_comm_percs);
- printf FILE "]\n";
- printf FILE " Mean, std. dev: $mean_comm_perc,$std_dev_comm_perc\n";
- printf FILE 70 x "-" . "\n";
- printf FILE "All sparks (\@all_sparks:)\n";
- printf FILE "[";
- printf FILE join(", ",@all_sparks);
- printf FILE "]\n";
- printf FILE " Mean, std. dev: $mean_spark,$std_dev_spark\n";
- printf FILE 70 x "-" . "\n";
- printf FILE "All local sparks (\@all_local_sparks:)\n";
- printf FILE "[";
- printf FILE join(", ",@all_local_sparks);
- printf FILE "]\n";
- printf FILE " Mean, std. dev: $mean_local_spark,$std_dev_local_spark\n";
- printf FILE 70 x "-" . "\n";
- printf FILE "All global sparks (\@all_global_sparks:)\n";
- printf FILE "[";
- printf FILE join(", ",@all_global_sparks);
- printf FILE "]\n";
- printf FILE " Mean, std. dev: $mean_global_spark,$std_dev_global_spark\n";
- printf FILE 70 x "-" . "\n";
- printf FILE "All local sparks (\@all_has:)\n";
- printf FILE "[";
- printf FILE join(", ",@all_has);
- printf FILE "]\n";
- printf FILE " Mean, std. dev: $mean_ha,$std_dev_ha\n";
- printf FILE 70 x "-" . "\n";
-
-
- printf FILE ("CORR of runtime and heap alloc: %f\n",$c_exec_ha);
- printf FILE ("CORR of runtime and no. of sparks: %f\n",$c_exec_sp);
- printf FILE ("CORR of heap alloc and no. sparks: %f\n",$c_ha_sp);
- printf FILE ("CORR of runtime and local sparks: %f\n",$c_exec_lsp);
- printf FILE ("CORR of runtime and global sparks: %f\n",$c_exec_gsp);
- printf FILE ("CORR of heap alloc and local sparks: %f\n",$c_ha_lsp);
- printf FILE ("CORR of heap alloc and global sparks: %f\n",$c_ha_gsp);
- printf FILE ("CORR of runtime and communication time: %f\n",$c_exec_ft);
- printf FILE ("CORR of heap alloc and communication time: %f\n",$c_ha_ft);
- printf FILE ("CORR of local sparks and communication time: %f\n",$c_lsp_ft);
- printf FILE ("CORR of global_sparks and communication time: %f\n",$c_gsp_ft);
- close FILE;
-}
-
-if ( $opt_P ) {
- do percentify($line_no,*exec_class);
- do percentify($line_no,*exec_global_class);
- do percentify($line_no,*exec_local_class);
- do percentify($line_no,*comm_class);
- do percentify($line_no,*comm_global_class);
- do percentify($line_no,*comm_local_class);
- do percentify($line_no,*spark_local_class);
- do percentify($line_no,*spark_global_class);
- do percentify($line_no,*ha_class);
- do percentify($line_no,*ft_class);
-}
-
-# Produce cumulative RT graph and other (more or less) nice graphs
-# ................................................................
-
-do sort_and_cum();
-
-# ----------------------------------------------------------------------------
-
-open(IV,">INTERVALS") || die "Couldn't open file INTERVALS\n";
-do write_interval(IV, 'G', &guess_interval(@all_rts));
-do write_interval(IV, 'C', 0, int($mean_comm_perc),
- int($mean_comm_perc+$std_dev_comm_perc), 50);
-do write_interval(IV, 'S', &guess_interval(@all_sparks));
-do write_interval(IV, 'A', &guess_interval(@all_has));
-close(IV);
-
-# ----------------------------------------------------------------------------
-# Print results to STDOUT (mainly for testing)
-# ----------------------------------------------------------------------------
-
-if ( $opt_v ) {
- do print_general_info();
-}
-
-# ----------------------------------------------------------------------------
-# Write results to data files to be processed by GNUPLOT
-# ----------------------------------------------------------------------------
-
-do write_data($gran_file_name, $OPEN_INT, $logscale{'g'}, $#exec_times+1,
- @exec_times, @exec_class);
-
-do write_data($gran_global_file_name, $OPEN_INT, $logscale{'g'}, $#exec_times+1,
- @exec_times, @exec_global_class);
-
-do write_data($gran_local_file_name, $OPEN_INT, $logscale{'g'}, $#exec_times+1,
- @exec_times, @exec_local_class);
-
-do write_data($comm_file_name, $CLOSED_INT, $logscale{'c'}, $#comm_percs+1,
- @comm_percs, @comm_class);
-
-do write_data($comm_global_file_name, $CLOSED_INT, $logscale{'c'}, $#comm_percs+1,
- @comm_percs, @comm_global_class);
-
-do write_data($comm_local_file_name, $CLOSED_INT, $logscale{'c'}, $#comm_percs+1,
- @comm_percs, @comm_local_class);
-
-do write_data($spark_file_name, $OPEN_INT, $logscale{'s'}, $#sparks+1,
- @sparks, @spark_class);
-
-do write_data($spark_local_file_name, $OPEN_INT, $logscale{'s'}, $#sparks+1,
- @sparks, @spark_local_class);
-
-do write_data($spark_global_file_name, $OPEN_INT, $logscale{'s'}, $#sparks+1,
- @sparks, @spark_global_class);
-
-do write_data($ha_file_name, $OPEN_INT, $logscale{'a'}, $#has+1,
- @has, @ha_class);
-
-do write_data($ft_file_name, $OPEN_INT, $logscale{'g'}, $#fetch_times+1,
- @fetch_times, @fetch_class);
-
-
-# ----------------------------------------------------------------------------
-# Run GNUPLOT over the data files and create figures
-# ----------------------------------------------------------------------------
-
-do gnu_plotify($gp_file_name);
-
-print "Script finished successfully!\n";
-
-exit 0;
-
-# ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-# ----------------------------------------------------------------------------
-# Basic Operations on the intervals
-# ----------------------------------------------------------------------------
-
-sub get_index_open_int {
- local ($value,@list) = @_;
- local ($index,$right);
-
- # print "get_index: searching for index of" . $value;
- # print " in " . join(':',@list);
-
- $index = 0;
- $right = $list[$index];
- while ( ($value >= $right) && ($index < $#list) ) {
- $index++;
- $right = $list[$index];
- }
-
- return ( ($index == $#list) && ($value > $right) ) ? $index+1 : $index;
-}
-
-# ----------------------------------------------------------------------------
-
-sub get_index_closed_int {
- local ($value,@list) = @_;
- local ($index,$right);
-
- if ( ($value < $list[0]) || ($value > $list[$#list]) ) {
- return ( -1 );
- }
-
- $index = 0;
- $left = $list[$index];
- while ( ($left <= $value) && ($index < $#list) ) {
- $index++;
- $left = $list[$index];
- }
- return ( $index-1 );
-}
-
-# ----------------------------------------------------------------------------
-# Write operations
-# ----------------------------------------------------------------------------
-
-sub write_data {
- local ($file_name, $open_int, $logaxes, $n, @rest) = @_;
- local (@times) = splice(@rest,0,$n);
- local (@class) = @rest;
-
- open(GRAN,">$file_name") || die "Couldn't open file $file_name for output";
-
- if ( $open_int == $OPEN_INT ) {
-
- for ($i=0,
- $left = ( index($logaxes,"x") != -1 ? int($times[0]/2) : 0 ),
- $right = 0;
- $i < $n;
- $i++, $left = $right) {
- $right = $times[$i];
- print GRAN int(($left+$right)/2) . " " .
- ($class[$i] eq "" ? "0" : $class[$i]) . "\n";
- }
- print GRAN $times[$n-1]+(($times[$n-1]-$times[$n-2])/2) . " " .
- ($class[$n] eq "" ? "0" : $class[$n]) . "\n";
-
- } else {
-
- print GRAN ( (index($logaxes,"x") != -1) && ($times[0] == 0 ? int($times[1]/2) : ($times[$1] + $times[0])/2 ) . " " . $class[0] . "\n");
- for ($i=1; $i < $n-2; $i++) {
- $left = $times[$i];
- $right = $times[$i+1];
- print(GRAN ($left+$right)/2 . " " .
- ($class[$i] eq "" ? "0" : $class[$i]) . "\n");
- }
- print GRAN ($times[$n-1]+$times[$n-2])/2 . " " . $class[$n-2] if $n >= 2;
- }
-
- close(GRAN);
-}
-
-# ----------------------------------------------------------------------------
-
-sub write_array {
- local ($file_name,$n,@list) = @_;
-
- open(FILE,">$file_name") || die "$file_name: $!";
- for ($i=0; $i<=$#list; $i++) {
- print FILE $i . " " . ( $list[$i] eq "" ? "0" : $list[$i] ) . "\n";
- }
-
- if ( $opt_D ) {
- print "write_array: (" . join(", ",1 .. $#list) . ")\n for file $file_name returns: \n (0, $#list, &list_max(@list)\n";
- }
-
- return ( (0, $#list, &list_max(@list),
- "(" . join(", ",1 .. $#list) . ")\n") );
-}
-
-# ----------------------------------------------------------------------------
-
-sub write_cumulative_data {
- local ($file_name1,$file_name2,@list) = @_;
- local (@ns, @elems, @xtics, $i, $j, $n, $elem, $max_clust, $xtics_str,
- $xstart, $xend, $file_name0);
- local ($CLUST_SZ) = $no_of_clusters;
-
- @ns = ();
- @elems = ();
- $file_name0 = $file_name1;
- $file_name0 =~ s/\.dat$//;
- $file_name0 .= "0.dat";
- open(CUMM,">$file_name1") || die "Couldn't open file $file_name1 (error $!)\n";
- open(CUMM0,">$file_name0") || die "Couldn't open file $file_name0 (error $!)\n";
-
- print CUMM "1 0\n" unless $list[0] <= 1;
- print CUMM0 "1 0\n" unless $list[0] <= 1;;
-
- for ($i=0; $i <= $#list; $i++) {
- $elem = $list[$i];
- print CUMM ($elem) . " " . int( (100 * ($i)) / ($#list+1) ) . "\n" unless $elem == 0;
- print CUMM0 ($elem) . " " . $i . "\n" unless $elem == 0;;
- for ($n=1; $i < $#list && $list[$i+1] == $elem; $i++, $n++) { }
-
- print CUMM "$elem " . int( (100 * ($i+1)) / ($#list+1) ) . "\n";
- print CUMM0 "$elem " . ($i+1) . "\n";
-
-
- if ( $opt_D ) {
- print "\n--> Insert: n: $n (elem $elem) in the above lists yields: \n ";
- }
-
- # inlined version of do insert_elem($elem, $n, $#exs, @exs, @ns)
- for ($j=0; $j<=$#ns && $ns[$j]>$n; $j++) { }
- if ( $j > $#ns ) {
- push(@ns,$n);
- push(@elems,$elem);
- } else {
- splice(@ns,$j,0,$n); # insert $n at pos $j and move the
- splice(@elems,$j,0,$elem); # rest of the array to the right
- }
-
- if ( $opt_D ) {
- print "[" . join(", ",@ns) . "]" . "\n and \n" .
- "[" . join(", ",@elems) . "]\n";
- }
-
- }
-
- close(CUMM);
- close(CUMM0);
-
- open(CLUSTERS_ALL,">" . (&dirname($file_name2)) . "CL-" .
- &basename($file_name2))
- || die "Couldn't open file CL-$file_name2 (error $!)\n";
- for ($i=0; $i <= $#ns; $i++) {
- print CLUSTERS_ALL "$elems[$i] $ns[$i]\n";
- }
- close(CLUSTERS_ALL);
-
- # Interesting are only the first parts of the list (clusters!)
- splice(@elems, $CLUST_SZ);
- splice(@ns, $CLUST_SZ);
-
- open(CLUSTERS,">$file_name2") || die "Couldn't open file $file_name2 (error $!)\n";
-
- $xstart = &list_min(@elems);
- $xend = &list_max(@elems);
- $step = ($xend - $xstart) / ( $CLUST_SZ == 1 ? 1 : ($CLUST_SZ-1));
-
- @xtics = ();
- for ($i=0, $x=$xstart; $i <= $#ns; $i++, $x+=$step) {
- print CLUSTERS "$x $ns[$i]\n";
- push(@xtics,"\"$elems[$i]\" $x");
- }
- close(CLUSTERS);
-
- $max_clust = $ns[0];
- $xtics_str = "(" . join(", ",@xtics) . ")\n";
-
- return ( ($xstart, $xend, $max_clust, $xtics_str) );
-}
-
-# ----------------------------------------------------------------------------
-
-sub get_xtics {
- local ($open_int, @list) = @_;
-
- local ($str);
-
- if ( $open_int == $OPEN_INT ) {
- $last = pop(@list);
- $str = "( \">0\" 0";
- foreach $x (@list) {
- $str .= ", \">$x\" $x";
- }
- $str .= ", \"Large\" $last)\n";
- } else {
- $left = shift(@list);
- $right = shift(@list) if $#list >= 0;
- $last = pop(@list) if $#list >= 0;
- $str = "( \"$left-$right\" " . $left;
- $left = $right;
- foreach $right (@list) {
- $str .= ", \"$left-$right\" " . ($left+$right)/2;
- $left = $right;
- }
- $str .= ", \"$left-$last\" " . $last .")\n" unless $last eq "";
- }
- return $str;
-}
-
-# ----------------------------------------------------------------------------
-
-sub print_line {
- local ($start,$end,$is_global,$bbs,$ha,$rt,$bt,$bc,$ft,$fc,$my) = @_;
-
- printf("START: %u, END: %u ==> tot_exec: %u\n",
- $start,$end,$end-$start);
- printf(" BASIC_BLOCKS: %u, HEAP_ALLOCATIONS: %u \n",$bbs,$ha);
- printf(" TOT_EXEC: %u = RUN_TIME %u + BLOCK_TIME %u + FETCH_TIME %u\n",
- $end-$start,$rt,$bt,$ft);
- printf(" BLOCK_TIME %u / BLOCK_COUNT %u; FETCH_TIME %u / FETCH_COUNT %u\n",
- $bt,$bc,$ft,$fc);
- printf(" %s %s\n",
- $is_global eq 'T' ? "GLOBAL" : "LOCAL",
- $my eq 'T' ? "MANDATORY" : "NOT MANDATORY");
-}
-
-# ----------------------------------------------------------------------------
-
-sub gnu_plotify {
- local ($gp_file_name) = @_;
-
- local (@open_xrange,@closed_xrang,@spark_xrange,@ha_xrange, @ft_range,
- $exec_xtics,$comm_perc_xtics,$spark_xtics,$has_xtics,
- $cumu0_rts_file, $cumu0_has_file, $cumu0_fts_file);
-
- $cumu0_rts_file = $cumulat_rts_file_name;
- $cumu0_rts_file =~ s/\.dat$//;
- $cumu0_rts_file .= "0.dat";
-
- $cumu0_has_file = $cumulat_has_file_name;
- $cumu0_has_file =~ s/\.dat$//;
- $cumu0_has_file .= "0.dat";
-
- $cumu0_fts_file = $cumulat_fts_file_name;
- $cumu0_fts_file =~ s/\.dat$//;
- $cumu0_fts_file .= "0.dat";
-
- $cumu0_cps_file = $cumulat_cps_file_name;
- $cumu0_cps_file =~ s/\.dat$//;
- $cumu0_cps_file .= "0.dat";
-
- @open_xrange = &range($OPEN_INT,$logscale{'g'},@exec_times);
- @closed_xrange = &range($CLOSED_INT,$logscale{'c'},@comm_percs);
- @spark_xrange = &range($OPEN_INT,$logscale{'s'},@sparks);
- @ha_xrange = &range($OPEN_INT,$logscale{'a'},@has);
- @ft_xrange = &range($OPEN_INT,$logscale{'f'},@fts);
-
- $exec_xtics = $opt_T ? &get_xtics($OPEN_INT,@exec_times) : "" ;
- $comm_perc_xtics = $opt_T ? &get_xtics($CLOSED_INT,@comm_percs) : "";
- $spark_xtics = $opt_T ? &get_xtics($OPEN_INT,@sparks) : "";
- $has_xtics = $opt_T ? &get_xtics($OPEN_INT,@has) : "";
- $fts_xtics = $opt_T ? &get_xtics($OPEN_INT,@fts) : "";
-
- open(GP_FILE,">$gp_file_name") ||
- die "Couldn't open gnuplot file $gp_file_name for output\n";
-
- if ( $opt_m ) {
- print GP_FILE "set term postscript \"Roman\" 20\n";
- } else {
- print GP_FILE "set term postscript color \"Roman\" 20\n";
- }
-
- do write_gp_record(GP_FILE,
- $gran_file_name, &dat2ps_name($gran_file_name),
- "Granularity (pure exec. time)", $ylabel, $logscale{'g'},
- @open_xrange,$max_rt_class,$exec_xtics);
- do write_gp_record(GP_FILE,
- $gran_global_file_name, &dat2ps_name($gran_global_file_name),
- "Granularity (pure exec. time) of exported threads",
- $ylabel, $logscale{'g'},
- @open_xrange,$max_rt_global_class,$exec_xtics);
- do write_gp_record(GP_FILE,
- $gran_local_file_name, &dat2ps_name($gran_local_file_name),
- "Granularity (pure exec. time) of not exported threads",
- $ylabel,$logscale{'g'},
- @open_xrange,$max_rt_local_class,$exec_xtics);
-
- do write_gp_record(GP_FILE,
- $comm_file_name, &dat2ps_name($comm_file_name),
- "% of communication",$ylabel,$logscale{'c'},
- @closed_xrange,$max_comm_perc_class,$comm_perc_xtics);
- do write_gp_record(GP_FILE,
- $comm_global_file_name, &dat2ps_name($comm_global_file_name),
- "% of communication of exported threads",$ylabel,$logscale{'c'},
- @closed_xrange,$max_comm_perc_global_class,$comm_perc_xtics);
- do write_gp_record(GP_FILE,
- $comm_local_file_name, &dat2ps_name($comm_local_file_name),
- "% of communication of not exported threads",$ylabel,$logscale{'c'},
- @closed_xrange,$max_comm_perc_local_class,$comm_perc_xtics);
- do write_gp_record(GP_FILE,
- $ft_file_name, &dat2ps_name($ft_file_name),
- "Communication time", $ylabel, $logscale{'g'},
- @open_xrange,$max_ft_class,$fts_xtics);
-
-
- do write_gp_record(GP_FILE,
- $spark_file_name, &dat2ps_name($spark_file_name),
- "No. of sparks created", $ylabel, $logscale{'s'},
- @spark_xrange,$max_spark_class,$spark_xtics);
-
- do write_gp_record(GP_FILE,
- $spark_local_file_name, &dat2ps_name($spark_local_file_name),
- "No. of sparks created (parLocal)", $ylabel, $logscale{'s'},
- @spark_xrange,$max_spark_local_class,$spark_xtics);
-
- do write_gp_record(GP_FILE,
- $spark_global_file_name, &dat2ps_name($spark_global_file_name),
- "No. of sparks created (parGlobal)", $ylabel, $logscale{'s'},
- @spark_xrange,$max_spark_global_class,$spark_xtics);
-
- do write_gp_record(GP_FILE,
- $ha_file_name, &dat2ps_name($ha_file_name),
- "Heap Allocations (words)", $ylabel, $logscale{'a'},
- @ha_xrange,$max_ha_class,$has_xtics);
-
- do write_gp_lines_record(GP_FILE,
- $cumulat_rts_file_name, &dat2ps_name($cumulat_rts_file_name),
- "Cumulative pure exec. times","% of threads",
- $logscale{'Cg'},
- $xend_cum_rts, $yend_cum_rts,"");
- # $xtics_cluster_rts as last arg?
-
- do write_gp_lines_record(GP_FILE,
- $cumulat_has_file_name, &dat2ps_name($cumulat_has_file_name),
- "Cumulative heap allocations","% of threads",
- $logscale{'Ca'},
- $xend_cum_has, $yend_cum_has,"");
- # $xtics_cluster_has as last arg?
-
- do write_gp_lines_record(GP_FILE,
- $cumu0_rts_file, &dat2ps_name($cumu0_rts_file),
- "Cumulative pure exec. times","Number of threads",
- $logscale{'Cg'},
- $xend_cum_rts, $yend_cum0_rts,"");
- # $xtics_cluster_rts as last arg?
-
- do write_gp_lines_record(GP_FILE,
- $cumu0_has_file, &dat2ps_name($cumu0_has_file),
- "Cumulative heap allocations","Number of threads",
- $logscale{'Ca'},
- $xend_cum_has, $yend_cum0_has,"");
- # $xtics_cluster_has as last arg?
-
- do write_gp_lines_record(GP_FILE,
- $cumulat_fts_file_name, &dat2ps_name($cumulat_fts_file_name),
- "Cumulative communication times","% of threads",
- $logscale{'Cg'},
- $xend_cum_fts, $yend_cum_fts,"");
- # $xtics_cluster_rts as last arg?
-
- do write_gp_lines_record(GP_FILE,
- $cumu0_fts_file, &dat2ps_name($cumu0_fts_file),
- "Cumulative communication times","Number of threads",
- $logscale{'Cg'},
- $xend_cum_fts, $yend_cum0_fts,"");
- # $xtics_cluster_rts as last arg?
-
- do write_gp_lines_record(GP_FILE,
- $cumulat_cps_file_name, &dat2ps_name($cumulat_cps_file_name),
- "Cumulative communication percentages","% of threads",
- "", # No logscale here !
- $xend_cum_cps, $yend_cum_cps,"");
- # $xtics_cluster_rts as last arg?
-
- do write_gp_lines_record(GP_FILE,
- $cumu0_cps_file, &dat2ps_name($cumu0_cps_file),
- "Cumulative communication percentages","Number of threads",
- "", # No logscale here !
- $xend_cum_cps, $yend_cum0_cps,"");
- # $xtics_cluster_rts as last arg?
-
- do write_gp_record(GP_FILE,
- $clust_rts_file_name, &dat2ps_name($clust_rts_file_name),
- "Pure exec. time", "No. of threads", $logscale{'CG'},
- $xstart_cluster_rts,$xend_cluster_rts,$max_cluster_rts,$xtics_cluster_rts);
-
- do write_gp_record(GP_FILE,
- $clust_has_file_name, &dat2ps_name($clust_has_file_name),
- "Pure exec. time", "No. of threads", $logscale{'CA'},
- $xstart_cluster_has,$xend_cluster_has,$max_cluster_has,$xtics_cluster_has);
-
- do write_gp_record(GP_FILE,
- $clust_fts_file_name, &dat2ps_name($clust_fts_file_name),
- "Communication time", "No. of threads", $logscale{'CG'},
- $xstart_cluster_fts,$xend_cluster_fts,$max_cluster_fts,$xtics_cluster_rts);
-
-
- do write_gp_simple_record(GP_FILE,
- $pe_file_name, &dat2ps_name($pe_file_name),
- "Processing Elements (PEs)", "Ready Time (not running)",
- $logscale{'Yp'},$xstart_pe,$xend_pe,$max_pe,$xtics_pe);
-
- do write_gp_simple_record(GP_FILE,
- $sn_file_name, &dat2ps_name($sn_file_name),
- "Spark sites", "Pure exec. time",
- $logscale{'Ys'},$xstart_sn,$xend_sn,$max_sn,$xtics_sn);
-
- close GP_FILE;
-
- print "Gnu plotting figures ...\n";
- system "gnuplot $gp_file_name";
-
- print "Extending thickness of impulses ...\n";
- do gp_ext($gran_file_name,
- $gran_global_file_name,
- $gran_local_file_name,
- $comm_file_name,
- $comm_global_file_name,
- $comm_local_file_name,
- $spark_file_name,
- $spark_local_file_name,
- $spark_global_file_name,
- $ha_file_name,
- $ft_file_name,
- $clust_fts_file_name,
- $clust_rts_file_name,
- $clust_has_file_name,
- $pe_file_name,
- $sn_file_name
- );
-
-
-}
-
-# ----------------------------------------------------------------------------
-
-sub gp_ext {
- local (@file_names) = @_;
- local ($file_name);
- local ($ps_file_name);
- local ($prg);
-
- #$prg = system "which gp-ext-imp";
- #print " Using script $prg for impuls extension\n";
- $prg = $ENV{GRANDIR} ? $ENV{GRANDIR} . "/bin/gp-ext-imp"
- : $ENV{HOME} . "/bin/gp-ext-imp" ;
- if ( $opt_v ) {
- print " (using script $prg)\n";
- }
-
- foreach $file_name (@file_names) {
- $ps_file_name = &dat2ps_name($file_name);
- system "$prg -w $ext_size -g $gray " .
- $ps_file_name . " " .
- $ps_file_name . "2" ;
- system "mv " . $ps_file_name . "2 " . $ps_file_name;
- }
-}
-
-# ----------------------------------------------------------------------------
-
-sub write_gp_record {
- local ($file,$in_file,$out_file,$xlabel,$ylabel,$logaxes,
- $xstart,$xend,$ymax,$xtics) = @_;
-
- if ( $xstart >= $xend ) {
- print ("WARNING: empty xrange [$xstart:$xend] changed to [$xstart:" . $xstart+1 . "]\n") if ( $pedantic || $opt_v );
- $xend = $xstart + 1;
- }
-
- if ( $ymax <=0 ) {
- $ymax = 2;
- print "WARNING: empty yrange changed to [0:$ymax]\n" if ( $pedantic || $opt_v );
- }
-
- $str = "set size " . $xsize . "," . $ysize . "\n" .
- "set xlabel \"" . $xlabel . "\"\n" .
- "set ylabel \"" . $ylabel . "\"\n" .
- ($xstart eq "" ? ""
- : "set xrange [" . int($xstart) .":" . int($xend) . "]\n") .
- ($ymax eq "" ? ""
- : "set yrange [" . (index($logaxes,"y") != -1 ? 1 : 0) .
- ":" . &list_max(2,int($ymax+$ymax/5)) . "]\n") .
- ($xtics ne "" ? "set xtics $xtics" : "") .
- "set tics out\n" .
- "set border\n" .
- "set title \"$nPEs PEs\"\n" .
- "set nokey \n" .
- "set nozeroaxis\n" .
- "set format xy \"%g\"\n" .
- (index($logaxes,"x") != -1 ?
- "set logscale x\n" :
- "set nologscale x\n") .
- (index($logaxes,"y") != -1 ?
- "set logscale y\n" :
- "set nologscale y\n") .
- "set output \"" . $out_file . "\"\n" .
- "plot \"" . $in_file . "\" with impulses\n\n";
- print $file $str;
-}
-
-# ----------------------------------------------------------------------------
-
-sub write_gp_lines_record {
- local ($file,$in_file,$out_file,$xlabel,$ylabel,$logaxes,
- $xend,$yend,$xtics) = @_;
-
- local ($str);
-
- $str = "set xlabel \"" . $xlabel . "\"\n" .
- "set ylabel \"" . $ylabel . "\"\n" .
- "set xrange [" . ( index($logaxes,"x") != -1 ? 1 : 0 ) . ":$xend]\n" .
- "set yrange [" . ( index($logaxes,"y") != -1 ? 1 : 0 ) . ":$yend]\n" .
- "set border\n" .
- "set nokey\n" .
- ( $xtics ne "" ? "set xtics $xtics" : "" ) .
- (index($logaxes,"x") != -1 ?
- "set logscale x\n" :
- "set nologscale x\n") .
- (index($logaxes,"y") != -1 ?
- "set logscale y\n" :
- "set nologscale y\n") .
- "set nozeroaxis\n" .
- "set format xy \"%g\"\n" .
- "set output \"" . $out_file . "\"\n" .
- "plot \"" . $in_file . "\" with lines\n\n";
- print $file $str;
-}
-
-
-# ----------------------------------------------------------------------------
-
-sub write_gp_simple_record {
- local ($file,$in_file,$out_file,$xlabel,$ylabel,$logaxes,
- $xstart,$xend,$ymax,$xtics) = @_;
-
- $str = "set size " . $xsize . "," . $ysize . "\n" .
- "set xlabel \"" . $xlabel . "\"\n" .
- "set ylabel \"" . $ylabel . "\"\n" .
- ($xstart eq "" ? ""
- : "set xrange [" . int($xstart) .":" . int($xend) . "]\n") .
- ($ymax eq "" ? ""
- : "set yrange [" . (index($logaxes,"y") != -1 ? 1 : 0) .
- ":" . &list_max(2,int($ymax+$ymax/5)) . "]\n") .
- ($xtics ne "" ? "set xtics $xtics" : "") .
- "set border\n" .
- "set nokey\n" .
- "set tics out\n" .
- "set nozeroaxis\n" .
- "set format xy \"%g\"\n" .
- (index($logaxes,"x") != -1 ?
- "set logscale x\n" :
- "set nologscale x\n") .
- (index($logaxes,"y") != -1 ?
- "set logscale y\n" :
- "set nologscale y\n") .
- "set output \"" . $out_file . "\"\n" .
- "plot \"" . $in_file . "\" with impulses\n\n";
- print $file $str;
-}
-
-# ----------------------------------------------------------------------------
-
-sub dat2ps_name {
- local ($dat_name) = @_;
-
- $dat_name =~ s/\.dat$/\.ps/;
- return ($dat_name);
-}
-
-# ----------------------------------------------------------------------------
-
-sub range {
- local ($open_int, $logaxes, @ints) = @_;
-
- local ($range, $left_margin, $right_margin);
-
- $range = $ints[$#ints]-$ints[0];
- $left_margin = 0; # $range/10;
- $right_margin = 0; # $range/10;
-
- if ( $opt_D ) {
- print "\n==> Range: logaxes are $logaxes i.e. " .
- (index($logaxes,"x") != -1 ? "matches x axis\n"
- : "DOESN'T match x axis\n");
- }
- if ( index($logaxes,"x") != -1 ) {
- if ( $open_int == $OPEN_INT ) {
- return ( ($ints[0]/2-$left_margin,
- $ints[$#ints]+($ints[$#ints]-$ints[$#ints-1])/2+$right_margin) );
- } else {
- return ( ( &list_max(1,$ints[0]-$left_margin),
- $ints[$#ints]+($ints[$#ints]-$ints[$#ints-1])/2+$right_margin) );
- }
- } else {
- if ( $open_int == $OPEN_INT ) {
- return ( ($ints[0]/2-$left_margin,
- $ints[$#ints]+($ints[$#ints]-$ints[$#ints-1])/2+$right_margin) );
- } else {
- return ( ($ints[0]-$left_margin,
- $ints[$#ints]+($ints[$#ints]-$ints[$#ints-1])/2+$right_margin) );
- }
- }
-}
-
-# ----------------------------------------------------------------------------
-
-sub percentify {
- local ($sum,*classes) = @_;
-
- for ($i=0; $i<=$#classes; $i++) {
- $classes[$i] = (100 * $classes[$i]) / $sum;
- }
-}
-
-# ----------------------------------------------------------------------------
-# ToDo: get these statistics functions from "stat.pl"
-# ----------------------------------------------------------------------------
-
-sub mean_std_dev {
- local ($sum,@list) = @_;
-
- local ($n, $s, $s_);
-
- #print "\nmean_std_dev: sum is $sum ; list has length $#list";
-
- $n = $#list+1;
- $mean_value = $sum/$n;
-
- $s_ = 0;
- foreach $x (@list) {
- $s_ += $x;
- $s += ($mean_value - $x) ** 2;
- }
- if ( $sum != $s_ ) {
- print "ERROR in mean_std_dev: provided sum is wrong " .
- "(provided: $sum; computed: $s_)\n";
- print " list_sum: " . &list_sum(@list) . "\n";
- exit (2);
- }
-
- return ( ($mean_value, sqrt($s / ($n - 1)) ) );
-}
-
-# ----------------------------------------------------------------------------
-
-sub _mean_std_dev {
- return ( &mean_std_dev(&list_sum(@_), @_) );
-}
-
-# ----------------------------------------------------------------------------
-# Compute covariance of 2 vectors, having their sums precomputed.
-# Input: $n ... number of all elements in @list_1 as well as in @list_2
-# (i.e. $n = $#list_1+1 = $#list_2+1).
-# $mean_1 ... mean value of all elements in @list_1
-# @list_1 ... list of integers; first vector
-# $mean_2 ... mean value of all elements in @list_2
-# @list_2 ... list of integers; first vector
-# Output: covariance of @list_1 and @list_2
-# ----------------------------------------------------------------------------
-
-sub cov {
- local ($n, $mean_1, @rest) = @_;
- local (@list_1) = splice(@rest,0,$n);
- local ($mean_2, @list_2) = @rest;
-
- local ($i,$s,$s_1,$s_2);
-
- for ($i=0; $i<$n; $i++) {
- $s_1 += $list_1[$i];
- $s_2 += $list_2[$i];
- $s += ($mean_1 - $list_1[$i]) * ($mean_2 - $list_2[$i]);
- }
- if ( $mean_1 != ($s_1/$n) ) {
- print "ERROR in cov: provided mean value is wrong " .
- "(provided: $mean_1; computed: " . ($s_1/$n) . ")\n";
- exit (2);
- }
- if ( $mean_2 != ($s_2/$n) ) {
- print "ERROR in cov: provided mean value is wrong " .
- "(provided: $mean_2; computed: " . ($s_2/$n) . ")\n";
- exit (2);
- }
- return ( $s / ($n - 1) ) ;
-}
-
-# ----------------------------------------------------------------------------
-# Compute correlation of 2 vectors, having their sums precomputed.
-# Input: $n ... number of all elements in @list_1 as well as in @list_2
-# (i.e. $n = $#list_1+1 = $#list_2+1).
-# $sum_1 ... sum of all elements in @list_1
-# @list_1 ... list of integers; first vector
-# $sum_2 ... sum of all elements in @list_2
-# @list_2 ... list of integers; first vector
-# Output: correlation of @list_1 and @list_2
-# ----------------------------------------------------------------------------
-
-sub corr {
- local ($n, $sum_1, @rest) = @_;
- local (@list_1) = splice(@rest,0,$n);
- local ($sum_2, @list_2) = @rest;
-
- local ($mean_1,$mean_2,$std_dev_1,$std_dev_2);
-
- if ( $opt_D ) {
- print "\ncorr: n=$n sum_1=$sum_1 sum_2=$sum_2\n";
- print " list_sum of list_1=" . &list_sum(@list_1) .
- " list_sum of list_2=" . &list_sum(@list_2) . "\n";
- print " len of list_1=$#list_1 len of list_2=$#list_2\n";
- }
-
- ($mean_1, $std_dev_1) = &mean_std_dev($sum_1,@list_1);
- ($mean_2, $std_dev_2) = &mean_std_dev($sum_2,@list_2);
-
- if ( $opt_D ) {
- print "corr: $mean_1, $std_dev_1; $mean_2, $std_dev_2\n";
- }
-
- return ( ($std_dev_1 * $std_dev_2) == 0 ?
- 0 :
- &cov($n, $mean_1, @list_1, $mean_2, @list_2) /
- ( $std_dev_1 * $std_dev_2 ) );
-}
-
-# ----------------------------------------------------------------------------
-
-sub list_sum {
- local (@list) = @_;
-
- local ($sum);
-
- foreach $x (@list) {
- $sum += $x;
- }
-
- return ($sum);
-}
-
-# ----------------------------------------------------------------------------
-
-sub list_max {
- local (@list) = @_;
-
- local ($max) = shift;
-
- foreach $x (@list) {
- $max = $x if $x > $max;
- }
-
- return ($max);
-}
-
-# ----------------------------------------------------------------------------
-
-sub list_min {
- local (@list) = @_;
-
- local ($min) = shift;
-
- foreach $x (@list) {
- $min = $x if $x < $min;
- }
-
- return ($min);
-}
-
-# ----------------------------------------------------------------------------
-
-sub guess_interval {
- local (@list) = @_ ;
-
- local ($min,$max,$sum,$mean,$std_dev,@intervals);
-
- $min = &list_min(@list);
- $max = &list_max(@list);
- $sum = &list_sum(@list);
- ($mean, $std_dev) = &mean_std_dev($sum,@list);
-
- @intervals = (int($mean-$std_dev),int($mean-$std_dev/2),int($mean),
- int($mean+$std_dev/2),int($mean+$std_dev));
-
- while ($#intervals>=0 && $intervals[0]<0) {
- shift(@intervals);
- }
-
- return (@intervals);
-}
-
-# ----------------------------------------------------------------------------
-
-sub write_interval {
- local ($file,$flag,@intervals) = @_;
-
- printf $file "$flag: (" . join(", ",@intervals) . ")\n";
-}
-
-# ----------------------------------------------------------------------------
-
-sub read_template {
-
- if ( $opt_v ) {
- print "Reading settings from template file $templ_file_name ...\n";
- }
-
- open(TEMPLATE,$templ_file_name) || die "Couldn't open file $templ_file_name";
- while (<TEMPLATE>) {
- next if /^\s*$/ || /^--/;
- if (/^\s*G[:,;.\s]+([^\n]+)$/) {
- $list_str = $1;
- $list_str =~ s/[\(\)\[\]]//g;
- @exec_times = split(/[,;. ]+/, $list_str);
- } elsif (/^\s*F[:,;.\s]+([^\n]+)$/) {
- $list_str = $1;
- $list_str =~ s/[\(\)\[\]]//g;
- @fetch_times = split(/[,;. ]+/, $list_str);
- } elsif (/^\s*A[:,;.\s]+([^\n]+)$/) {
- $list_str = $1;
- $list_str =~ s/[\(\)\[\]]//g;
- @has = split(/[,;. ]+/, $list_str);
- } elsif (/^\s*C[:,;.\s]+([^\n]+)$/) {
- $list_str = $1;
- $list_str =~ s/[\(\)\[\]]//g;
- @comm_percs = split(/[,;. ]+/, $list_str);
- } elsif (/^\s*S[:,;.\s]+([^\n]+)$/) {
- $list_str = $1;
- $list_str =~ s/[\(\)\[\]]//g;
- @sparks = split(/[,;. ]+/, $list_str);
- } elsif (/^\s*g[:,;.\s]+([\S]+)$/) {
- ($gran_file_name,$gran_global_file_name, $gran_local_file_name) =
- &mk_global_local_names($1);
- } elsif (/^\s*f[:,;.\s]+([\S]+)$/) {
- ($ft_file_name,$ft_global_file_name, $ft_local_file_name) =
- &mk_global_local_names($1);
- } elsif (/^\s*c[:,;.\s]+([\S]+)$/) {
- ($comm_file_name, $comm_global_file_name, $comm_local_file_name) =
- &mk_global_local_names($1);
- } elsif (/^\s*s[:,;.\s]+([\S]+)$/) {
- ($spark_file_name, $spark_global_file_name, $spark_local_file_name) =
- &mk_global_local_names($1);
- } elsif (/^\s*a[:,;.\s]+([\S]+)$/) {
- ($ha_file_name, $ha_global_file_name, $ha_local_file_name) =
- &mk_global_local_names($1);
- } elsif (/^\s*p[:,;.\s]+([\S]+)$/) {
- $gp_file_name = $1;
- $ps_file_name = &dat2ps_name($gp_file_name);
-
- } elsif (/^\s*Xcorr[:,;.\s]+([\S]+)$/) {
- $corr_file_name = $1;
- } elsif (/^\s*Xcumulat-rts[:,;.\s]+([\S]+)$/) {
- $cumulat_rts_file_name = $1;
- } elsif (/^\s*Xcumulat-has[:,;.\s]+([\S]+)$/) {
- $cumulat_has_file_name = $1;
- } elsif (/^\s*Xcumulat-fts[:,;.\s]+([\S]+)$/) {
- $cumulat_fts_file_name = $1;
- } elsif (/^\s*Xcumulat-cps[:,;.\s]+([\S]+)$/) {
- $cumulat_cps_file_name = $1;
- } elsif (/^\s*Xclust-rts[:,;.\s]+([\S]+)$/) {
- $clust_rts_file_name = $1;
- } elsif (/^\s*Xclust-has[:,;.\s]+([\S]+)$/) {
- $clust_has_file_name = $1;
- } elsif (/^\s*Xclust-fts[:,;.\s]+([\S]+)$/) {
- $clust_fts_file_name = $1;
- } elsif (/^\s*Xclust-cps[:,;.\s]+([\S]+)$/) {
- $clust_cps_file_name = $1;
- } elsif (/^\s*Xpe[:,;.\s]+([\S]+)$/) {
- $pe_file_name = $1;
- } elsif (/^\s*Xsn[:,;.\s]+([\S]+)$/) {
- $sn_file_name = $1;
-
- } elsif (/^\s*XRTS[:,;.\s]+([\S]+)$/) {
- $rts_file_name = $1;
- } elsif (/^\s*XHAS[:,;.\s]+([\S]+)$/) {
- $has_file_name = $1;
- } elsif (/^\s*XFTS[:,;.\s]+([\S]+)$/) {
- $fts_file_name = $1;
- } elsif (/^\s*XLSPS[:,;.\s]+([\S]+)$/) {
- $lsps_file_name = $1;
- } elsif (/^\s*XGSPS[:,;.\s]+([\S]+)$/) {
- $gsps_file_name = $1;
- } elsif (/^\s*XCPS[:,;.\s]+([\S]+)$/) {
- $cps_file_name = $1;
- } elsif (/^\s*XCCPS[:,;.\s]+([\S]+)$/) {
- $ccps_file_name = $1;
-
- } elsif (/^\s*\-[:,;.\s]+([\S]+)$/) {
- $input = $1;
- } elsif (/^\s*L[:,;\s]+(.*)$/) {
- $str = $1;
- %logscale = ('g',"xy",'a',"xy",'Cg',"xy",'Ca',"xy",'Yp',"y",'Ys',"y") , next if $str eq ".";
- $str =~ s/[\(\)\[\]]//g;
- %logscale = split(/[,;. ]+/, $str);
- } elsif (/^\s*i[:,;.\s]+([\S]+)$/) {
- $gray = $1;
- } elsif (/^\s*k[:,;.\s]+([\S]+)$/) {
- $no_of_clusters = $1;
- } elsif (/^\s*e[:,;.\s]+([\S]+)$/) {
- $ext_size = $1;
- } elsif (/^\s*v.*$/) {
- $verbose = 1;
- } elsif (/^\s*T.*$/) {
- $opt_T = 1;
- } elsif (/^\s*m.*$/) {
- $opt_m = 1;
- }
- }
- close(TEMPLATE);
-}
-
-# ----------------------------------------------------------------------------
-
-sub mk_global_local_names {
- local ($file_name) = @_;
-
- $file_name .= ".dat" unless $file_name =~ /\.dat$/;
- $global_file_name = $file_name;
- $global_file_name =~ s/\.dat/\-global\.dat/ ;
- $local_file_name = $file_name;
- $local_file_name =~ s/\.dat/\-local\.dat/ ;
-
- return ( ($file_name, $global_file_name, $local_file_name) );
-}
-
-# ----------------------------------------------------------------------------
-
-# ----------------------------------------------------------------------------
-
-sub pre_process {
- local ($lines) = @_;
-
- local (@all_rts, @all_comm_percs, @all_sparks, @all_local_sparks,
- @all_global_sparks, @all_has, @fields,
- $line_no, $elem, $total_rt, $comm_perc,
- $pe, $start, $end, $is_global, $bbs, $ha, $rt, $bt, $ft,
- $lsp, $gsp, $my);
-
- if ( $opt_v ) {
- print "Preprocessing file $input ... \n";
- }
-
- open(INPUT,"<$input") || die "Couldn't open input file $input";
-
- do skip_header();
-
- $line_no = 0;
- while (<INPUT>) {
- $line_no++;
- last if $line_no > $lines;
-
- @fields = split(/,/,$_);
-
- foreach $elem (@fields) {
- foo : {
- $pe = $1 , last foo if $elem =~ /^\s*PE\s+(\d+).*$/;
- $start = $1 , last foo if $elem =~ /^\s*ST\s+(\d+).*$/;
- $end = $1 , last foo if $elem =~ /^\s*END\s+(\d+).*$/;
- $is_global = $1 , last foo if $elem =~ /^\s*GBL\s+(T|F).*$/;
- $bbs = $1 , last foo if $elem =~ /^\s*BB\s+(\d+).*$/;
- $ha = $1 , last foo if $elem =~ /^\s*HA\s+(\d+).*$/;
- $rt = $1 , last foo if $elem =~ /^\s*RT\s+(\d+).*$/;
- $bt = $1, $bc = $2 , last foo if $elem =~ /^\s*BT\s+(\d+)\s+\((\d+)\).*$/;
- $ft = $1, $fc = $2 , last foo if $elem =~ /^\s*FT\s+(\d+)\s+\((\d+)\).*$/;
- $lsp = $1 , last foo if $elem =~ /^\s*LS\s+(\d+).*$/;
- $gsp = $1 , last foo if $elem =~ /^\s*GS\s+(\d+).*$/;
- $my = $1 , last foo if $elem =~ /^\s*MY\s+(T|F).*$/;
- }
- }
-
- $total_rt = $end - $start;
- $comm_perc = ( $total_rt == 0 ? 100 : (100 * $ft)/$total_rt );
- $sp = $lsp + $gsp;
-
- push(@all_rts,$rt);
-
- push(@all_comm_percs,$comm_perc);
-
- push(@all_sparks,$sp);
- push(@all_local_sparks,$lsp);
- push(@all_global_sparks,$gsp);
-
- push(@all_has,$ha);
- }
-
- close(INPUT);
-
- @exec_times = &guess_interval(@all_rts);
- @sparks = &guess_interval(@all_sparks);
- @has = &guess_interval(@all_has);
-
- ($m,$std_dev) = &_mean_std_dev(@all_comm_percs);
- @comm_percs = (0, int($m), int($std_dev), 100) unless int($m) == 0;
- @comm_percs = (0, 1, 2, 5, 10, 50, 100) if int($m) == 0;
-}
-
-# ----------------------------------------------------------------------------
-
-sub process_options {
- if ( $opt_h ) {
- open(ME,$0) || die "Can't open myself ($0)";
- $n = 0;
- while (<ME>) {
- last if $_ =~ /^$/;
- print $_;
- $n++;
- }
- close(ME);
-
- # system "cat $0 | awk 'BEGIN { n = 0; } \
- # /^$/ { print n; \
- # exit; } \
- # { n++; }'"
- exit ;
- }
-
- if ( $opt_W ) {
- $pedantic = 1;
- } else {
- $pedantic = 0;
- }
-
- $input = $#ARGV == -1 ? "-" : $ARGV[0] ;
-
- if ( $#ARGV != 0 ) {
- #print "Usage: gran-extr [options] <sim-file>\n";
- #print "Use -h option to get details\n";
- #exit 1;
-
- }
-
-
- if ( ! $opt_t ) {
- do pre_process(20);
- }
-
- if ( $opt_g ) {
- ($gran_file_name, $gran_global_file_name, $gran_local_file_name) =
- do mk_global_local_names($opt_g);
- } else {
- $gran_file_name = "gran.dat";
- $gran_global_file_name = "gran-global.dat";
- $gran_local_file_name = "gran-local.dat";
- }
-
- if ( $opt_c ) {
- ($comm_file_name, $comm_global_file_name, $comm_local_file_name) =
- do mk_global_local_names($opt_c);
- } else {
- $comm_file_name = "comm.dat";
- $comm_global_file_name = "comm-global.dat";
- $comm_local_file_name = "comm-local.dat";
- }
-
- if ( $opt_f ) {
- ($ft_file_name, $ft_global_file_name, $ft_local_file_name) =
- do mk_global_local_names($opt_c);
- } else {
- $ft_file_name = "ft.dat";
- $ft_global_file_name = "ft-global.dat";
- $ft_local_file_name = "ft-local.dat";
- }
-
- if ( $opt_s ) {
- ($spark_file_name, $spark_global_file_name, $spark_local_file_name) =
- do mk_global_local_names($opt_s);
- } else {
- $spark_file_name = "spark.dat";
- $spark_global_file_name = "spark-global.dat";
- $spark_local_file_name = "spark-local.dat";
- }
-
- if ( $opt_a ) {
- ($ha_file_name, $ha_global_file_name, $ha_local_file_name) =
- do mk_global_local_names($opt_a);
- } else {
- $ha_file_name = "ha.dat";
- }
-
- if ( $opt_p ) {
- $gp_file_name = $opt_p;
- } else {
- $gp_file_name = "gran.gp";
- }
-
- $ps_file_name = &dat2ps_name($gp_file_name);
-
- $corr_file_name = "CORR";
- $cumulat_rts_file_name = "cumulative-rts.dat";
- $cumulat_has_file_name = "cumulative-has.dat";
- $cumulat_fts_file_name = "cumulative-fts.dat";
- $cumulat_cps_file_name = "cumulative-cps.dat";
- $clust_rts_file_name = "clusters-rts.dat";
- $clust_has_file_name = "clusters-has.dat";
- $clust_fts_file_name = "clusters-fts.dat";
- $clust_cps_file_name = "clusters-cps.dat";
- $pe_file_name = "pe.dat";
- $sn_file_name = "sn.dat";
-
- $pie_file_name = "Pie.ps";
-
- $cps_file_name = "CPS";
- $fts_file_name = "FTS";
- $rts_file_name = "RTS";
- $has_file_name = "HAS";
- $lsps_file_name = "LSPS";
- $gsps_file_name = "GSPS";
- $ccps_file_name = "CCPS";
-
- if ( $opt_l ) {
- $left_margin = $opt_l;
- } else {
- $left_margin = 0;
- }
- $left_perc_margin = 0;
-
- if ( $opt_r ) {
- $right_margin = $opt_r;
- } else {
- $right_margin = 0;
- }
- $right_perc_margin = 0;
-
- if ( $opt_x ) {
- $xsize = $opt_x;
- } else {
- $xsize = 1;
- }
-
- if ( $opt_y ) {
- $ysize = $opt_y;
- } else {
- $ysize = 1;
- }
-
- if ( $opt_e ) {
- $ext_size = $opt_e;
- } else {
- $ext_size = 200;
- }
-
- if ( $opt_i ) {
- $gray = $opt_i;
- } else {
- $gray = 0;
- }
-
- if ( $opt_k ) {
- $no_of_clusters = $opt_k;
- } else {
- $no_of_clusters = 5;
- }
-
- if ( $opt_L ) {
- $str = $opt_L;
- $str =~ s/[\(\)\[\]]//g;
- %logscale = split(/[,;. ]+/, $str);
- # $logscale = $opt_L;
- } else {
- %logscale = (); # ('g',"xy",'a',"xy",'Cg',"xy",'Ca',"xy");
- }
-
-# $delta = do compute_delta(@exec_times);
-# $no_of_exec_times = $#exec_times;
-
- if ( $opt_G ) {
- $opt_G =~ s/[\(\)\[\]]//g;
- @exec_times = split(/[,;. ]+/, $opt_G);
- # @exec_times = split(/[,;. ]+/, ($opt_G =~ s/[\(\)]//g));
- } else {
- # @exec_times = (50, 100, 200, 300, 400, 500, 700);
- }
-
- if ( $opt_F ) {
- $opt_F =~ s/[\(\)\[\]]//g;
- @fetch_times = split(/[,;. ]+/, $opt_F);
- # @fetch_times = split(/[,;. ]+/, ($opt_F =~ s/[\(\)]//g));
- } else {
- # @fetch_times = (50, 100, 200, 300, 400, 500, 700);
- }
-
- if ( $opt_C ) {
- $opt_C =~ s/[\(\)\[\]]//g;
- @comm_percs = split(/[,;. ]+/, $opt_C);
- } else {
- # @comm_percs = (0,10,20,30,50,100);
- }
-
- if ( $opt_S ) {
- $opt_S =~ s/[\(\)\[\]]//g;
- @sparks = split(/[,;. ]+/, $opt_S);
- } else {
- # @sparks = (0,5,10,50);
- }
-
-# $delta_comm = do compute_delta(@comm_percs);
-
- if ( $opt_A ) {
- $opt_A =~ s/[\(\)\[\]]//g;
- @has = split(/[,;. ]+/, $opt_A);
- } else {
- # @has = (10, 100, 200, 300, 500, 1000);
- }
-
- if ( $opt_t ) {
- $templ_file_name = ( $opt_t eq '.' ? "TEMPL" # default file name
- : $opt_t eq ',' ? "/users/fp/hwloidl/grasp/GrAn/bin/TEMPL" # global master template
- : $opt_t eq '/' ? "/users/fp/hwloidl/grasp/GrAn/bin/T0" # template, that throws away most of the info
- : $opt_t );
- do read_template();
- # see RTS2gran for use of template-package
- }
-
- $ylabel = $opt_P ? "% of threads" : "No. of threads";
-}
-
-# ----------------------------------------------------------------------------
-
-sub print_verbose_message {
-
- print "-" x 70 . "\n";
- print "Setup: \n";
- print "-" x 70 . "\n";
- print "\nFilenames: \n";
- print " Input file: $input\n";
- print " Gran files: $gran_file_name $gran_global_file_name $gran_local_file_name\n";
- print " Comm files: $comm_file_name $comm_global_file_name $comm_local_file_name\n";
- print " Sparked threads file: $spark_file_name $spark_local_file_name $spark_global_file_name\n";
- print " Heap file: $ha_file_name\n";
- print " GNUPLOT file name: $gp_file_name Correlation file name: $corr_file_name\n";
- print " Cumulative RT file name: $cumulat_rts_file_name \n Cumulative HA file name: $cumulat_has_file_name\n";
- print " Cluster RT file name: $clust_rts_file_name \n Cluster HA file name: $clust_has_file_name\n";
- print " Cumulative runtimes file name: $cumulat_rts_file_name\n";
- print " Cumulative heap allocations file name $cumulat_has_file_name\n";
- print " Cluster run times file name: $clust_rts_file_name\n";
- print " Cluster heap allocations file name: $clust_has_file_name\n";
- print " PE load file name: $pe_file_name\n";
- print " Site size file name: $sn_file_name\n";
- print "\nBoundaries: \n";
- print " Gran boundaries: @exec_times\n";
- print " Comm boundaries: @comm_percs\n";
- print " Sparked threads boundaries: @sparks\n";
- print " Heap boundaries: @has\n";
- print "\nOther pars: \n";
- print " Left margin: $left_margin Right margin: $right_margin\n";
- print " GP-extension: $ext_size GP xsize: $xsize GP ysize: $ysize\n";
- print " Gray scale: $gray Smart x-tics is " . ($opt_T ? "ON" : "OFF") .
- " Percentage y-axis is " . ($opt_P ? "ON" : "OFF") . "\n";
- print " Log. scaling assoc list: ";
- while (($key,$value) = each %logscale) {
- print "$key: $value, ";
- }
- print "\n";
- print " Active template file: $templ_file\n" if $opt_t;
- print "-" x 70 . "\n";
-}
-
-# ----------------------------------------------------------------------------
-
-sub sort_and_cum {
-
-@sorted_rts = sort {$a <=> $b} @all_rts;
-
-($xstart_cluster_rts,$xend_cluster_rts,$max_cluster_rts,$xtics_cluster_rts) =
- &write_cumulative_data($cumulat_rts_file_name,$clust_rts_file_name,@sorted_rts);
-
-$xend_cum_rts = pop(@sorted_rts);
-$yend_cum_rts = 100;
-$yend_cum0_rts = $#sorted_rts+1; # unpercentified cum graph
-
-open(RTS,">$rts_file_name") || die "$rts_file_name: $!";
-print RTS "Sorted list of all runtimes:\n";
-print RTS join("\n",@sorted_rts);
-close(RTS);
-
-@sorted_has = sort {$a <=> $b} @all_has;
-
-($xstart_cluster_has,$xend_cluster_has,$max_cluster_has,$xtics_cluster_has) =
- &write_cumulative_data($cumulat_has_file_name,$clust_has_file_name,@sorted_has);
-
-$xend_cum_has = pop(@sorted_has);
-$yend_cum_has = 100;
-$yend_cum0_has = $#sorted_has+1; # unpercentified cum graph
-
-open(HAS,">$has_file_name") || die "$has_file_name: $!";
-print HAS "Sorted list of all heap allocations:\n";
-print HAS join("\n",@sorted_has);
-close(HAS);
-
-@sorted_lsps = sort {$a <=> $b} @all_local_sparks;
-
-open(LSPS,">$lsps_file_name") || die "$lsps_file_name: $!";
-print LSPS "Sorted list of all local sparks:\n";
-print LSPS join("\n",@sorted_lsps);
-close(LSPS);
-
-@sorted_gsps = sort {$a <=> $b} @all_global_sparks;
-
-open(GSPS,">$gsps_file_name") || die "$gsps_file_name: $!";
-print GSPS "Sorted list of all global sparks:\n";
-print GSPS join("\n",@sorted_gsps);
-close(GSPS);
-
-@sorted_fts = sort {$a <=> $b} @all_fts;
-
-($xstart_cluster_fts,$xend_cluster_fts,$max_cluster_fts,$xtics_cluster_fts) =
- &write_cumulative_data($cumulat_fts_file_name,$clust_fts_file_name,@sorted_fts);
-
-$xend_cum_fts = pop(@sorted_fts);
-$yend_cum_fts = 100;
-$yend_cum0_fts = $#sorted_fts+1; # unpercentified cum graph
-
-open(FTS,">$fts_file_name") || die "$FTS_file_name: $!";
-print FTS "Sorted list of all communication times:\n";
-print FTS join("\n",@sorted_fts);
-close(FTS);
-
-@sorted_comm_percs = sort {$a <=> $b} @all_comm_percs;
-
-($xstart_cluster_cps,$xend_cluster_cps,$max_cluster_cps,$xtics_cluster_cps) =
- &write_cumulative_data($cumulat_cps_file_name,$clust_cps_file_name,@sorted_comm_percs);
-
-$xend_cum_cps = 100; # pop(@sorted_comm_percs);
-$yend_cum_cps = 100;
-$yend_cum0_cps = $#sorted_comm_percs+1; # unpercentified cum graph
-
-open(CCPS,">$ccps_file_name") || die "$ccps_file_name: $!";
-print CCPS "Sorted list of all communication percentages:\n";
-print CCPS join("\n",@sorted_comm_percs);
-close(CCPS);
-
-($xstart_pe,$xend_pe,$max_pe,$xtics_pe) =
- &write_array($pe_file_name,$#pe_load,@pe_load);
-
-($xstart_sn,$xend_sn,$max_sn,$xtics_sn) =
- &write_array($sn_file_name,$#site_size,@site_size);
-
-if ( $opt_D ) {
- print "After write_array: xstart, xend, max _sn: $xstart_sn,$xend_sn,$max_sn,$xtics_sn\n";
-}
-}
-
-# ----------------------------------------------------------------------------
-# Compute statistical values (like mean, std_dev and especially corr coeff).
-# Write the important info to a file.
-# ----------------------------------------------------------------------------
-
-sub do_statistics {
- local ($n) = @_;
-
- if ( $n <= 1 ) {
- print "Sorry, no statistics for just $n threads\n";
- return -1;
- }
-
-# Compute mean values and std deviations
-# ......................................
-
- ($mean_rt,$std_dev_rt) = &mean_std_dev($sum_rt,@all_rts);
- ($mean_comm_perc,$std_dev_comm_perc) = &mean_std_dev($sum_comm_perc,@all_comm_percs);
- ($mean_spark,$std_dev_spark) = &mean_std_dev($sum_sp,@all_sparks);
- ($mean_local_spark,$std_dev_local_spark) = &mean_std_dev($sum_local_sp,@all_local_sparks);
- ($mean_global_spark,$std_dev_global_spark) = &mean_std_dev($sum_global_sp,@all_global_sparks);
- ($mean_ha,$std_dev_ha) = &mean_std_dev($sum_ha,@all_has);
- ($mean_ft,$std_dev_ft) = &mean_std_dev($sum_ft,@all_fts);
-
-# Compute correlation coefficients
-# ................................
-
- $c_exec_ha = &corr($#all_rts+1,$sum_rt,@all_rts,$sum_ha,@all_has);
- $c_exec_sp = &corr($#all_rts+1,$sum_rt,@all_rts,$sum_sp,@all_sparks);
- $c_exec_lsp = &corr($#all_rts+1,$sum_rt,@all_rts,$sum_local_sp,@all_local_sparks);
- $c_exec_gsp = &corr($#all_rts+1,$sum_rt,@all_rts,$sum_global_sp,@all_global_sparks);
- $c_ha_sp = &corr($#all_has+1,$sum_ha,@all_has,$sum_sp,@all_sparks);
- $c_ha_lsp = &corr($#all_has+1,$sum_ha,@all_has,$sum_local_sp,@all_local_sparks);
- $c_ha_gsp = &corr($#all_has+1,$sum_ha,@all_has,$sum_global_sp,@all_global_sparks);
- $c_exec_ft = &corr($#all_rts+1,$sum_rt,@all_rts,$sum_ft,@all_fts);
- $c_ha_ft = &corr($#all_has+1,$sum_ha,@all_has,$sum_ft,@all_fts);
- $c_lsp_ft = &corr($#all_local_sparks+1,$sum_local_sp,@all_local_sparks,$sum_ft,@all_fts);
- $c_gsp_ft = &corr($#all_global_sparks+1,$sum_global_sp,@all_global_sparks,$sum_ft,@all_fts);
-
-# Write corr coeffs into a file
-# .............................
-
- open(CORR,">$corr_file_name") || die "Couldn't open file $corr_file_name\n";
- #printf CORR ("%f\n%f\n%f\n%f\n%f",$c_exec_ha,$c_exec_lsp,$c_exec_gsp,$c_ha_lsp,$c_ha_gsp) ;
- printf CORR ("CORR of runtime and heap alloc: %f\n",$c_exec_ha);
- printf CORR ("CORR of runtime and no. of sparks: %f\n",$c_exec_sp);
- printf CORR ("CORR of heap alloc and no. sparks: %f\n",$c_ha_sp);
- printf CORR ("CORR of runtime and no. of local sparks: %f\n",$c_exec_lsp);
- printf CORR ("CORR of runtime and no. of global sparks: %f\n",$c_exec_gsp);
- printf CORR ("CORR of heap alloc and no. local sparks: %f\n",$c_ha_lsp);
- printf CORR ("CORR of heap alloc and no. global sparks: %f\n",$c_ha_gsp);
- printf CORR ("CORR of runtime and communication time: %f\n",$c_exec_ft);
- printf CORR ("CORR of heap alloc and communication time: %f\n",$c_ha_ft);
- printf CORR ("CORR of no. of local sparks and communication time: %f\n",$c_lsp_ft);
- printf CORR ("CORR of no. of global sparks and communication time: %f\n",$c_gsp_ft);
- close(CORR);
-
-# These are needed later in the GNUPLOT files
-# ...........................................
-
- $max_rt_class = &list_max(@exec_class);
- $max_rt_global_class = &list_max(@exec_global_class);
- $max_rt_local_class = &list_max(@exec_local_class);
- $max_comm_perc_class = &list_max(@comm_class);
- $max_comm_perc_global_class = &list_max(@comm_global_class);
- $max_comm_perc_local_class = &list_max(@comm_local_class);
- $max_spark_class = &list_max(@spark_class);
- $max_spark_local_class = &list_max(@spark_local_class);
- $max_spark_global_class = &list_max(@spark_global_class);
- $max_ha_class = &list_max(@ha_class);
- $max_ft_class = &list_max(@fetch_class);
-
-}
-
-# ----------------------------------------------------------------------------
-# This is written to STDOUT at the end of the file processing (before
-# gnuplotting and such) if the verbose option is given.
-# ----------------------------------------------------------------------------
-
-sub print_general_info {
-
- printf("\nTotal number of lines: %d\n", $line_no);
-
- print "\nDistribution of execution times: \n";
- print " Intervals: " . join('|',@exec_times) . "\n";
- print " Total: " . join('|',@exec_class) . "\n";
- print " Global: " . join('|',@exec_global_class) . "\n";
- print " Local: " . join('|',@exec_local_class) . "\n";
-
- $total=0; foreach $i (@exec_class) { $total += $i ; }
- $global=0; foreach $i (@exec_global_class) { $global += $i ; }
- $local=0; foreach $i (@exec_local_class) { $local += $i ; }
-
- print " Sum of classes (should be " . $line_no . "): " . $total .
- " (global/local)=(" . $global . "/" . $local . ")\n";
- print " Mean value: $mean_rt Std dev: $std_dev_rt\n";
-
- print "\nPercentage of communication: \n";
- print " Intervals: " . join('|',@comm_percs) . "\n";
- print " Total: " . join('|',@comm_class) . "\n";
- print " Global: " . join('|',@comm_global_class) . "\n";
- print " Local: " . join('|',@comm_local_class) . "\n";
- print " Values outside closed int: Total: " . $outside .
- " Global: " . $outside_global . " Local: " . $outside_local . "\n";
-
- $total=0; foreach $i (@comm_class) { $total += $i ; }
- $global=0; foreach $i (@comm_global_class) { $global += $i ; }
- $local=0; foreach $i (@comm_local_class) { $local += $i ; }
-
- print " Sum of classes (should be " . $line_no . "): " . $total .
- " (global/local)=(" . $global . "/" . $local . ")\n";
- print " Mean value: $mean_comm_perc Std dev: $std_dev_comm_perc\n";
-
- print "\nSparked threads: \n";
- print " Intervals: " . join('|',@sparks) . "\n";
- print " Total allocs: " . join('|',@spark_class) . "\n";
-
- $total=0; foreach $i (@spark_class) { $total += $i ; }
-
- print " Sum of classes (should be " . $line_no . "): " . $total . "\n";
- print " Mean value: $mean_spark Std dev: $std_dev_spark\n";
-
- print "\nHeap Allcoations: \n";
- print " Intervals: " . join('|',@has) . "\n";
- print " Total allocs: " . join('|',@ha_class) . "\n";
-
- $total=0; foreach $i (@ha_class) { $total += $i ; }
-
- print " Sum of classes (should be " . $line_no . "): " . $total . "\n";
- print " Mean value: $mean_ha Std dev: $std_dev_ha\n";
- print "\n";
- print "CORRELATION between runtimes and heap allocations: $c_exec_ha \n";
- print "CORRELATION between runtime and no. of sparks: $c_exec_sp \n";
- print "CORRELATION between heap alloc and no. sparks: $c_ha_sp \n";
- print "CORRELATION between runtimes and locally sparked threads: $c_exec_lsp \n";
- print "CORRELATION between runtimes and globally sparked threads: $c_exec_gsp \n";
- print "CORRELATION between heap allocations and locally sparked threads: $c_ha_lsp \n";
- print "CORRELATION between heap allocations and globally sparked threads: $c_ha_gsp \n";
- print "CORRELATION between runtime and communication time: $c_exec_ft\n";
- print "CORRELATION between heap alloc and communication time: $c_ha_ft\n";
- print "CORRELATION between no. of local sparks and communication time: $c_lsp_ft\n";
- print "CORRELATION between no. of global sparks and communication time: $c_gsp_ft\n";
- print "\n";
-
-}
-
-# ----------------------------------------------------------------------------
-# Old (obsolete) stuff
-# ----------------------------------------------------------------------------
-#
-#for ($index=0;
-# $index <= &list_max($#spark_local_class,$#spark_local_class);
-# $index++) {
-# $spark_class[$index] = $spark_local_class[$index] + $spark_global_class[$index];
-#}
-#
-#for ($index=0, $sum_sp=0;
-# $index <= &list_max($#all_local_sparks,$#all_global_sparks);
-# $index++) {
-# $all_sparks[$index] = $all_local_sparks[$index] + $all_global_sparks[$index];
-# $sum_sp += $all_sparks[$index];
-#}
-#
-# ----------------------------------------------------------------------------
-#
-#sub compute_delta {
-# local (@times) = @_;
-#
-# return ($times[$#times] - $times[$#times-1]);
-#}
-#
-# ----------------------------------------------------------------------------
-
-sub insert_elem {
- local ($elem,$val,$n,*list1,*list2) = @_;
- local (@small_part, $i, $len);
-
- if ( $opt_D ) {
- print "Inserting val $val (with elem $elem) in the following list: \n" .
- @list . "\n yields the lists: \n ";
- }
-
- for ($i=0; $i<=$#list2 && $list2[$i]>$val; $i++) { }
- $len = $#list2 - $i + 1;
- if ( $len == 0 ) {
- push(@list1,$elem);
- push(@list2,$val);
- } else {
- splice(@list1,$i,0,$elem);
- splice(@list2,$i,0,$val);
- }
-
- if ( $opt_D ) {
- print @list1 . "\n and \n" . @list2;
- }
-
-}
-
-# ----------------------------------------------------------------------------
-
-sub skip_header {
- local ($in_header);
-
- $in_header = 9;
- while (<INPUT>) {
- if ( $in_header = 9 ) {
- if (/^=/) {
- $gum_style_gr = 1;
- $in_header = 0;
- $prg = "????"; #
- $pars = "-b??????"; #
- $nPEs = 1; #
- $lat = 1;
- return ($prg, $pars, $nPEs, $lat);
- } else {
- $gum_style_gr = 0;
- $in_header = 1;
- }
-
- }
- $prg = $1, $pars = $2 if /^Granularity Simulation for\s+(\w+)\s+(.*)$/;
- $nPEs = $1 if /^PEs\s+(\d+)/;
- $lat = $1, $fetch = $2 if /^Latency\s+(\d+)[^F]+Fetch\s+(\d+)/;
-
- last if /^\+\+\+\+\+/;
- }
-}
-
-# ----------------------------------------------------------------------------
-
-sub write_pie_chart {
- local ($rt_perc, $bt_perc, $ft_perc, $it_perc);
- local ($title, $title_sz, $label_sz, $x_center, $y_center, $radius);
-
- $PieChart = "/users/fp/hwloidl/grasp/GrAn/bin/PieChart.ps";
-
- $title = "Original Glaswegian Communication Pie (tm)";
- $title_sz = 24;
- $label_sz = 12;
- $x_center = 300;
- $y_center = 400;
- $radius = 100;
-
- open(PIE,">$pie_file_name") || die "$pie_file_name: $!";
-
- print PIE "%!PS-Adobe-2.0\n";
- print PIE "%%Title: Pie Chart\n";
- print PIE "%%Creator: gran-extr\n";
- print PIE "%%CreationDate: Ides of March 44 B.C.\n";
- print PIE "%%EndComments\n";
- print PIE "\n";
- print PIE "% Def of PieChart is taken from:\n";
- print PIE "% ($PieChart) run\n";
- print PIE "\n";
-
- open(PIE_CHART,"<$PieChart") || die "$PieChart: $!";
- while (<PIE_CHART>){
- print PIE $_;
- }
- close (PIE_CHART);
- print PIE "\n";
-
- $rt_perc = $tot_rt / $tot_total_rt;
- $bt_perc = $tot_bt / $tot_total_rt;
- $ft_perc = $tot_ft / $tot_total_rt;
- $it_perc = $tot_it / $tot_total_rt;
-
- print PIE "($title) $title_sz $label_sz % Title, title size and label size\n" .
- "[ % PS Array of (descrition, percentage [0, .., 1])\n" .
- "[(Run Time) $rt_perc]\n" .
- "[(Block Time) $bt_perc]\n" .
- "[(Fetch Time) $ft_perc]\n" .
- "[(Ready Time) $it_perc]\n" .
- "] $x_center $y_center $radius DrawPieChart\n";
- print PIE "showpage\n";
-
- close(PIE);
-}
-
-# ----------------------------------------------------------------------------
-
-sub basename {
- local ($in_str) = @_;
- local ($str,$i) ;
-
- $i = rindex($in_str,"/");
- if ($i == -1) {
- $str = $in_str;
- } else {
- $str = substr($in_str,$i+1) ;
- }
-
- return $str;
-}
-
-# ----------------------------------------------------------------------------
-
-sub dirname {
- local ($in_str) = @_;
- local ($str,$i) ;
-
- $i = rindex($in_str,"/");
- if ($i == -1) {
- $str = "";
- } else {
- $str = substr($in_str,0,$i+1) ;
- }
-
- return $str;
-}
-
-# ----------------------------------------------------------------------------
-
diff --git a/ghc/utils/parallel/grs2gr.pl b/ghc/utils/parallel/grs2gr.pl
deleted file mode 100644
index ab398a53d9..0000000000
--- a/ghc/utils/parallel/grs2gr.pl
+++ /dev/null
@@ -1,48 +0,0 @@
-#!/usr/local/bin/perl
-
-#
-# Convert several .gr files (from the same GUM run) into a single
-# .gr file with all times adjusted relative to the earliest start
-# time.
-#
-
-$count = 0;
-
-foreach $i (@ARGV) {
- open(GR, $i) || die "Can't read $i\n";
- $cmd = <GR>;
- $dateline = <GR>;
- $start = <GR>;
- ($pe, $timestamp) = ($start =~ /PE\s+(\d+) \[(\d+)\]/);
- die "PE $pe too high\n" if $pe > $#ARGV;
- $proc[$count++] = $pe;
- $prog[$pe] = $cmd;
- $time[$pe] = $timestamp;
- close(GR);
-}
-
-$basetime = 0;
-
-for($i = 0; $i < $count; $i++) {
- $pe = $proc[$i];
- die "PE $pe missing?\n" if !defined($time[$pe]);
- die "Mismatched .gr files\n" if $pe > 0 && $prog[$pe] ne $prog[$pe - 1];
- $basetime = $time[$pe] if $basetime == 0 || $basetime > $time[$pe];
-}
-
-print $cmd;
-print $dateline;
-
-for($i = 0; $i < $count; $i++) {
- $pe = $proc[$i];
- $delta = $time[$pe] - $basetime;
- open(GR, $ARGV[$i]) || die "Can't read $ARGV[i]\n";
- $cmd = <GR>;
- $dateline = <GR>;
- $start = <GR>;
- while(<GR>) {
- /PE\s+(\d+) \[(\d+)\]/;
- printf "PE %2u [%lu]%s", $1, $2 + $delta, $';
- }
- close(GR);
-}
diff --git a/ghc/utils/parallel/par-aux.pl b/ghc/utils/parallel/par-aux.pl
deleted file mode 100644
index 8484057aab..0000000000
--- a/ghc/utils/parallel/par-aux.pl
+++ /dev/null
@@ -1,89 +0,0 @@
-#!/usr/local/bin/perl
-##############################################################################
-# Time-stamp: <Sat Oct 28 1995 22:41:09 Stardate: [-31]6509.51 hwloidl>
-#
-# Usage: do ...
-#
-# Various auxiliary Perl subroutines that are mainly used in gran-extr and
-# RTS2gran.
-# This module contains the following `exported' routines:
-# - mk_global_local_names
-# - dat2ps_name
-# The following routines should be local:
-# - basename
-# - dirname
-#
-##############################################################################
-
-# ----------------------------------------------------------------------------
-# Usage: do mk_global_local_names (<file_name>);
-# Returns: (<file_name>,<local_file_name>, <global_file_name>)
-#
-# Take a filename and create names for local and global variants.
-# E.g.: foo.dat -> foo-local.dat and foo-global.dat
-# ----------------------------------------------------------------------------
-
-sub mk_global_local_names {
- local ($file_name) = @_;
-
- $file_name .= ".dat" unless $file_name =~ /\.dat$/;
- $global_file_name = $file_name;
- $global_file_name =~ s/\.dat/\-global\.dat/ ;
- $local_file_name = $file_name;
- $local_file_name =~ s/\.dat/\-local\.dat/ ;
-
- return ( ($file_name, $global_file_name, $local_file_name) );
-}
-
-
-# ----------------------------------------------------------------------------
-# Usage: do dat2ps(<dat_file_name>);
-# Returns: (<ps_file_name>);
-# ----------------------------------------------------------------------------
-
-sub dat2ps_name {
- local ($dat_name) = @_;
-
- $dat_name =~ s/\.dat$/\.ps/;
- return ($dat_name);
-}
-
-# ----------------------------------------------------------------------------
-# ----------------------------------------------------------------------------
-
-sub basename {
- local ($in_str) = @_;
- local ($str,$i) ;
-
- $i = rindex($in_str,"/");
- if ($i == -1) {
- $str = $in_str;
- } else {
- $str = substr($in_str,$i+1) ;
- }
-
- return $str;
-}
-
-# ----------------------------------------------------------------------------
-
-sub dirname {
- local ($in_str) = @_;
- local ($str,$i) ;
-
- $i = rindex($in_str,"/");
- if ($i == -1) {
- $str = "";
- } else {
- $str = substr($in_str,0,$i+1) ;
- }
-
- return $str;
-}
-
-# ----------------------------------------------------------------------------
-
-
-# ----------------------------------------------------------------------------
-
-1;
diff --git a/ghc/utils/parallel/ps-scale-y.pl b/ghc/utils/parallel/ps-scale-y.pl
deleted file mode 100644
index 0e1242081c..0000000000
--- a/ghc/utils/parallel/ps-scale-y.pl
+++ /dev/null
@@ -1,188 +0,0 @@
-#!/usr/local/bin/perl
-##############################################################################
-# Time-stamp: <Wed Jul 24 1996 22:19:02 Stardate: [-31]7859.44 hwloidl>
-#
-# Usage: ps-scale-y [options] <file>
-#
-# It is assumed that the last line of <file> is of the format:
-# %% y_scaling: <f> max: <n>
-# where <f> is a floating point number determining the amount of scaling of
-# the y-axis of the graph that is necessary. <n> is the real maximal number
-# of tasks in the program (needed to rebuild y-axis). This script replaces the
-# definitions of the PostScript functions scale-y and unscale-y in <file> by
-# new definitions that do the right amount of scaling.
-# The y-axis is rebuilt (using the above maximal number of tasks and a copy
-# of the print_y_axis routine from qp2ps).
-# If the above line doesn't exist, <file> is unchanged.
-# This script is typically called from gr2ps.
-#
-##############################################################################
-
-require "getopts.pl";
-
-&Getopts('hv');
-
-do process_options();
-
-$tmpfile = ",t";
-$debug = 0;
-
-# NB: This must be the same as in qp2ps!!
-
-$xmin = 100;
-$xmax = 790;
-
-$scalex = $xmin;
-$labelx = $scalex - 45;
-$markx = $scalex - 30;
-$major = $scalex - 5;
-$majorticks = 10;
-
-$mmax = 1;
-
-$amax = 0;
-$ymin = 50;
-$ymax = 500;
-
-# E
-open (GET_SCALING,"cat $file | tail -1 |") || die "Can't open pipe: $file | tail -1 |\n";
-
-$y_scaling = 1.0;
-
-while (<GET_SCALING>){
- # print STDERR $_;
- if (/^\%\%\s+y_scaling:\s+([0-9\.]+)\s+max:\s+(\d+)/) {
- $y_scaling = $1;
- $pmax = $2;
- $y_translate = 1.0 - $y_scaling;
- }
-}
-close (GET_SCALING);
-
-if ( $y_scaling != 1.0 ) {
- print STDERR "Scaling $file ($y_scaling; $pmax tasks) ...\n" if $opt_v;
- # print STDERR "SCALING NECESSARY: y_scaling = $y_scaling; y_translate = $y_translate !\n";
-} else {
- # No scaling necessary!!
- exit 0;
-}
-
-
-open (IN,"<$file") || die "Can't open file $file\n";
-open (OUT,">$tmpfile") || die "Can't open file $tmpfile\n";
-
-$skip = 0;
-while (<IN>) {
- $skip = 0 if $skip && /^% End Y-Axis.$/;
- next if $skip;
- if (/\/scale\-y/) {
- print OUT "/scale-y { gsave\n" .
- " 0 50 $y_translate mul translate\n" .
- " 1 $y_scaling scale } def\n";
- }
- elsif (/\/unscale\-y/) {
- print OUT "/unscale-y { grestore } def \n";
- } else {
- print OUT $_;
- }
- if (/^% Y-Axis:$/) {
- $skip = 1;
- do print_y_axis();
- }
-}
-
-close (IN);
-close (OUT);
-
-rename($tmpfile,$file);
-
-exit 0;
-
-# ###########################################################################
-# Same as in qp2ps (but printing to OUT)!
-# ###########################################################################
-
-sub print_y_axis {
- local ($i);
- local ($y, $smax,$majormax, $majorint);
-
-# Y-axis label
-
- print OUT "% " . ("-" x 75) . "\n";
- print OUT "% Y-Axis (scaled):\n";
- print OUT "% " . ("-" x 75) . "\n";
-
- print OUT ("%scale-y % y-axis outside scaled area if ps-scale-y rebuilds it!\n");
-
- print OUT ("gsave\n");
- print OUT ("HE12 setfont\n");
- print OUT ("(tasks)\n");
- print OUT ("dup stringwidth pop\n");
- print OUT ("$ymax\n");
- print OUT ("exch sub\n");
- print OUT ("$labelx exch\n");
- print OUT ("translate\n");
- print OUT ("90 rotate\n");
- print OUT ("0 0 moveto\n");
- print OUT ("show\n");
- print OUT ("grestore\n");
-
-# Scale
-
- if ($pmax < $majorticks) {
- $majorticks = $pmax;
- }
-
- print OUT ("HE12 setfont\n$scalex $ymin moveto\n$scalex $ymax lineto\n");
- print OUT ("% Max number of tasks: $pmax\n");
- print OUT ("% Number of ticks: $majorticks\n");
-
- print OUT "0.5 setlinewidth\n";
-
- $y = $ymax; # (($pmax - $ymin)/$majorticks) * ($majorticks-$i) + $ymin;
- print OUT ("$scalex $y moveto\n$major $y lineto\n");
- print OUT ("$markx $y moveto\n($pmax) show\n");
-
- $majormax = int($pmax/$majorticks)*$majorticks;
- $smax = $majormax*(($ymax-$ymin)/$pmax)+$ymin;
- $majorint = $majormax/$majorticks;
-
- for($i=1; $i <= $majorticks; ++$i) {
- $y = (($smax - $ymin)/$majorticks) * ($majorticks-$i) + $ymin;
- $majorval = int($majorint * ($majormax/$majorint-$i));
- print OUT ("$scalex $y moveto\n$major $y lineto\n");
- print OUT ("$markx $y moveto\n($majorval) show\n");
- }
-
- # print OUT ("$xmin $ymax moveto\n10 0 rlineto\n10 0 rmoveto\n($pmax) show\n");
- print OUT " stroke\n";
- print OUT "1 setlinewidth\n";
- print OUT ("%unscale-y\n");
- print OUT ("% End Y-Axis (scaled).\n");
- print OUT "% " . ("-" x 75) . "\n";
-}
-
-# ----------------------------------------------------------------------------
-
-sub process_options {
-
- if ( $opt_h ) {
- open(ME,$0) || die "Can't open myself ($0): $!\n";
- $n = 0;
- while (<ME>) {
- last if $_ =~ /^$/;
- print $_;
- $n++;
- }
- close(ME);
- exit ;
- }
-
- if ( $#ARGV != 0 ) {
- print "Usage: $0 [options] <file>\n";
- print "Use -h option to get details\n";
- exit 1;
- }
-
- $file = $ARGV[0];
-}
diff --git a/ghc/utils/parallel/qp2ap.pl b/ghc/utils/parallel/qp2ap.pl
deleted file mode 100644
index b3c3bcf122..0000000000
--- a/ghc/utils/parallel/qp2ap.pl
+++ /dev/null
@@ -1,495 +0,0 @@
-#! /usr/local/bin/perl
-##############################################################################
-# Time-stamp: <Wed Jul 24 1996 22:05:31 Stardate: [-31]7859.39 hwloidl>
-#
-# Usage: qp2ap [options] <max-x> <max-y> <prg> <date>
-#
-# Filter that transforms a quasi-parallel profile (a .qp file) at stdin to
-# a PostScript file at stdout, showing an activity profile with one horizontal
-# line for each task (thickness of the line shows if it's active or suspended).
-#
-# Options:
-# -o <file> ... write .ps file to <file>
-# -m ... create mono PostScript file instead a color one.
-# -O ... optimise i.e. try to minimise the size of the .ps file.
-# -s <n> ... scaling factor of y axis (default: 1)
-# -w <n> ... width of lines denoting running threads (default: 2)
-# -v ... be talkative.
-# -h ... print help message (this header).
-#
-##############################################################################
-
-
-require "getopts.pl";
-
-&Getopts('hvms:w:OlD');
-
-do process_options();
-
-if ( $opt_v ) {
- do print_verbose_message();
-}
-
-# ---------------------------------------------------------------------------
-# Init
-# ---------------------------------------------------------------------------
-
-$y_scaling = 0;
-$gtid = 1; # number of process so far = $gtid-1
-
-$xmin = 100;
-$xmax = 790;
-
-$scalex = $xmin;
-$labelx = $scalex - 45;
-$markx = $scalex - 30;
-$major = $scalex - 5;
-$majorticks = 10;
-
-# $pmax = 40;
-$ymin = 50;
-$ymax = 500;
-
-if ( ($ymax - $ymin)/$pmax < 3 ) {
- print STDERR "Warning: Too many tasks! Distance will be smaller than 3 pixels.\n";
-}
-
-if ( !$width ) {
- $width = 2/3 * ($ymax - $ymin)/$pmax;
-}
-
-do write_prolog();
-do print_y_axis();
-
-# ---------------------------------------------------------------------------
-# Main Part
-# ---------------------------------------------------------------------------
-
-while(<STDIN>) {
- next if /^[^0-9]/; # ignore lines not beginning with a digit (esp. last)
- chop;
- ($time, $event, $tid, $addr, $tid2, $addr2) = split;
-
- if ( $event eq "*G") {
- $TID{$addr} = $gtid++;
- $START{$addr} = $time;
- }
-
- elsif ($event eq "*A") {
- $TID{$addr} = $gtid++;
- $SUSPEND{$addr} = $time;
- }
-
- elsif ($event eq "G*" || $event eq "GR" ) {
- do psout($START{$addr},$time,$TID{$addr},"runlineto");
-# $STOP{$addr} = $time;
- }
-
- elsif ($event eq "GA" || $event eq "GC" || $event eq "GY") {
- do psout($START{$addr},$time,$TID{$addr},"runlineto");
- $SUSPEND{$addr} = $time;
- }
-
- elsif ($event eq "RA") {
- $SUSPEND{$addr} = $time;
- }
-
- elsif ($event eq "YR") {
- do psout($SUSPEND{$addr},$time,$TID{$addr},"fetchlineto");
- }
-
- elsif ($event eq "CA" || $event eq "YA" ) {
- do psout($SUSPEND{$addr},$time,$TID{$addr},"fetchlineto");
- $SUSPEND{$addr} = $time;
- }
-
- elsif ($event eq "AC" || $event eq "AY" ) {
- do psout($SUSPEND{$addr},$time,$TID{$addr},"suspendlineto");
- $SUSPEND{$addr} = $time;
- }
-
- elsif ($event eq "RG") {
- $START{$addr} = $time;
- }
-
- elsif ($event eq "AG") {
- do psout($SUSPEND{$addr},$time,$TID{$addr},"suspendlineto");
- $START{$addr} = $time;
- }
-
- elsif ($event eq "CG" || $event eq "YG" ) {
- do psout($SUSPEND{$addr},$time,$TID{$addr},"fetchlineto");
- $START{$addr} = $time;
- } elsif ( $event eq "B*" || $event eq "*B" || $event eq "BB" ) {
- print STDERR "Ignoring spark event $event at $time\n" if $opt_v;
- } else {
- print STDERR "Unexpected event $event at $time\n";
- }
-
- print("%% $time: $event $addr $TID{$addr}\n\n") if $opt_D;
-}
-
-# ---------------------------------------------------------------------------
-
-# Logo
-print("HE14 setfont\n");
-if ( $opt_m ) {
- print("50 550 asciilogo\n");
-} else {
- print("50 550 logo\n"); #
-}
-
-# Epilogue
-print("showpage\n");
-
-if ( $gtid-1 != $pmax ) {
- if ( $pedantic ) {
- die "Error: Calculated max no. of tasks ($gtid-1) does not agree with stated max. no. of tasks ($pmax)\n";
- } else {
- print STDERR "Warning: Calculated total no. of tasks ($gtid-1) does not agree with stated total no. of tasks ($pmax)\n" if $opt_v;
- $y_scaling = $pmax/($gtid-1);
- }
-}
-
-
-exit 0;
-
-# ---------------------------------------------------------------------------
-
-sub psout {
- local($x1, $x2, $y, $cmd) = @_;
- print("% ($x1,$y) -- ($x2,$y) $cmd\n") if $opt_D;
- $x1 = int(($x1/$tmax) * ($xmax-$xmin) + $xmin);
- $x2 = int(($x2/$tmax) * ($xmax-$xmin) + $xmin);
- $y = int(($y/$pmax) * ($ymax-$ymin) + $ymin);
- if ( $x1 == $x2 ) {
- $x2 = $x1 + 1;
- }
-
- if ( $opt_l ) {
- print("newpath\n");
- print("$x1 $y moveto\n");
- print("$x2 $y $cmd\n");
- print("stroke\n");
- } elsif ( $opt_O ) {
- print "$x1 $x2 $y " .
- ( $cmd eq "runlineto" ? "G RL\n" :
- $cmd eq "suspendlineto" ? "R SL\n" :
- $cmd eq "fetchlineto" ? "B FL\n" :
- "\n% ERROR: Unknown command $cmd\n");
-
- } else {
- print "$x2 $y $x1 $y " .
- ( $cmd eq "runlineto" ? "green run\n" :
- $cmd eq "suspendlineto" ? "red suspend\n" :
- $cmd eq "fetchlineto" ? "blue fetch\n" :
- "\n% ERROR: Unknown command $cmd\n");
- }
-}
-
-# -----------------------------------------------------------------------------
-
-sub get_date {
- local ($date);
-
- chop($date = `date`);
- return ($date);
-}
-
-# -----------------------------------------------------------------------------
-
-sub write_prolog {
- local ($now);
-
- $now = do get_date();
-
- print("%!PS-Adobe-2.0\n");
- print("%%BoundingBox: 0 0 560 800\n");
- print("%%Title: Per-thread Activity Profile\n");
- print("%%Creator: qp2ap\n");
- print("%%StartTime: $date\n");
- print("%%CreationDate: $now\n");
- print("%%Copyright: 1995, 1996 by Hans-Wolfgang Loidl, University of Glasgow\n");
- print("%%EndComments\n");
-
- print "% " . "-" x 77 . "\n";
- print "% Tunable Parameters:\n";
- print "% The width of a line representing a task\n";
- print "/width $width def\n";
- print "% Scaling factor for the y-axis (usful to enlarge)\n";
- print "/y-scale $y_scale def\n";
- print "% " . "-" x 77 . "\n";
-
- print "/total-len $tmax def\n";
- print "/show-len $xmax def\n";
- print "/x-offset $xmin def\n";
- print "/y-offset $ymin def\n";
- print "% normalize is the PS version of the formula: \n" .
- "% int(($x1/$tmax) * ($xmax-$xmin) + $xmin) \n" .
- "% in psout.\n";
- print "/normalize { total-len div show-len x-offset sub mul x-offset add floor } def\n";
- print "/x-normalize { exch show-len mul total-len div exch } def\n";
- print "/y-normalize { y-offset sub y-scale mul y-offset add } def\n";
- print "/str-len 12 def\n";
- print "/prt-n { cvi str-len string cvs \n" .
- " dup stringwidth pop \n" .
- " currentpoint pop 780 gt { 10 sub } { 2 div } ifelse \n" .
- " neg 0 rmoveto \n" .
- " show } def \n" .
- " % print top-of-stack integer centered at the current point\n";
- # print "/prt-n { cvi str-len string cvs \n" .
- # " dup stringwidth pop 2 div neg 0 rmoveto \n" .
- # " show } def \n" .
- # " % print top-of-stack integer centered at the current point\n";
-
- if ( $opt_l ) {
- print ("/runlineto {1.5 setlinewidth lineto} def\n");
- print ("/suspendlineto {0.5 setlinewidth lineto} def\n");
- print ("/fetchlineto {0.2 setlinewidth lineto} def\n");
- } else {
- if ( $opt_m ) {
- if ( $opt_O ) {
- print "/R { 0 } def\n";
- print "/G { 0.5 } def\n";
- print "/B { 0.2 } def\n";
- } else {
- print "/red { 0 } def\n";
- print "/green { 0.5 } def\n";
- print "/blue { 0.2 } def\n";
- }
- print "/set-bg { setgray } def\n";
- } else {
- if ( $opt_O ) {
- print "/R { 0.8 0 0 } def\n";
- print "/G { 0 0.9 0.1 } def\n";
- print "/B { 0 0.1 0.9 } def\n";
- print "/set-bg { setrgbcolor } def\n";
- } else {
- print "/red { 0.8 0 0 } def\n";
- print "/green { 0 0.9 0.1 } def\n";
- print "/blue { 0 0.1 0.9 } def\n";
- print "/set-bg { setrgbcolor } def\n";
- }
- }
-
- if ( $opt_O ) {
- print "% RL: runlineto; draws a horizontal line in given color\n";
- print "% Operands: x-from x-to y color\n";
- print "/RL { set-bg % set color \n" .
- " newpath y-normalize % mangle y val\n" .
- " 2 index 1 index moveto width setlinewidth \n" .
- " lineto pop stroke} def\n";
- print "% SL: suspendlineto; draws a horizontal line in given color (thinner)\n";
- print "% Operands: x-from x-to y color\n";
- print "/SL { set-bg % set color \n" .
- " newpath y-normalize % mangle y val\n" .
- " 2 index 1 index moveto width 2 div setlinewidth \n" .
- " lineto pop stroke} def\n";
- print "% FL: fetchlineto; draws a horizontal line in given color (thinner)\n";
- print "% Operands: x-from x-to y color\n";
- print "/FL { set-bg % set color \n" .
- " newpath y-normalize % mangle y val\n" .
- " 2 index 1 index moveto width " .
- ( $opt_m ? " 4 " : " 2 ") .
- " div setlinewidth \n" .
- " lineto pop stroke} def\n";
- } else {
- print "/run { set-bg newpath 50 sub y-scale mul 50 add moveto width " .
- "setlinewidth 50 sub y-scale mul 50 add lineto stroke} def\n";
- print "/suspend { set-bg newpath 50 sub y-scale mul 50 add moveto width " .
- "2 div setlinewidth 50 sub y-scale mul 50 add lineto stroke} def\n";
- print "/fetch { set-bg newpath 50 sub y-scale mul 50 add moveto width " .
- ( $opt_m ? " 4 " : " 2 ") .
- "div setlinewidth 50 sub y-scale mul 50 add lineto stroke} def\n";
- #print ("/run { newpath moveto 1.5 setlinewidth lineto stroke} def\n");
- #print ("/suspend { newpath moveto 0.5 setlinewidth lineto stroke} def\n");
- }
- }
-
- print "/printText { 0 0 moveto (GrAnSim) show } def\n";
- print "/asciilogo { 5 sub moveto HB16 setfont (GrAnSim) show } def\n";
- if ( $opt_m ) {
- print "/logo { asciilogo } def\n";
- } else {
- print "/logo { gsave \n" .
- " translate \n" .
- " .95 -.05 0\n" .
- " { dup 1 exch sub 0 exch setrgbcolor printText 1 -.5 translate } for \n" .
- " 1 0 0 setrgbcolor printText\n" .
- " grestore} def\n";
- }
- print "% For debugging PS uncomment this line and add the file behandler.ps\n";
- print "% $brkpage begin printonly endprint \n";
-
- print("/HE10 /Helvetica findfont 10 scalefont def\n");
- print("/HE12 /Helvetica findfont 12 scalefont def\n");
- print("/HE14 /Helvetica findfont 14 scalefont def\n");
- print("/HB16 /Helvetica-Bold findfont 16 scalefont def\n");
- print "% " . "-" x 77 . "\n";
- print("newpath\n");
-
- print("-90 rotate\n");
- print("-785 30 translate\n");
- print("0 8.000000 moveto\n");
- print("0 525.000000 760.000000 525.000000 8.000000 arcto\n");
- print("4 {pop} repeat\n");
- print("760.000000 525.000000 760.000000 0 8.000000 arcto\n");
- print("4 {pop} repeat\n");
- print("760.000000 0 0 0 8.000000 arcto\n");
- print("4 {pop} repeat\n");
- print("0 0 0 525.000000 8.000000 arcto\n");
- print("4 {pop} repeat\n");
- print("0.500000 setlinewidth\n");
- print("stroke\n");
- print("newpath\n");
- print("4.000000 505.000000 moveto\n");
- print("4.000000 521.000000 752.000000 521.000000 4.000000 arcto\n");
- print("4 {pop} repeat\n");
- print("752.000000 521.000000 752.000000 501.000000 4.000000 arcto\n");
- print("4 {pop} repeat\n");
- print("752.000000 501.000000 4.000000 501.000000 4.000000 arcto\n");
- print("4 {pop} repeat\n");
- print("4.000000 501.000000 4.000000 521.000000 4.000000 arcto\n");
- print("4 {pop} repeat\n");
- print("0.500000 setlinewidth\n");
- print("stroke\n");
-
- print("HE14 setfont\n");
- print("100 505 moveto\n");
- print("($pname ) show\n");
-
- print("($date) dup stringwidth pop 750 exch sub 505.000000 moveto show\n");
-
- # print "/total-len $tmax def\n";
- print("-40 -40 translate\n");
-
- print "% " . "-" x 77 . "\n";
- print "% Print x-axis:\n";
- print "/y-val $ymin def % { y-offset 40 sub 2 div y-offset add } def\n";
- print "0.5 setlinewidth\n";
- print "x-offset y-val moveto total-len normalize x-offset sub 0 rlineto stroke\n";
- print "0 total-len 10 div total-len\n" .
- " { dup normalize dup y-val moveto 0 -2 rlineto stroke % tic\n" .
- " y-val 10 sub moveto HE10 setfont round prt-n % print label \n" .
- " } for \n";
- print "1 setlinewidth\n";
- print "% " . "-" x 77 . "\n";
-
-}
-
-# -----------------------------------------------------------------------------
-
-sub print_y_axis {
- local ($i);
- local ($y, $smax,$majormax, $majorint);
-
-# Y-axis label
-
- print "% " . ("-" x 75) . "\n";
- print "% Y-Axis:\n";
- print "% " . ("-" x 75) . "\n";
-
- if ( $opt_m ) {
- print "0 setgray\n";
- } else {
- print "0 0 0 setrgbcolor\n";
- }
-
- print("gsave\n");
- print("HE12 setfont\n");
- print("(tasks)\n");
- print("dup stringwidth pop\n");
- print("$ymax\n");
- print("exch sub\n");
- print("$labelx exch\n");
- print("translate\n");
- print("90 rotate\n");
- print("0 0 moveto\n");
- print("show\n");
- print("grestore\n");
-
-# Scale
-
- if ($pmax < $majorticks) {
- $majorticks = $pmax;
- }
-
- print "0.5 setlinewidth\n";
-
- print("HE12 setfont\n$scalex $ymin moveto\n$scalex $ymax lineto\n");
- print("% Total number of tasks: $pmax\n");
- print("% Number of ticks: $majorticks\n");
-
- $y = $ymax; # (($pmax - $ymin)/$majorticks) * ($majorticks-$i) + $ymin;
- print("$scalex $y moveto\n$major $y lineto\n");
- print("$markx $y moveto\n($pmax) show\n");
-
- $majormax = int($pmax/$majorticks)*$majorticks;
- $smax = $majormax*(($ymax-$ymin)/$pmax)+$ymin;
- $majorint = $majormax/$majorticks;
-
- for($i=0; $i <= $majorticks; ++$i) {
- $y = (($smax - $ymin)/$majorticks) * ($majorticks-$i) + $ymin;
- $majorval = int($majorint * ($majormax/$majorint-$i));
- print("$scalex $y moveto\n$major $y lineto\n");
- print("$markx $y moveto\n($majorval) show\n");
- }
-
- # print("$xmin $ymax moveto\n10 0 rlineto\n10 0 rmoveto\n($pmax) show\n");
- print " stroke\n";
- print "1 setlinewidth\n";
- print "% " . ("-" x 75) . "\n";
-}
-
-# ---------------------------------------------------------------------------
-
-sub print_verbose_message {
-
- print "Prg Name: $pname Date: $date\n";
- print "Input: stdin Output: stdout\n";
-}
-
-# ----------------------------------------------------------------------------
-
-sub process_options {
-
- if ( $opt_h ) {
- open(ME,$0) || die "Can't open myself ($0): $!\n";
- $n = 0;
- while (<ME>) {
- last if $_ =~ /^$/;
- print $_;
- $n++;
- }
- close(ME);
- exit ;
- }
-
- if ( $opt_s ) {
- $y_scale = $opt_s;
- } else {
- $y_scale = 1;
- }
-
- if ( $#ARGV != 3 ) {
- print "Usage: $0 [options] <max x value> <max y value> <prg name> <date> \n";
- print "Use -h option to get details\n";
- exit 1;
- }
-
- $tmax = $ARGV[0];
- $pmax = $ARGV[1];
- # GUM uses the absolute path (with '=' instead of '/') of the executed file
- # (for PVM reasons); if you want to have the full path in the generated
- # graph, too, eliminate the substitution below
- ($pname = $ARGV[2]) =~ s/.*=//;
- $date = $ARGV[3];
-
- if ( $opt_w ) {
- $width = $opt_w;
- } else {
- $width = 0;
- }
-
-}
-# -----------------------------------------------------------------------------
diff --git a/ghc/utils/parallel/qp2ps.pl b/ghc/utils/parallel/qp2ps.pl
deleted file mode 100644
index 2fb090346a..0000000000
--- a/ghc/utils/parallel/qp2ps.pl
+++ /dev/null
@@ -1,988 +0,0 @@
-#! /usr/local/bin/perl
-##############################################################################
-# Time-stamp: <Wed Jul 24 1996 22:04:50 Stardate: [-31]7859.39 hwloidl>
-#
-# Usage: qp2ps [options] <max-x> <max-y> <prg> <date>
-#
-# Filter that transforms a quasi-parallel profile (a .qp file) at stdin to
-# a PostScript file at stdout, showing essentially the total number of running,
-# runnable and blocked tasks.
-#
-# Options:
-# -o <file> ... write .ps file to <file>
-# -m ... create mono PostScript file instead a color one.
-# -O ... compress i.e. try to minimize the size of the .ps file
-# -s <str> ... print <str> in the top right corner of the generated graph
-# -i <int> ... info level from 1 to 7; number of queues to display
-# -I <str> ... queues to be displayed (in the given order) with the encoding
-# 'a' ... active (running)
-# 'r' ... runnable
-# 'b' ... blocked
-# 'f' ... fetching
-# 'm' ... migrating
-# 's' ... sparks
-# (e.g. -I "arb" shows active, runnable, blocked tasks)
-# -l <int> ... length of a slice in the .ps file; (default: 100)
-# small value => less memory consumption of .ps file & script
-# but slower in generating the .ps file
-# -d ... Print date instead of average parallelism
-# -v ... be talkative.
-# -h ... print help message (this header).
-#
-##############################################################################
-
-require "getopts.pl";
-
-&Getopts('hvDCOmdl:s:i:I:H');
-
-do process_options();
-
-if ( $opt_v ) {
- do print_verbose_message();
-}
-
-# ---------------------------------------------------------------------------
-# Init
-# ---------------------------------------------------------------------------
-
-$y_scaling = 1.0;
-
-$xmin = 100;
-$xmax = 790;
-
-$scalex = $xmin;
-$labelx = $scalex - 45;
-$markx = $scalex - 30;
-$major = $scalex - 5;
-$majorticks = 10;
-
-$mmax = 1;
-
-$amax = 0;
-$ymin = 50;
-$ymax = 500;
-
-$active = 0;
-$runnable = 0;
-$blocked = 0;
-$fetching = 0;
-$migrating = 0;
-$sparks = 0;
-
-#$lines_per_flush = 100; # depends on the PS implementation you use
-
-%color = ( "a", "green", # active
- "r", "amber", # runnable
- "b", "red", # blocked
- "f", "cyan", # fetching
- "m", "blue", # migrating
- "s", "crimson" ); # sparks
-
-# ---------------------------------------------------------------------------
-
-do print_prolog();
-
-$otime = -1;
-$time_of_second_event = 0;
-$samples = 0;
-
-$T[0] = 0;
-$G[0] = 0;
-$A[0] = 0;
-$R[0] = 0;
-$B[0] = 0;
-$Y[0] = 0;
-
-while(<STDIN>) {
- next if /^[^0-9]/; # ignore lines not beginning with a digit (esp. last)
- chop;
- ($time, $event, $tid, $addr, $tid2, $addr2) = split;
- $time_of_second_event = $time if $time_of_second_event == 0;
-
- if($time != $otime) {
- $tottime += $G[$samples] * ($time-$T[$samples]);
- $otime = $time;
- }
-
- if($active > $amax) {
- $amax = $active;
- }
-
- if ( $opt_D ) {
- if($G[$samples] < $amax && $A[$samples] > 0) {
- printf(stderr "%% $otime: G $G[$samples], A $A[$samples], " .
- "R $R[$samples], B $B[$samples], " .
- "Y $Y[$samples]\n");
- }
- }
-
- # Reality Check
- if($G[$samples] < 0 || $A[$samples] < 0 ||
- $R[$samples] < 0 || $B[$samples] < 0 ||
- $Y[$samples] < 0) {
- printf(stderr "Error: Impossible number of tasks at time " .
- "$T[$samples] (G $G[$samples], A $A[$samples], ".
- "R $R[$samples], B $B[$samples], Y $Y[$samples])\n") if $opt_v || $opt_D;
- if ( $opt_H ) { # HACK
- $G[$samples] = 0 if $G[$samples] < 0;
- $A[$samples] = 0 if $A[$samples] < 0;
- $R[$samples] = 0 if $R[$samples] < 0;
- $B[$samples] = 0 if $B[$samples] < 0;
- $Y[$samples] = 0 if $Y[$samples] < 0;
- }
- }
- $samples++;
-
- $eventfrom = substr($event,0,1);
- $eventto = substr($event,1,1);
-
- printf(stderr "$time $event $eventfrom $eventto\n") if 0 && $opt_D;
-
- if ($eventfrom eq '*') {
- }
-
- elsif ($eventfrom eq 'G') {
- --$active;
- }
-
- elsif ($eventfrom eq 'A') {
- --$runnable;
- }
-
- elsif ($eventfrom eq 'R') {
- --$blocked;
- }
-
- elsif ($eventfrom eq 'B') {
- --$sparks;
- }
-
- elsif ($eventfrom eq 'C') {
- --$migrating;
- }
-
- elsif ($eventfrom eq 'Y') {
- --$fetching;
- }
-
- if ($eventto eq '*') {
- }
-
- elsif ($eventto eq 'G') {
- ++$active;
- }
-
- elsif ($eventto eq 'A') {
- ++$runnable;
- $somerunnable = 1;
- }
-
- elsif ($eventto eq 'R') {
- ++$blocked;
- $someblocked = 1;
- }
-
- elsif ($eventto eq 'B') {
- ++$sparks;
- $somesparks = 1;
- }
-
- elsif ($eventto eq 'C') {
- ++$migrating;
- $somemigratory = 1;
- }
-
- elsif ($eventto eq 'Y') {
- ++$fetching;
- $somefetching = 1;
- }
-
-
- #printf(stderr "%% $time: G $active, A $runnable, R $blocked, " .
- # "B $sparks, C $migrating\n") if 1;
-
- printf(stderr "Error: Trying to write at index 0!\n") if $samples == 0;
- $T[$samples] = $time;
- do set_values($samples,
- $active,$runnable,$blocked,$fetching,$sparks,$migrating);
-
- #$G[$samples] = queue_on_a ? $active : 0;
- #$A[$samples] = queue_on_r ? $runnable : 0;
- #$R[$samples] = queue_on_b ? $blocked : 0;
- #$Y[$samples] = queue_on_f ? $fetching : 0;
- #$B[$samples] = queue_on_s ? $sparks : 0;
- #$C[$samples] = queue_on_m ? $migrating : 0;
-
- $all = $G[$samples] + $A[$samples] + $R[$samples] + $Y[$samples] +
- $B[$samples] + $C[$samples] ;
-
- if($all > $mmax) {
- $mmax = $all;
- }
-
- if ( 0 ) {
- print STDERR "%% $time: (act,runnable,blocked,fetch,mig,sp) = " .
- "($active, $runnable, $blocked, $fetching, $migrating, $sparks)".
- " max = $all\n" ;
- }
-
- #print STDERR "Sparks @ $time: $sparks \tAll: $all \tMMax: $mmax\n" if $opt_D;
-
- if ( $samples >= $slice_width ) {
- do flush_queues();
- $samples = 0;
- }
-
-} # <STDIN>
-
-do flush_queues();
-print "%% End\n" if $opt_C;
-
-# For debugging only
-if ($opt_D) {
- printf(stderr "Queue values after last event: " .
- "$T[$samples] (G $G[$samples], A $A[$samples], ".
- "R $R[$samples], B $B[$samples], Y $Y[$samples])\n");
-}
-
-if($time != $tmax) {
- if ( $pedantic ) {
- die "Error: Calculated time ($time) does not agree with stated max. time ($tmax)\n";
- } else { #
- print STDERR "Warning: Calculated time ($time) does not agree with stated max. time ($tmax)\n" if $opt_v;
- }
-}
-
-# HACK warning:
-# The real max-y value ($mmax) might differ from the one that is the input
-# to this script ($pmax). If so, we post-process the generated ps-file
-# and place an appropriate scaling fct into the header of the ps-file.
-# This is done by yet another perl-script:
-# ps-scale-y <y-scaling-factor> <ps-file>
-
-if($pmax != $mmax) {
- if ( $pedantic ) {
- die "Error: Calculated max no. of tasks ($mmax) does not agree with stated max. no. of tasks ($pmax)\n";
- } else {
- print STDERR "Warning: Calculated max no. of tasks ($mmax) does not agree with stated max. no. of tasks ($pmax)\n" if $opt_v;
- $y_scaling = $pmax/$mmax; #((float) $pmax)/((float) $mmax);
- }
-}
-
-print "% " . ("-" x 75) . "\n";
-
-if ( $opt_m ) {
- print "0 setgray\n";
-} else {
- print "0 0 0 setrgbcolor\n";
-}
-
-# Print optional str
- if ( $opt_s ) {
- print("HB16 setfont ($opt_s) dup stringwidth pop 790 exch sub 500 moveto show\n");
- }
-
- print("unscale-y\n");
-
-# Average Parallelism
-if($time > 0) {
- if ( $opt_S ) { # HACK warning; is this *always* correct -- HWL
- $avg = ($tottime-$time_of_second_event)/($time-$time_of_second_event);
- } else {
- $avg = $tottime/$time;
- }
- if ( $opt_d ) { # Print date instead of average parallelism
- print("HE14 setfont ($date) dup stringwidth pop 790 exch sub 515 moveto show\n");
- } else {
- $avgs=sprintf("Average Parallelism = %0.1f\n",$avg);
- print("HE14 setfont ($avgs) dup stringwidth pop 790 exch sub 515 moveto show\n");
- }
- $rt_str=sprintf("Runtime = %0.0f\n",$tmax);
- print("HE14 setfont ($rt_str) dup stringwidth pop 790 exch sub 20 moveto show\n");
-}
-
-# do print_y_axis();
-
-# -----------------------------------------------------------------------------
-# Draw axes lines etc
-# -----------------------------------------------------------------------------
-
-if ( ! $opt_S ) {
-
-# Draw dashed line for orientation (startup time) -- HWL
-
-if ( $draw_lines ) {
- local($x, $y);
- $x = int((500000/$tmax) * ($xmax-$xmin) + $xmin);
- $y = int((0/$pmax) * ($ymax-$ymin) + $ymin);
- $h = ($ymax-$ymin);
-
- print "gsave\n" .
- "[1 3] 1 setdash\n" .
- "$x $y moveto 0 $h rlineto stroke\n" .
- "grestore\n";
-}
-
-# and another one at the second event -- HWL
-
-print STDERR "Time of second event is: $time_of_second_event" if 0 && $opt_D;
-
-if ( $draw_lines ) {
- local($x, $y);
- $x = int(($time_of_second_event/$tmax) * ($xmax-$xmin) + $xmin);
- $y = int((0/$pmax) * ($ymax-$ymin) + $ymin);
- $h = ($ymax-$ymin);
-
- print "gsave\n";
- if ( ! $opt_m ) {
- print "green setrgbcolor\n";
- }
- print "[3 5] 1 setdash\n" .
- "$x $y moveto 0 $h rlineto stroke\n" .
- "grestore\n";
-}
-
-}
-
-# -----------------------------------------------------------------------------
-
-# Logo
-print("HE14 setfont\n");
-if ($opt_m) {
- print("50 520 asciilogo\n");
-} else {
- print("50 520 logo\n");
-}
-
-# Epilogue
-print("showpage\n");
-
-if ( $y_scaling != 1.0 ) {
- print "%% y_scaling: $y_scaling\t max: $mmax\n";
-}
-
-exit 0 ;
-
-# +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-# -----------------------------------------------------------------------------
-# Draw the current slice of the overall graph.
-# This routine is called if a slice of data is full (i.e. $T[0..$samples],
-# $G[0..$slice_width] etc with $samples==$slice_width contain data from the
-# input file) or if the end of the input has been reached (i.e. $samples<=
-# $slice_width). Note that the last value of the current slice is stored as
-# the first value for the next slice.
-# -----------------------------------------------------------------------------
-
-sub flush_queues {
- local ($x_norm, $y_norm);
- local ($index);
- local ($last_x, $last_y, $in_seq) = (-1, -1, 0);
- local ($foo_x, $foo_y);
-
- if ( $samples == 0 ) { return ; }
-
- # print "% First sample: T $T[0] (G $G[0], A $A[0], ".
- # " R $R[0], B $B[0], Y $Y[0])\n" if $opt_C;
-
- $rshow = reverse($show);
- print STDERR "\nReversed info-mask is : $rshow" if 0 && $opt_D;
- print STDERR "\nMaximal y value is $pmax" if 0 && $opt_D;
- for ($j=0; $j<length($rshow); $j++) {
- $q = substr($rshow,$j,1);
- # print "% Queue = $q i.e. " . ($color{$q}) . " counts at first sample: " . &count($q,0) ."\n" if $opt_C;
- do init_psout($q, $T[0], &count($q,0));
- for($i=1; $i <= $samples; $i++) {
- do psout($T[$i],&count($q,$i));
- }
- print $color{$q} . " F\n";
- ($foo_x, $foo_y) = &normalize($T[$samples],&count($q,$samples));
- print "%% Last " . ($color{$q}) . " is " . &get_queue_val($q,$samples) ." (" . $T[$samples] . ", " . &count($q,$samples) . ") -> ($foo_x,$foo_y)\n" if $opt_C;
- # print($color{$q} . " flush-it\n");
- # print("$xmax $ymin L\n");
- }
- do wrap($samples);
-
- #print "% Last sample T $T[$samples] (G $G[$samples], A $A[$samples], ".
- # " R $R[$samples], B $B[$samples], Y $Y[$samples])\n" if $opt_C;
-}
-
-# -----------------------------------------------------------------------------
-# Scale the (x,y) point (x is time in cycles, y is no. of tasks) s.t. the
-# x-(time-) axis fits between $xmin and $xmax (range for .ps graph).
-# In case of optimization ($opt_O):
-# If there is a sequence of (x,y) pairs with same x value, then just
-# print the first and the last pair in the seqence. To do that, $last_x
-# always contains the scaled x-val of the last point. $last_y contains
-# the y-val of the last point in the current sequence (it is 0 outside a
-# sequence!).
-# -----------------------------------------------------------------------------
-
-sub normalize {
- local($x, $y ) = @_;
- local($x_norm, $y_norm );
-
- if ( $opt_S ) {
- $x_norm = int(( ($x-$time_of_second_event)/($tmax-$time_of_second_event)) * ($xmax-$xmin) + $xmin);
- } else {
- $x_norm = int(($x/$tmax) * ($xmax-$xmin) + $xmin);
- }
- $y_norm = int(($y/$pmax) * ($ymax-$ymin) + $ymin);
-
- return (($x_norm, $y_norm));
-}
-
-# -----------------------------------------------------------------------------
-
-sub init_psout {
- local ($q, $x, $y) = @_;
- local ($x_norm, $y_norm);
-
- ($last_x, $last_y, $in_seq) = (-1, -1, 0);
- ($x_norm, $y_norm) = &normalize($T[0],&count($q,0));
- $last_x = $x_norm;
- $last_y = $y_norm;
- print "%% Begin " . ($color{$q}) . " (" . $T[0] . ", " . &count($q,0) . ") -> ($x_norm,$y_norm)\n" if $opt_C;
- print $x_norm, " ", $y_norm, " M\n";
-
-}
-
-# ----------------------------------------------------------------------------
-
-sub psout {
- local($x_in, $y_in ) = @_;
- local($x, $y );
-
- ($x, $y) = &normalize($x_in, $y_in);
- die "Error in psout: Neg x coordinate\n" if ($x < 0) ;
-
- if ( $opt_O ) {
- if ( $last_x == $x ) { # If seq before $x that then print last pt
- if ( ! $in_seq ) {
- $in_seq = 1;
- $first_y = $last_y;
- }
- } else { # If seq with same $x val then ignore pts
- if ( $in_seq ) { # Seq before that -> print last in seq
- print("$last_x $last_y L\n") if ($first_y != $last_y);
- $in_seq = 0;
- }
- print("$x $y L\n");
- }
- $last_x = $x;
- $last_y = $y;
- } else {
- print("$x $y L\n");
- }
-}
-
-# -----------------------------------------------------------------------------
-
-sub queue_on {
- local ($queue) = @_;
-
- return index($show,$queue)+1;
-}
-
-# -----------------------------------------------------------------------------
-
-sub count {
- local ($queue,$index) = @_;
- local ($res);
-
- $where = &queue_on($queue);
- $res = (($queue_on_a && ($queue_on_a<=$where)) ? $G[$index] : 0) +
- (($queue_on_r && ($queue_on_r<=$where)) ? $A[$index] : 0) +
- (($queue_on_b && ($queue_on_b<=$where)) ? $R[$index] : 0) +
- (($queue_on_f && ($queue_on_f<=$where)) ? $Y[$index] : 0) +
- (($queue_on_m && ($queue_on_m<=$where)) ? $C[$index] : 0) +
- (($queue_on_s && ($queue_on_s<=$where)) ? $B[$index] : 0);
-
- return $res;
-}
-
-# -----------------------------------------------------------------------------
-
-sub set_values {
- local ($samples,
- $active,$runnable,$blocked,$fetching,$sparks,$migrating) = @_;
-
- $G[$samples] = $queue_on_a ? $active : 0;
- $A[$samples] = $queue_on_r ? $runnable : 0;
- $R[$samples] = $queue_on_b ? $blocked : 0;
- $Y[$samples] = $queue_on_f ? $fetching : 0;
- $B[$samples] = $queue_on_s ? $sparks : 0;
- $C[$samples] = $queue_on_m ? $migrating : 0;
-}
-
-# -----------------------------------------------------------------------------
-
-sub set_queue_val {
- local ($queue,$index,$val) = @_;
-
- if ( $queue == "a" ) { $G[$index] = $val; }
- elsif ( $queue == "r" ) { $A[$index] = $val; }
- elsif ( $queue == "b" ) { $R[$index] = $val; }
- elsif ( $queue == "f" ) { $Y[$index] = $val; }
- elsif ( $queue == "m" ) { $C[$index] = $val; }
- elsif ( $queue == "s" ) { $B[$index] = $val; }
-}
-
-# -----------------------------------------------------------------------------
-
-sub wrap { # used in flush_queues at the end of a slice
- local ($index) = @_;
-
- $T[0] = $T[$index];
-
- $G[0] = $G[$index];
- $A[0] = $A[$index];
- $R[0] = $R[$index];
- $Y[0] = $Y[$index];
- $B[0] = $B[$index];
- $C[0] = $C[$index];
-}
-
-# -----------------------------------------------------------------------------
-
-sub get_queue_val {
- local ($queue,$index) = @_;
-
- if ( $queue == "a" ) { return $G[$index]; }
- elsif ( $queue == "r" ) { return $A[$index]; }
- elsif ( $queue == "b" ) { return $R[$index]; }
- elsif ( $queue == "f" ) { return $Y[$index]; }
- elsif ( $queue == "m" ) { return $C[$index]; }
- elsif ( $queue == "s" ) { return $B[$index]; }
-}
-
-# -----------------------------------------------------------------------------
-
-sub get_date {
- local ($date);
-
- chop($date = `date`);
- return ($date);
-}
-
-# -----------------------------------------------------------------------------
-
-sub print_prolog {
- local ($now);
-
- $now = do get_date();
-
- print("%!PS-Adobe-2.0\n");
- print("%%BoundingBox: 0 0 560 800\n");
- print("%%Title: Activity Profile\n");
- print("%%Creator: qp2ps\n");
- print("%%StartTime: $date\n");
- print("%%CreationDate: $now\n");
- print("%%Copyright: 1995, 1996 by Hans-Wolfgang Loidl, University of Glasgow\n");
- print("%%EndComments\n");
- #print ("/greenlineto {1.0 setlinewidth lineto} def\n");
- #print ("/amberlineto {0.5 setlinewidth lineto} def\n");
- #print ("/redlineto {1.5 setlinewidth lineto} def\n");
- #print ("/G {newpath moveto greenlineto stroke} def\n");
- #print ("/A {newpath moveto amberlineto stroke} def\n");
- #print ("/R {newpath moveto redlineto stroke} def\n");
-
- if ( $opt_m ) {
- print "/red { 0 } def\n";
- print "/green { 0.5 } def\n";
- print "/blue { 0.7 } def\n";
- print "/crimson { 0.8 } def\n";
- print "/amber { 0.9 } def\n";
- print "/cyan { 0.3 } def\n";
- } else {
- print "/red { 0.8 0 0 } def\n";
- print "/green { 0 0.9 0.1 } def\n";
- print "/blue { 0 0.1 0.9 } def\n";
- print "/crimson { 0.7 0.5 0 } def\n";
- print "/amber { 0.9 0.7 0.2 } def\n";
- print "/cyan { 0 0.6 0.9 } def\n";
- }
-
- print "/printText { 0 0 moveto (GrAnSim) show } def\n";
-
- if ( $opt_m ) {
- print "/logo { gsave \n" .
- " translate \n" .
- " .95 -.05 0\n" .
- " { setgray printText 1 -.5 translate } for \n" .
- " 1 setgray printText\n" .
- " grestore } def\n";
- } else {
- print "/logo { gsave \n" .
- " translate \n" .
- " .95 -.05 0\n" .
- " { dup 1 exch sub 0 exch setrgbcolor printText 1 -.5 translate } for \n" .
- " 1 0 0 setrgbcolor printText\n" .
- " grestore} def\n";
- }
-
- print "/asciilogo { 5 sub moveto HB16 setfont (GrAnSim) show } def\n";
- print "/cmpx {pop exch pop eq} def % compare x-coors of 2 points\n";
- print "/cmpy {exch pop 3 2 roll pop eq} def % compare y-coors of 2 points\n";
- print "/cmp {2 index eq {exch pop eq} % compare 2 points\n";
- print " {pop pop pop false} ifelse } def\n";
-
- # Hook for scaling just the graph and y-axis
- print "% " . "-" x 77 . "\n";
- print "/scale-y { } def\n";
- print "/unscale-y { } def\n";
-
- print "% " . "-" x 77 . "\n";
- print "/str-len 12 def\n";
- print "/prt-n { cvi str-len string cvs \n" .
- " dup stringwidth pop \n" .
- " currentpoint pop 780 gt { 10 sub } { 2 div } ifelse \n" .
- " neg 0 rmoveto \n" .
- " show } def \n" .
- " % print top-of-stack integer centered at the current point\n";
- # NB: These PostScript functions must correspond to the Perl fct `normalize'
- # Currently normalize defines the following trafo on (x,y) values:
- # $x_norm = int(($x/$tmax) * ($xmax-$xmin) + $xmin);
- # $y_norm = int(($y/$pmax) * ($ymax-$ymin) + $ymin);
-
- print "/total-len $tmax def\n";
- print "/show-len $xmax def\n";
- print "/x-offset $xmin def\n";
- print "/y-offset $ymin def\n";
- print "/normalize { total-len div show-len x-offset sub mul x-offset add floor } def\n";
- print "% " . "-" x 77 . "\n";
- print "%/L { lineto } def\n";
- print "%/L {2 copy pop 1 sub currentpoint exch pop lineto lineto} def\n";
- print "/L {2 copy currentpoint cmpx not\n";
- print " {2 copy pop currentpoint exch pop lineto} if\n";
- print " 2 copy currentpoint cmpy \n";
- print " {pop pop} \n";
- print " {lineto} ifelse\n";
- print "} def\n";
- print "/F { % flush a segment of the overall area; Arg: color\n";
- print " currentpoint pop $ymin lineto closepath\n";
- if ( $opt_m ) {
- print " setgray fill \n";
- } else {
- print " setrgbcolor fill \n";
- }
- print "} def\n";
- print "/M { % Start drawing a slice (vert. line and moveto startpoint)\n";
- print " % Arg: x y\n";
- print " newpath 1 index $ymin moveto lineto\n";
- print "} def\n";
- print "% For debugging PS uncomment this line and add the file behandler.ps\n";
- print "% $brkpage begin printonly endprint \n";
- print("/HE10 /Helvetica findfont 10 scalefont def\n");
- print("/HE12 /Helvetica findfont 12 scalefont def\n");
- print("/HE14 /Helvetica findfont 14 scalefont def\n");
- print("/HB16 /Helvetica-Bold findfont 16 scalefont def\n");
- print "% " . "-" x 77 . "\n";
-
- print("-90 rotate\n");
- print("-785 30 translate\n");
- print("newpath\n");
- print("0 8 moveto\n");
- print("0 525 760 525 8 arcto\n");
- print("4 {pop} repeat\n");
- print("760 525 760 0 8 arcto\n");
- print("4 {pop} repeat\n");
- print("760 0 0 0 8 arcto\n");
- print("4 {pop} repeat\n");
- print("0 0 0 525 8 arcto\n");
- print("4 {pop} repeat\n");
- print("0.500000 setlinewidth\n");
- print("stroke\n");
- print("newpath\n");
- print("4 505 moveto\n");
- print("4 521 752 521 4 arcto\n");
- print("4 {pop} repeat\n");
- print("752 521 752 501 4 arcto\n");
- print("4 {pop} repeat\n");
- print("752 501 4 501 4 arcto\n");
- print("4 {pop} repeat\n");
- print("4 501 4 521 4 arcto\n");
- print("4 {pop} repeat\n");
- print("0.500000 setlinewidth\n");
- print("stroke\n");
-
- print("HE14 setfont\n");
- print("100 505 moveto\n");
- print("($pname ) show\n");
-
- # print("($date) dup stringwidth pop 750 exch sub 505 moveto show\n");
-
- print("4 8 moveto\n");
- print("4 24 756 24 4 arcto\n");
- print("4 {pop} repeat\n");
- print("756 24 756 4 4 arcto\n");
- print("4 {pop} repeat\n");
- print("756 4 4 4 4 arcto\n");
- print("4 {pop} repeat\n");
- print("4 4 4 24 4 arcto\n");
- print("4 {pop} repeat\n");
- print("0.500000 setlinewidth\n");
- print("stroke\n");
-
-# Labels
-
-# x-range: 100 - 600
-# y-value:
-
- $x_begin = 100;
- $x_end = 600;
- $y_label = 10;
-
- $no_of_labels = length($show); # $info_level;
-
- $step = ($x_end-$x_begin)/($no_of_labels);
-
- $x_now = $x_begin;
-
- if ( $queue_on_a ) {
- do print_box_and_label($x_now,$y_label,"green","running");
- }
-
- if ( $queue_on_r ) {
- $x_now += $step;
- do print_box_and_label($x_now,$y_label,"amber","runnable");
- }
-
- if ( $queue_on_f ) {
- $x_now += $step;
- do print_box_and_label($x_now,$y_label,"cyan","fetching");
- }
-
- if ( $queue_on_b ) {
- $x_now += $step;
- do print_box_and_label($x_now,$y_label,"red","blocked");
- }
-
- if ( $queue_on_m ) {
- $x_now += $step;
- do print_box_and_label($x_now,$y_label,"blue","migrating");
- }
-
- if ( $queue_on_s ) {
- $x_now += $step;
- do print_box_and_label($x_now,$y_label,"crimson","sparked");
- }
-
- # Print runtime of prg; this is jus a crude HACK; better: x-axis! -- HWL
- #print("HE10 setfont\n");
- #print("680 10 moveto\n");
- #print("(RT: $tmax) show\n");
-
- print("-40 -10 translate\n");
-
- do print_x_axis();
-
- print("$xmin $ymin moveto\n");
- if ( $opt_m ) {
- print "0 setgray\n";
- } else {
- print "0 0 0 setrgbcolor\n";
- }
-
- do print_y_axis();
-
- print("scale-y\n");
-
-}
-
-# -----------------------------------------------------------------------------
-
-sub print_box_and_label {
- local ($x,$y,$color,$label) = @_;
- local ($z) = (15);
-
- print("$x 10 moveto\n");
- print("0 10 rlineto\n");
- print("10 0 rlineto\n");
- print("0 -10 rlineto\n");
- print("closepath\n");
- print("gsave\n");
- if ( $opt_m ) {
- print("$color setgray\n");
- } else {
- print("$color setrgbcolor\n");
- }
- print("fill\n");
- print("grestore\n");
- print("stroke\n");
- print("HE14 setfont\n");
- print(($x+$z) . " 10 moveto\n");
- print("($label) show\n");
-
-}
-
-# -----------------------------------------------------------------------------
-
-sub print_x_axis {
-
- print "% " . "-" x 77 . "\n";
- print "% X-Axis:\n";
- print "/y-val $ymin def\n";
- print "0.5 setlinewidth\n";
- print "x-offset y-val moveto total-len normalize x-offset sub 0 rlineto stroke\n";
- print "0 total-len 10 div total-len\n" .
- " { dup normalize dup y-val moveto 0 -2 rlineto stroke % tic\n" .
- " y-val 10 sub moveto HE10 setfont round prt-n % print label \n" .
- " } for \n";
- print "1 setlinewidth\n";
- print "% End X-Axis:\n";
- print "% " . "-" x 77 . "\n";
-}
-
-# -----------------------------------------------------------------------------
-
-sub print_y_axis {
- local ($i);
- local ($y, $smax,$majormax, $majorint);
-
-# Y-axis label
-
- print "% " . ("-" x 75) . "\n";
- print "% Y-Axis:\n";
- print "% " . ("-" x 75) . "\n";
-
- print("%scale-y % y-axis outside scaled area if ps-scale-y rebuilds it!\n");
-
- print("gsave\n");
- print("HE12 setfont\n");
- print("(tasks)\n");
- print("dup stringwidth pop\n");
- print("$ymax\n");
- print("exch sub\n");
- print("$labelx exch\n");
- print("translate\n");
- print("90 rotate\n");
- print("0 0 moveto\n");
- print("show\n");
- print("grestore\n");
-
-# Scale
-
- if ($pmax < $majorticks) {
- $majorticks = $pmax;
- }
-
- print("HE12 setfont\n$scalex $ymin moveto\n$scalex $ymax lineto\n");
- print("% Max number of tasks: $pmax\n");
- print("% Number of ticks: $majorticks\n");
-
- print "0.5 setlinewidth\n";
-
- $y = $ymax; # (($pmax - $ymin)/$majorticks) * ($majorticks-$i) + $ymin;
- print("$scalex $y moveto\n$major $y lineto\n");
- print("$markx $y moveto\n($pmax) show\n");
-
- $majormax = int($pmax/$majorticks)*$majorticks;
- $smax = $majormax*(($ymax-$ymin)/$pmax)+$ymin;
- $majorint = $majormax/$majorticks;
-
- for($i=1; $i <= $majorticks; ++$i) {
- $y = (($smax - $ymin)/$majorticks) * ($majorticks-$i) + $ymin;
- $majorval = int($majorint * ($majormax/$majorint-$i));
- print("$scalex $y moveto\n$major $y lineto\n");
- print("$markx $y moveto\n($majorval) show\n");
- }
-
- # print("$xmin $ymax moveto\n10 0 rlineto\n10 0 rmoveto\n($pmax) show\n");
- print " stroke\n";
- print "1 setlinewidth\n";
- print "%unscale-y\n";
- print "% End Y-Axis.\n";
- print "% " . ("-" x 75) . "\n";
-}
-
-# -----------------------------------------------------------------------------
-
-sub print_verbose_message {
-
- print STDERR "Prg Name: $pname \nDate: $date \nInfo-str: $show\n";
- print STDERR "Input: stdin Output: stdout\n";
- print STDERR "The following queues are turned on: " .
- ( $queue_on_a ? "active, " : "") .
- ( $queue_on_r ? "runnable, " : "") .
- ( $queue_on_b ? "blocked, " : "") .
- ( $queue_on_f ? "fetching, " : "") .
- ( $queue_on_m ? "migrating, " : "") .
- ( $queue_on_s ? "sparks" : "") .
- "\n";
- if ( $opt_C ) {
- print STDERR "Inserting check code into .ps file (for check-ps3 script)\n";
- }
- if ( $opt_D ) {
- print STDERR "Debugging is turned ON!\n";
- }
-}
-
-# ----------------------------------------------------------------------------
-
-sub process_options {
-
- if ( $opt_h ) {
- open(ME,$0) || die "Can't open myself ($0): $!\n";
- $n = 0;
- while (<ME>) {
- last if $_ =~ /^$/;
- print $_;
- $n++;
- }
- close(ME);
- exit ;
- }
-
- if ( $#ARGV != 3 ) {
- print "Usage: $0 [options] <max x value> <max y value> <prg name> <date> \n";
- print "Use -h option to get details\n";
- exit 1;
- }
-
- $tmax = $ARGV[0];
- $pmax = $ARGV[1];
- # GUM uses the absolute path (with '=' instead of '/') of the executed file
- # (for PVM reasons); if you want to have the full path in the generated
- # graph, too, eliminate the substitution below
- ($pname = $ARGV[2]) =~ s/.*=//;
- $date = $ARGV[3];
-
- $show = "armfb";
- $draw_lines = 0;
-
- if ( $opt_i ) {
- $show = "a" if info_level == 1;
- $show = "ar" if info_level == 2;
- $show = "arb" if info_level == 3;
- $show = "arfb" if info_level == 4;
- $show = "armfb" if info_level == 5;
- $show = "armfbs" if info_level == 6;
- }
-
- if ( $opt_I ) {
- $show = $opt_I;
- }
-
- if ( $opt_v ){
- $verbose = 1;
- }
-
- if ( $opt_l ) {
- $slice_width = $opt_l;
- } else {
- $slice_width = 500;
- }
-
- $queue_on_a = &queue_on("a");
- $queue_on_r = &queue_on("r");
- $queue_on_b = &queue_on("b");
- $queue_on_f = &queue_on("f");
- $queue_on_s = &queue_on("s");
- $queue_on_m = &queue_on("m");
-
-# if ($#ARGV == 0) {
-# printf(stderr "usage: qp2ps.pl runtime [prog [date]]\n");
-# exit 1;
-# }
-}
-
diff --git a/ghc/utils/parallel/sn_filter.pl b/ghc/utils/parallel/sn_filter.pl
deleted file mode 100644
index 4bfc2d1721..0000000000
--- a/ghc/utils/parallel/sn_filter.pl
+++ /dev/null
@@ -1,92 +0,0 @@
-#!/usr/local/bin/perl
-# ############################################################################
-# Time-stamp: <Wed Jun 19 1996 12:26:21 Stardate: [-31]7682.38 hwloidl>
-#
-# Usage: sn_filter [options] <gr-file> <sn>
-#
-# Extract all events out of <gr-file> that are related to threads whose
-# spark name component is <sn>.
-#
-# Options:
-# -H ... Print header of the <gr-file>, too
-# -h ... print help message (this text)
-# -v ... be talkative
-#
-# ############################################################################
-
-$gran_dir = $ENV{'GRANDIR'};
-if ( $gran_dir eq "" ) {
- print STDERR "Warning: Env variable GRANDIR is undefined\n";
-}
-
-push(@INC, $gran_dir, $gran_dir . "/bin");
-# print STDERR "INC: " . join(':',@INC) . "\n";
-
-require "get_SN";
-require "getopts.pl";
-
-&Getopts('hvH');
-
-do process_options();
-if ( $opt_v ) { do print_verbose_message(); }
-
-# ----------------------------------------------------------------------------
-
-do get_SN($input);
-
-open (FILE,$input) || die "Can't open $file\n";
-
-$in_header = 1;
-while (<FILE>) {
- print if $in_header && $opt_H;
- $in_header = 0 if /^\++$/;
- next if $in_header;
- next unless /^PE\s*\d+\s*\[\d+\]:\s*\w*\s*([0-9a-fx]+)/;
- $id = $1;
- # print STDERR "$id --> " . $id2sn{hex($id)} . " sn: $sn ==> " . ($sn eq $id2sn{hex($id)}) . "\n";
- print if $sn == $id2sn{hex($id)};
-}
-
-close (FILE);
-
-exit 0;
-
-# ----------------------------------------------------------------------------
-
-sub process_options {
-
- if ( $#ARGV != 1 ) {
- die "Usage: sn_filter <gr-file> <sn>\n";
- }
-
- $input = $ARGV[0];
- $sn = $ARGV[1];
-
- print STDERR "File: |$file|; sn: |$sn|\n" if $opt_v;
-
- if ( $opt_h ) {
- open (ME,$0) || die "!$: $0";
- while (<ME>) {
- last if /^$/;
- print;
- }
- close (ME);
- exit 1;
- }
-}
-
-# ----------------------------------------------------------------------------
-
-sub print_verbose_message {
-
- print "Input: $input\tOutput: stdout\tSN: $sn\n";
- if ( $opt_H ) {
- print "Prepending .gr header to the output.\n";
- }
-
-}
-
-# ----------------------------------------------------------------------------
-
-
-
diff --git a/ghc/utils/parallel/stats.pl b/ghc/utils/parallel/stats.pl
deleted file mode 100644
index 6cf826b5cd..0000000000
--- a/ghc/utils/parallel/stats.pl
+++ /dev/null
@@ -1,168 +0,0 @@
-#!/usr/local/bin/perl
-##############################################################################
-# Time-stamp: <Sat Oct 28 1995 23:15:13 Stardate: [-31]6509.63 hwloidl>
-#
-# Usage: do ....
-#
-# Statistics package that is used in gran-extr, RTS2gran and friends.
-# Most of the routines assume a list of integers as input.
-# This package contains:
-# - corr
-# - mean_std_dev
-# - cov
-# - list_sum
-# - list_max
-# - list_min
-#
-##############################################################################
-
-# ----------------------------------------------------------------------------
-# Compute correlation of 2 vectors, having their sums precomputed.
-# Usage: do corr(($n, $sum_1, @rest);
-#
-# Input: $n ... number of all elements in @list_1 as well as in @list_2
-# (i.e. $n = $#list_1+1 = $#list_2+1).
-# $sum_1 ... sum of all elements in @list_1
-# @list_1 ... list of integers; first vector
-# $sum_2 ... sum of all elements in @list_2
-# @list_2 ... list of integers; first vector
-# Output: correlation of @list_1 and @list_2
-# ----------------------------------------------------------------------------
-
-sub corr {
- local ($n, $sum_1, @rest) = @_;
- local (@list_1) = splice(@rest,0,$n);
- local ($sum_2, @list_2) = @rest;
-
- local ($mean_1,$mean_2,$std_dev_1,$std_dev_2);
-
- if ( $opt_D ) {
- print "\ncorr: n=$n sum_1=$sum_1 sum_2=$sum_2\n";
- print " list_sum of list_1=" . &list_sum(@list_1) .
- " list_sum of list_2=" . &list_sum(@list_2) . "\n";
- print " len of list_1=$#list_1 len of list_2=$#list_2\n";
- }
-
- ($mean_1, $std_dev_1) = &mean_std_dev($sum_1,@list_1);
- ($mean_2, $std_dev_2) = &mean_std_dev($sum_2,@list_2);
-
- if ( $opt_D ) {
- print "corr: $mean_1, $std_dev_1; $mean_2, $std_dev_2\n";
- }
-
- return ( ($std_dev_1 * $std_dev_2) == 0 ?
- 0 :
- &cov($n, $mean_1, @list_1, $mean_2, @list_2) /
- ( $std_dev_1 * $std_dev_2 ) );
-}
-
-# ----------------------------------------------------------------------------
-
-sub mean_std_dev {
- local ($sum,@list) = @_;
- local ($n, $s, $s_);
-
- #print "\nmean_std_dev: sum is $sum ; list has length $#list";
-
- $n = $#list+1;
- $mean_value = $sum/$n;
-
- $s_ = 0;
- foreach $x (@list) {
- $s_ += $x;
- $s += ($mean_value - $x) ** 2;
- }
- if ( $sum != $s_ ) {
- print "stat.pl: ERROR in mean_std_dev: provided sum is wrong " .
- "(provided: $sum; computed: $s_ " .
- ";list_sum: " . &list_sum(@list) . "\n";
- exit (2);
- }
-
- return ( ($mean_value, sqrt($s / ($n - 1)) ) );
-}
-
-# ----------------------------------------------------------------------------
-
-sub _mean_std_dev {
- return ( &mean_std_dev(&list_sum(@_), @_) );
-}
-
-# ----------------------------------------------------------------------------
-# Compute covariance of 2 vectors, having their sums precomputed.
-# Input: $n ... number of all elements in @list_1 as well as in @list_2
-# (i.e. $n = $#list_1+1 = $#list_2+1).
-# $mean_1 ... mean value of all elements in @list_1
-# @list_1 ... list of integers; first vector
-# $mean_2 ... mean value of all elements in @list_2
-# @list_2 ... list of integers; first vector
-# Output: covariance of @list_1 and @list_2
-# ----------------------------------------------------------------------------
-
-sub cov {
- local ($n, $mean_1, @rest) = @_;
- local (@list_1) = splice(@rest,0,$n);
- local ($mean_2, @list_2) = @rest;
-
- local ($i,$s,$s_1,$s_2);
-
- for ($i=0; $i<$n; $i++) {
- $s_1 += $list_1[$i];
- $s_2 += $list_2[$i];
- $s += ($mean_1 - $list_1[$i]) * ($mean_2 - $list_2[$i]);
- }
- if ( $mean_1 != ($s_1/$n) ) {
- print "stat.pl: ERROR in cov: provided mean value is wrong " .
- "(provided: $mean_1; computed: " . ($s_1/$n) . ")\n";
- exit (2);
- }
- if ( $mean_2 != ($s_2/$n) ) {
- print "stat.pl: ERROR in cov: provided mean value is wrong " .
- "(provided: $mean_2; computed: " . ($s_2/$n) . ")\n";
- exit (2);
- }
- return ( $s / ($n - 1) ) ;
-}
-
-# ---------------------------------------------------------------------------
-
-sub list_sum {
- local (@list) = @_;
- local ($sum) = (0);
-
- foreach $x (@list) {
- $sum += $x;
- }
-
- return ($sum);
-}
-
-# ----------------------------------------------------------------------------
-
-sub list_max {
- local (@list) = @_;
- local ($max) = shift;
-
- foreach $x (@list) {
- $max = $x if $x > $max;
- }
-
- return ($max);
-}
-
-# ----------------------------------------------------------------------------
-
-sub list_min {
- local (@list) = @_;
- local ($min) = shift;
-
- foreach $x (@list) {
- $min = $x if $x < $min;
- }
-
- return ($min);
-}
-
-# ----------------------------------------------------------------------------
-
-1;
diff --git a/ghc/utils/parallel/template.pl b/ghc/utils/parallel/template.pl
deleted file mode 100644
index 7fbe4cf797..0000000000
--- a/ghc/utils/parallel/template.pl
+++ /dev/null
@@ -1,141 +0,0 @@
-#!/usr/local/bin/perl
-##############################################################################
-# Time-stamp: <Sat Oct 28 1995 23:00:47 Stardate: [-31]6509.58 hwloidl>
-#
-# Usage: do read_template(<template_file_name>,<input_file_name>);
-#
-# Read the template file <template_file_name> as defined in /dev/null.
-# Set global variables as defined in the template file.
-# This is mainly used in gran-extr and RTS2gran.
-#
-##############################################################################
-
-require "par-aux.pl";
-
-sub read_template {
- local ($org_templ_file_name,$input) = @_;
- local ($f,$templ_file_name);
-
- # Resolve name
- $gran_dir = $ENV{GRANDIR} ? $ENV{GRANDIR} : $ENV{HOME} ;
- $templ_file_name = ( $org_templ_file_name eq '.' ? "TEMPL"
- #^^^ default file name
- : $org_templ_file_name eq ',' ? $gran_dir . "/bin/TEMPL"
- #^^^ global master template
- : $org_templ_file_name eq '/' ? $gran_dir . "/bin/T0"
- #^^ template, that throws away most of the info
- : $org_templ_file_name );
-
- if ( $opt_v ) {
- print "Reading template file $templ_file_name ...\n";
- }
-
- ($f = ($input eq "-" ? "stdin" : $input)) =~ s/.rts//;
-
- open(TEMPLATE,"cat $templ_file_name | sed -e 's/\$0/$f/' |")
- || die "Couldn't open file $templ_file_name";
-
- while (<TEMPLATE>) {
- next if /^\s*$/ || /^--/;
- if (/^\s*G[:,;.\s]+([^\n]+)$/) {
- $list_str = $1;
- $list_str =~ s/[\(\)\[\]]//g;
- @exec_times = split(/[,;. ]+/, $list_str);
- } elsif (/^\s*F[:,;.\s]+([^\n]+)$/) {
- $list_str = $1;
- $list_str =~ s/[\(\)\[\]]//g;
- @fetch_times = split(/[,;. ]+/, $list_str);
- } elsif (/^\s*A[:,;.\s]+([^\n]+)$/) {
- $list_str = $1;
- $list_str =~ s/[\(\)\[\]]//g;
- @has = split(/[,;. ]+/, $list_str);
- } elsif (/^\s*C[:,;.\s]+([^\n]+)$/) {
- $list_str = $1;
- $list_str =~ s/[\(\)\[\]]//g;
- @comm_percs = split(/[,;. ]+/, $list_str);
- } elsif (/^\s*S[:,;.\s]+([^\n]+)$/) {
- $list_str = $1;
- $list_str =~ s/[\(\)\[\]]//g;
- @sparks = split(/[,;. ]+/, $list_str);
- } elsif (/^\s*g[:,;.\s]+([\S]+)$/) {
- ($gran_file_name,$gran_global_file_name, $gran_local_file_name) =
- &mk_global_local_names($1);
- } elsif (/^\s*f[:,;.\s]+([\S]+)$/) {
- ($ft_file_name,$ft_global_file_name, $ft_local_file_name) =
- &mk_global_local_names($1);
- } elsif (/^\s*c[:,;.\s]+([\S]+)$/) {
- ($comm_file_name, $comm_global_file_name, $comm_local_file_name) =
- &mk_global_local_names($1);
- } elsif (/^\s*s[:,;.\s]+([\S]+)$/) {
- ($spark_file_name, $spark_global_file_name, $spark_local_file_name) =
- &mk_global_local_names($1);
- } elsif (/^\s*a[:,;.\s]+([\S]+)$/) {
- ($ha_file_name, $ha_global_file_name, $ha_local_file_name) =
- &mk_global_local_names($1);
- } elsif (/^\s*p[:,;.\s]+([\S]+)$/) {
- $gp_file_name = $1;
- # $ps_file_name = &dat2ps_name($gp_file_name);
- } elsif (/^\s*Xcorr[:,;.\s]+([\S]+)$/) {
- $corr_file_name = $1;
- } elsif (/^\s*Xcumulat-rts[:,;.\s]+([\S]+)$/) {
- $cumulat_rts_file_name = $1;
- ($cumulat0_rts_file_name = $1) =~ s/\./0./;
- } elsif (/^\s*Xcumulat-has[:,;.\s]+([\S]+)$/) {
- $cumulat_has_file_name = $1;
- } elsif (/^\s*Xcumulat-fts[:,;.\s]+([\S]+)$/) {
- $cumulat_fts_file_name = $1;
- } elsif (/^\s*Xcumulat-cps[:,;.\s]+([\S]+)$/) {
- $cumulat_cps_file_name = $1;
- } elsif (/^\s*Xclust-rts[:,;.\s]+([\S]+)$/) {
- $clust_rts_file_name = $1;
- } elsif (/^\s*Xclust-has[:,;.\s]+([\S]+)$/) {
- $clust_has_file_name = $1;
- } elsif (/^\s*Xclust-fts[:,;.\s]+([\S]+)$/) {
- $clust_fts_file_name = $1;
- } elsif (/^\s*Xclust-cps[:,;.\s]+([\S]+)$/) {
- $clust_cps_file_name = $1;
- } elsif (/^\s*Xpe[:,;.\s]+([\S]+)$/) {
- $pe_file_name = $1;
- } elsif (/^\s*Xsn[:,;.\s]+([\S]+)$/) {
- $sn_file_name = $1;
-
- } elsif (/^\s*XRTS[:,;.\s]+([\S]+)$/) {
- $rts_file_name = $1;
- } elsif (/^\s*XHAS[:,;.\s]+([\S]+)$/) {
- $has_file_name = $1;
- } elsif (/^\s*XFTS[:,;.\s]+([\S]+)$/) {
- $fts_file_name = $1;
- } elsif (/^\s*XLSPS[:,;.\s]+([\S]+)$/) {
- $lsps_file_name = $1;
- } elsif (/^\s*XGSPS[:,;.\s]+([\S]+)$/) {
- $gsps_file_name = $1;
- } elsif (/^\s*XCPS[:,;.\s]+([\S]+)$/) {
- $cps_file_name = $1;
- } elsif (/^\s*XCCPS[:,;.\s]+([\S]+)$/) {
- $ccps_file_name = $1;
-
- } elsif (/^\s*\-[:,;.\s]+([\S]+)$/) {
- $input = $1;
- } elsif (/^\s*L[:,;\s]+(.*)$/) {
- $str = $1;
- %logscale = ('g',"xy",'a',"xy",'Cg',"xy",'Ca',"xy",'Yp',"y",'Ys',"y") , next if $str eq ".";
- $str =~ s/[\(\)\[\]]//g;
- %logscale = split(/[,;. ]+/, $str);
- } elsif (/^\s*i[:,;.\s]+([\S]+)$/) {
- $gray = $1;
- } elsif (/^\s*k[:,;.\s]+([\S]+)$/) {
- $no_of_clusters = $1;
- } elsif (/^\s*e[:,;.\s]+([\S]+)$/) {
- $ext_size = $1;
- } elsif (/^\s*v.*$/) {
- $verbose = 1;
- } elsif (/^\s*T.*$/) {
- $opt_T = 1;
- }
- }
- close(TEMPLATE);
-}
-
-# ----------------------------------------------------------------------------
-
-1;
diff --git a/ghc/utils/parallel/tf.pl b/ghc/utils/parallel/tf.pl
deleted file mode 100644
index 40cff09f2c..0000000000
--- a/ghc/utils/parallel/tf.pl
+++ /dev/null
@@ -1,148 +0,0 @@
-#!/usr/local/bin/perl
-# ############################################################################
-# Time-stamp: <Fri Aug 25 1995 23:17:43 Stardate: [-31]6189.64 hwloidl>
-# (C) Hans Wolfgang Loidl, November 1994
-#
-# Usage: tf [options] <gr-file>
-#
-# Show the `taskflow' in the .gr file (especially useful for keeping track of
-# migrated tasks. It's also possible to focus on a given PE or on a given
-# event.
-#
-# Options:
-# -p <int> ... Print all events on PE <int>
-# -t <int> ... Print all events that occur on task <int>
-# -e <str> ... Print all <str> events
-# -n <hex> ... Print all events about fetching the node at address <hex>.
-# -s <int> ... Print all events with a spark name <int>
-# -L ... Print all events with spark queue length information
-# -H ... Print header of the <gr-file>, too
-# -h ... print help message (this text)
-# -v ... be talkative
-#
-# ############################################################################
-
-# ----------------------------------------------------------------------------
-# Command line processing and initialization
-# ----------------------------------------------------------------------------
-
-require "getopts.pl";
-
-&Getopts('hvHLp:t:e:n:s:S:');
-
-do process_options();
-
-if ( $opt_v ) {
- do print_verbose_message();
-}
-
-# ----------------------------------------------------------------------------
-
-$in_header = 1;
-while (<>) {
- if ( $opt_H && $in_header ) {
- print;
- $in_header = 0 if /^\+\+\+\+\+/;
- }
- next unless /^PE/;
- @c = split(/[\s\[\]:;,]+/);
- if ( ( $check_proc ? $proc eq $c[1] : 1 ) &&
- ( $check_event ? $event eq $c[3] : 1 ) &&
- ( $check_task ? $task eq $c[4] : 1) &&
- ( $check_node ? $node eq $c[5] : 1) &&
- ( $check_spark ? (("END" eq $c[3]) && ($spark eq $c[6])) : 1) &&
- ( $negated_spark ? (("END" eq $c[3]) && ($spark ne $c[6])) : 1) &&
- ( $spark_queue_len ? ($c[5] =~ /sparks/) : 1 ) ) {
- print;
- }
-}
-
-exit 0;
-
-# ----------------------------------------------------------------------------
-
-sub process_options {
-
- if ( $opt_p ne "" ) {
- $check_proc = 1;
- $proc = $opt_p;
- }
-
- if ( $opt_t ne "" ) {
- $check_task = 1;
- $task = $opt_t;
- }
-
- if ( $opt_e ne "" ) {
- $check_event = 1;
- $event = $opt_e;
- }
-
- if ( $opt_n ne "" ) {
- $check_node = 1;
- $node = $opt_n
- }
-
- if ( $opt_s ne "" ) {
- $check_spark = 1;
- $spark = $opt_s
- }
-
- if ( $opt_S ne "" ) {
- $negated_spark = 1;
- $spark = $opt_S
- }
-
- if ( $opt_L ) {
- $spark_queue_len = 1;
- } else {
- $spark_queue_len = 0;
- }
-
- if ( $opt_h ) {
- open (ME,$0) || die "!$: $0";
- while (<ME>) {
- last if /^$/;
- print;
- }
- close (ME);
- exit 1;
- }
-}
-
-# ----------------------------------------------------------------------------
-
-sub print_verbose_message {
-
- if ( $opt_p ne "" ) {
- print "Processor: $proc\n";
- }
-
- if ( $opt_t ne "" ) {
- print "Task: $task\n";
- }
-
- if ( $opt_e ne "" ) {
- print "Event: $event\n";
- }
-
- if ( $opt_n ne "" ) {
- print "Node: $node\n";
- }
-
- if ( $opt_s ne "" ) {
- print "Spark: $spark\n";
- }
-
- if ( $opt_S ne "" ) {
- print "Negated Spark: $spark\n";
- }
-
- if ( $opt_L ne "" ) {
- print "Printing spark queue len info.\n";
- }
-
-}
-
-# ----------------------------------------------------------------------------
-
diff --git a/ghc/utils/prof/Makefile b/ghc/utils/prof/Makefile
deleted file mode 100644
index 7887be7f1d..0000000000
--- a/ghc/utils/prof/Makefile
+++ /dev/null
@@ -1,46 +0,0 @@
-#-----------------------------------------------------------------------------
-# $Id: Makefile,v 1.5 2000/09/05 10:16:41 simonmar Exp $
-#
-# (c) The GHC Team, 2000
-#
-
-TOP=../..
-include $(TOP)/mk/boilerplate.mk
-
-INSTALLING=1
-
-ifeq "$(INSTALLING)" "1"
-SUBDIRS = cgprof icons
-endif
-
-SCRIPT_SUBST_VARS= \
- FPTOOLS_TOP_ABS \
- INSTALLING \
- DEFAULT_TMPDIR \
- TARGETPLATFORM
-
-INSTALLED_SCRIPT_PROG = ghcprof
-INPLACE_SCRIPT_PROG = ghcprof-inplace
-
-ifeq "$(INSTALLING)" "1"
-SCRIPT_PROG = $(INSTALLED_SCRIPT_PROG)
-else
-SCRIPT_PROG = $(INPLACE_SCRIPT_PROG)
-endif
-
-ifneq "$(BIN_DIST)" "1"
-SCRIPT_SUBST_VARS += libdir libexecdir
-endif
-
-# don't recurse on 'make install'
-#
-ifeq "$(INSTALLING)" "1"
-all clean distclean mostlyclean maintainer-clean ::
- $(MAKE) INSTALLING=0 BIN_DIST=0 $(MFLAGS) $@
-endif
-
-INTERP = perl
-SCRIPT_OBJS = ghcprof.prl
-INSTALL_SCRIPTS += $(SCRIPT_PROG)
-
-include $(TOP)/mk/target.mk
diff --git a/ghc/utils/prof/cgprof/Makefile b/ghc/utils/prof/cgprof/Makefile
deleted file mode 100644
index fd6ac040a7..0000000000
--- a/ghc/utils/prof/cgprof/Makefile
+++ /dev/null
@@ -1,15 +0,0 @@
-#-----------------------------------------------------------------------------
-# $Id: Makefile,v 1.2 2003/08/01 15:38:41 panne Exp $
-#
-# (c) The GHC Team, 2000
-#
-
-TOP=../../..
-include $(TOP)/mk/boilerplate.mk
-
-C_PROG = cgprof
-INSTALL_LIBEXECS=$(C_PROG)
-
-SRC_CC_OPTS += -Wall -I$(GHC_INCLUDE_DIR)
-
-include $(TOP)/mk/target.mk
diff --git a/ghc/utils/prof/cgprof/README b/ghc/utils/prof/cgprof/README
deleted file mode 100644
index 2c4ca16bc9..0000000000
--- a/ghc/utils/prof/cgprof/README
+++ /dev/null
@@ -1,7 +0,0 @@
-
-Please read the instructions in the section `Introduction - Using the
-profiling tool' before you begin:
-
-http://www.dcs.warwick.ac.uk/people/academic/Stephen.Jarvis/profiler/index.html
-
-This contains all the necessary compilation instructions etc.
diff --git a/ghc/utils/prof/cgprof/cgprof.c b/ghc/utils/prof/cgprof/cgprof.c
deleted file mode 100644
index 8ee66e1f52..0000000000
--- a/ghc/utils/prof/cgprof/cgprof.c
+++ /dev/null
@@ -1,1284 +0,0 @@
-/* ------------------------------------------------------------------------
- * $Id: cgprof.c,v 1.6 2004/08/13 13:11:22 simonmar Exp $
- *
- * Copyright (C) 1995-2000 University of Oxford
- *
- * Permission to use, copy, modify, and distribute this software,
- * and to incorporate it, in whole or in part, into other software,
- * is hereby granted without fee, provided that
- * (1) the above copyright notice and this permission notice appear in
- * all copies of the source code, and the above copyright notice
- * appear in clearly visible form on all supporting documentation
- * and distribution media;
- * (2) modified versions of this software be accompanied by a complete
- * change history describing author, date, and modifications made;
- * and
- * (3) any redistribution of the software, in original or modified
- * form, be without fee and subject to these same conditions.
- * --------------------------------------------------------------------- */
-
-#include "ghcconfig.h"
-#if HAVE_STRING_H
-#include <string.h>
-#endif
-
-#include "daVinci.h"
-#include "symbol.h"
-#include "cgprof.h"
-#include "matrix.h"
-
-/* -----------------------------------------------------------------------------
- * Data structures
- * -------------------------------------------------------------------------- */
-
-int raw_profile_next=0;
-int raw_profile_size=0;
-parsed_cost_object *raw_profile=NULL;
-
-/* -----------------------------------------------------------------------------
- * Create/grow data sequence of raw profile data
- * -------------------------------------------------------------------------- */
-
-void enlargeRawProfile() {
-
- if (raw_profile_size==0) {
- raw_profile_next = 0;
- raw_profile_size = RAW_PROFILE_INIT_SIZE;
- raw_profile = calloc(raw_profile_size,sizeof(parsed_cost_object));
- } else {
- raw_profile_size += RAW_PROFILE_INIT_SIZE;
- raw_profile = realloc(raw_profile,
- raw_profile_size*sizeof(parsed_cost_object));
- }
- if (raw_profile==NULL) {
- fprintf(stderr,"{enlargeRawProfile} unable to allocate %d elements",
- raw_profile_size);
- exit(1);
- }
-}
-
-/* -----------------------------------------------------------------------------
- * Function that adds two cost centers together
- *
- * This will be used to generate the inheretance profile.
- * -------------------------------------------------------------------------- */
-
-void add_costs(object_cost *left, object_cost right) {
-
- left->syncs += right.syncs;
- left->comp_max += right.comp_max;
- left->comp_avg += right.comp_avg;
- left->comp_min += right.comp_min;
- left->comm_max += right.comm_max;
- left->comm_avg += right.comm_avg;
- left->comm_min += right.comm_min;
- left->comp_idle_max += right.comp_idle_max;
- left->comp_idle_avg += right.comp_idle_avg;
- left->comp_idle_min += right.comp_idle_min;
- left->hrel_max += right.hrel_max;
- left->hrel_avg += right.hrel_avg;
- left->hrel_min += right.hrel_min;
- if ((left->proc==NULL) || (right.proc==NULL)) {
- fprintf(stderr,"Cost is null");
- exit(0);
- }
-}
-
-
-int ignore_function(char *fname) {
- return 0;
-}
-
-/* -----------------------------------------------------------------------------
- * GHC specific data structures
- * -------------------------------------------------------------------------- */
-
-/* Globals */
-/* You will need to update these when you increase the number of */
-/* cost centres, cost centre stacks, heap objects */
-
- #define MAX_IDENTIFIERS 2000 /* maximum number of identifiers */
- /* or size of matrix structure */
-
- /* make this dynamic */
-
- #define MAX_TIME 100 /* Maximum serial time for heap profile */
- #define MAX_SAMPLES 50 /* Maximum heap samples */
-
- /* To do: modify this to be dynamic */
-
- #define MAX_STRING_SIZE 70
- #define MAX_LINE_LENGTH 80
- #define EOF (-1)
-
-/* Cost centre data structure */
-
- struct cost_centre { char *name;
- char *module;
- char *group;
- } _cc_;
-
- typedef struct cost_centre cc_matrix[MAX_IDENTIFIERS];
-
- //typedef struct cost_centre *cc_matrix;
-
- typedef cc_matrix* p_cc_matrix;
- typedef char* MY_STRING;
-
-/* Heap sample structure */
-
- struct heap_sample {
- int count; /* heap_sample */
- };
-
- typedef struct heap_sample heap_sample_matrix[MAX_IDENTIFIERS];
- typedef heap_sample_matrix* p_heap_sample_matrix;
-
-/* Cost centre stack data structure */
-
- struct cost_centre_stack {
- int cc;
- int ccs;
- int scc; /* scc_sample */
- int ticks; /* scc_sample */
- int bytes; /* scc_sample */
- p_heap_sample_matrix hsm; /* heap_sample */
- };
-
- typedef struct cost_centre_stack ccs_matrix[MAX_IDENTIFIERS];
- typedef ccs_matrix* p_ccs_matrix;
-
-/* Heap object data structure */
-
- struct heap_object { int type; /* type of heap object */
- char* descriptor;
- int type_constr_ref; /* if present */
- };
-
- typedef struct heap_object heap_object_matrix[MAX_IDENTIFIERS];
- typedef heap_object_matrix* p_heap_object_matrix;
-
-/* Type constructor structure */
-
- struct type_constr { char* module;
- char* name;
- };
-
- typedef struct type_constr type_constr_matrix[MAX_IDENTIFIERS];
- typedef type_constr_matrix* p_type_constr_matrix;
-
-/* Heap update structure */
-
- struct heap_update_sample { int ccs; /* associated cost centre stack */
- int ho; /* associated heap object */
- int count;
- };
-
- typedef struct heap_update_sample heap_update_list[MAX_SAMPLES];
- typedef heap_update_list* p_heap_update_list;
-
- struct heap_update_record { int no_samples; /* Number of samples */
- p_heap_update_list acc_samples;
- };
-
- typedef struct heap_update_record TheHeap[MAX_TIME];
- typedef TheHeap* p_TheHeap;
-
-
-/* -----------------------------------------------------------------------------
- * GHC specific functions
- * -------------------------------------------------------------------------- */
-
-// Initialisation routines
-
-void initialise_heap_update_list(heap_update_list *m)
-{
- int i;
- for (i=0; i<MAX_SAMPLES;i++)
- {
- (*m)[i].ccs = -1;
- (*m)[i].ho = -1;
- (*m)[i].count = -1;
- }
-}
-
-void add_to_heap_update_list(heap_update_list *m, int ccs, int ho, int count, int pos)
-{
- (*m)[pos].ccs = ccs;
- (*m)[pos].ho = ho;
- (*m)[pos].count = count;
-}
-
-void initialise_TheHeap(TheHeap *h)
-{
- int i;
- for (i=0; i<MAX_TIME;i++)
- {
- heap_update_list *h_u_l;
- h_u_l = (p_heap_update_list) malloc (sizeof(heap_update_list));
- initialise_heap_update_list(h_u_l);
- (*h)[i].acc_samples = h_u_l;
- (*h)[i].no_samples = 0;
- }
-}
-
-void add_to_TheHeap(TheHeap *h, int time, int ccs, int ho, int count)
-{
- add_to_heap_update_list((*h)[time].acc_samples,ccs,ho,count,(*h)[time].no_samples);
- (*h)[time].no_samples++;
-}
-
-void initialise_cc_matrix(cc_matrix *m)
-{
- int i;
- char *blank="blank"; /* To do: Modify this terminator string */
- for (i=0; i<MAX_IDENTIFIERS; i++)
- {
- (*m)[i].name = (MY_STRING) malloc ((MAX_STRING_SIZE));
- (*m)[i].module = (MY_STRING) malloc ((MAX_STRING_SIZE));
- (*m)[i].group = (MY_STRING) malloc ((MAX_STRING_SIZE));
-
- strcpy((*m)[i].name,blank);
- strcpy((*m)[i].module,blank);
- strcpy((*m)[i].group,blank);
- }
-}
-
-void free_cc_matrix(cc_matrix *m)
-{
- int i;
- for (i=0; i<MAX_IDENTIFIERS; i++)
- {
- free((*m)[i].name);
- free((*m)[i].module);
- free((*m)[i].group);
- }
- free(m);
-}
-
-void initialise_heap_object_matrix(heap_object_matrix *m)
-{
- int i;
- char *blank="blank"; /* To do: ditto */
- for (i=0; i<MAX_IDENTIFIERS; i++)
- {
- (*m)[i].type = -1;
- (*m)[i].descriptor = (MY_STRING) malloc ((MAX_STRING_SIZE));
- strcpy((*m)[i].descriptor,blank);
- (*m)[i].type_constr_ref = -1;
- }
-}
-
-void initialise_type_constr_matrix(type_constr_matrix *m)
-{
- int i;
- char *blank="blank";
- for (i=0; i<MAX_IDENTIFIERS; i++)
- {
- (*m)[i].module = (MY_STRING) malloc ((MAX_STRING_SIZE));
- (*m)[i].name = (MY_STRING) malloc ((MAX_STRING_SIZE));
- strcpy((*m)[i].module,blank);
- strcpy((*m)[i].name,blank);
- }
-}
-
-void initialise_heap_sample_matrix(heap_sample_matrix *m)
-{
- int i;
- for (i=0; i<MAX_IDENTIFIERS; i++)
- { (*m)[i].count = -1; }
-}
-
-void initialise_ccs_matrix(ccs_matrix *m)
-{
- int i;
- for (i=0; i<MAX_IDENTIFIERS; i++)
- {
- /* Stack heap samples */
- heap_sample_matrix *hs_m;
- hs_m = (p_heap_sample_matrix) malloc (sizeof(heap_sample_matrix));
- initialise_heap_sample_matrix(hs_m);
- (*m)[i].hsm = hs_m;
- /* Stack scc samples */
- (*m)[i].cc = 0;
- (*m)[i].ccs = 0;
- (*m)[i].scc = 0;
- (*m)[i].ticks = 0;
- (*m)[i].bytes = 0;
- }
-}
-
-
-// Filling matrix routines
-
-char* StripDoubleQuotes(char* s) /* For fussy daVinci! */
-{
- char *p = s;
- char *tempchar;
- char *empty="";
- char *tempstring = (MY_STRING) malloc ((MAX_STRING_SIZE));
- strcpy(tempstring,empty);
- while (*p)
- { if (*p!='"')
- { tempchar = p; strncat(tempstring,p,1);
- }
- p++;
- }
- return tempstring;
-}
-
-void fill_cc_matrix(cc_matrix *m,char* name,char* module,char* group,int i)
-{
- if (i>MAX_IDENTIFIERS)
- { fprintf(logFile,"Cost centre MAX_IDENTIFIERS exceeded: %i \n",i); exit(1); }
- name = StripDoubleQuotes(name);
- strcpy((*m)[i].name,name);
- module = StripDoubleQuotes(module);
- strcpy((*m)[i].module,module);
- group = StripDoubleQuotes(group);
- strcpy((*m)[i].group,group);
-}
-
-void fill_ccs_matrix(ccs_matrix *m,int cc, int ccs, int scc, int ticks, int bytes, int h_o, int count, int i)
-{
- heap_sample_matrix *hsm;
-
- if ((*m)[i].cc == 0) /* added for type 2 stack semantics, but should not */
- /* change behaviour of type 1 (apart from CAF:REP. */
- {
- if (i>MAX_IDENTIFIERS)
- { fprintf(logFile,"Cost centre stack MAX_IDENTIFIERS exceeded: %i \n",i); exit(1); }
- hsm = (*m)[i].hsm;
- (*m)[i].cc = cc; (*m)[i].ccs = ccs;
- (*m)[i].ticks = ticks; (*m)[i].bytes = bytes; (*m)[i].scc = scc;
- (*hsm)[h_o].count = count;
- }
- else fprintf(logFile,"Ignoring redeclaration of stack %i\n",i);
-}
-
-void add_ccs_costs(ccs_matrix *m, int b,int c,int d,int x,int y,int h_o, int co)
-{
- (*m)[c].scc = (*m)[c].scc + d;
- (*m)[c].ticks = (*m)[c].ticks + x;
- (*m)[c].bytes = (*m)[c].bytes + y;
-}
-
-void add_heap_sample_costs(ccs_matrix *m, int b,int c,int d,int x,int y,int h_o, int co)
-{
- heap_sample_matrix *hsm = (*m)[c].hsm;
- if (((*hsm)[h_o].count)==-1)
- (*hsm)[h_o].count = (*hsm)[h_o].count + co + 1; /* as init is -1 */
- else
- (*hsm)[h_o].count = (*hsm)[h_o].count + co;
-}
-
-void add_heap_object(heap_object_matrix *m, int pos, int t, char* des, int tr)
-{
- if (pos>MAX_IDENTIFIERS)
- { fprintf(logFile,"Heap object MAX_IDENTIFIERS exceeded: %i \n",pos); exit(1); }
- (*m)[pos].type = t;
- strcpy((*m)[pos].descriptor,des);
- (*m)[pos].type_constr_ref = tr;
-}
-
-void add_type_constr_object(type_constr_matrix *m, int pos, char* mod, char* n)
-{
- if (pos>MAX_IDENTIFIERS)
- { fprintf(logFile,"Type constructor MAX_IDENTIFIERS exceeded: %i \n",pos); exit(1); }
- strcpy((*m)[pos].module,mod);
- strcpy((*m)[pos].name,n);
-}
-
-
-// Printing routines
-
-void print_heap_update_list(heap_update_list *m, int number)
-{
- int i;
- fprintf(logFile,"[");
- for (i=0; i<number;i++)
- {
- fprintf(logFile," (%i,%i,%i) ",(*m)[i].ccs,(*m)[i].ho,(*m)[i].count);
- }
- fprintf(logFile,"]\n");
-}
-
-void print_TheHeap(TheHeap *h)
-{
- int i;
- fprintf(logFile,"The Heap\n========\n");
- for (i=0; i<MAX_TIME;i++)
- {
- if ((*h)[i].no_samples>0)
- {
- fprintf(logFile,"Sample time %i, number of samples %i actual samples "
- ,i,(*h)[i].no_samples);
- print_heap_update_list((*h)[i].acc_samples,(*h)[i].no_samples);
- }
- }
-}
-
-void PrintXaxis(FILE *HEAP_PROFILE, TheHeap *h)
-{
- int i;
- fprintf(HEAP_PROFILE," ");
- for (i=0; i<MAX_TIME;i++)
- {
- if ((*h)[i].no_samples>0)
- fprintf(HEAP_PROFILE,"%i ",i);
- }
-}
-
-int FindSample(heap_update_list *m, int number, int element)
-{
- int i;
- for (i=0; i<number;i++)
- {
- if ((*m)[i].ho==element)
- return ((*m)[i].count);
- }
- return 0;
-}
-
-void PrintSampleCosts(FILE *hfp, TheHeap *h, int element)
-{
- int i;
- int total = 0;
- for (i=0; i<MAX_TIME;i++)
- {
- if ((*h)[i].no_samples>0)
- {
- total = total + FindSample((*h)[i].acc_samples,(*h)[i].no_samples,element);
- fprintf(hfp," %i ",total);
- }
- }
-}
-
-void print_cc_matrix(cc_matrix *m)
-{
- int i;
- char *blank="blank";
- fprintf(logFile,"Cost centre matrix\n");
- fprintf(logFile,"==================\n");
- for (i=0; i<MAX_IDENTIFIERS; i++)
- { if (strcmp((*m)[i].name,blank)!=0)
- fprintf(logFile,"%s %s %s\n",(*m)[i].name,(*m)[i].module,(*m)[i].group); }
- fprintf(logFile,"\n");
-}
-
-void print_heap_object_matrix(FILE* hfp, TheHeap *h, heap_object_matrix *m)
-{
- int i;
- for (i=0; i<MAX_IDENTIFIERS; i++)
- {
- if (((*m)[i].type)!=-1)
- {
- fprintf(hfp,"Y%i set {",i);
- /* if ((*m)[i].type==1) fprintf(hfp,"data_contr ");
- if ((*m)[i].type==2) fprintf(hfp,"PAP ");
- if ((*m)[i].type==3) fprintf(hfp,"thunk ");
- if ((*m)[i].type==4) fprintf(hfp,"function ");
- if ((*m)[i].type==5) fprintf(hfp,"dictionary ");
- if ((*m)[i].type==1)
- fprintf(hfp,"%s %i ",(*m)[i].descriptor,(*m)[i].type_constr_ref);
- else
- fprintf(hfp,"%s ",(*m)[i].descriptor); */
- PrintSampleCosts(hfp,h,i);
- fprintf(hfp,"}\n");
- }
- }
-}
-
-int number_of_heap_objects(heap_object_matrix *m)
-{
- int i;
- int count = 0;
- for (i=0; i<MAX_IDENTIFIERS; i++)
- {
- if (((*m)[i].type)!=-1) count++;
- }
- return count;
-}
-
-void names_of_heap_objects(FILE *hfp, heap_object_matrix *m)
-{
- int i;
- for (i=0; i<MAX_IDENTIFIERS; i++)
- {
- if (((*m)[i].type)!=-1)
- fprintf(hfp,"Y%i ",i);
- }
- fprintf(hfp,"\n");
-}
-
-void names_and_colour_assignment(FILE *hfp, heap_object_matrix *m)
-{
- int i;
- int colour=0;
- for (i=0; i<MAX_IDENTIFIERS; i++)
- {
- if (((*m)[i].type)!=-1)
- {
- switch(colour)
- {
- case 0 : fprintf(hfp,"%s \t Y%i \t red \t fdiagonal1\n",(*m)[i].descriptor,i);
- colour++; break;
- case 1 : fprintf(hfp,"%s \t Y%i \t blue \t fdiagonal1\n",(*m)[i].descriptor,i);
- colour++; break;
- case 2 : fprintf(hfp,"%s \t Y%i \t green \t fdiagonal1\n",(*m)[i].descriptor,i);
- colour++; break;
- case 3 : fprintf(hfp,"%s \t Y%i \t yellow \t fdiagonal1\n",(*m)[i].descriptor,i);
- colour++; break;
- case 4 : fprintf(hfp,"%s \t Y%i \t pink \t fdiagonal1\n",(*m)[i].descriptor,i);
- colour++; break;
- case 5 : fprintf(hfp,"%s \t Y%i \t goldenrod \t fdiagonal1\n",(*m)[i].descriptor,i);
- colour++; break;
- case 6 : fprintf(hfp,"%s \t Y%i \t orange \t fdiagonal1\n",(*m)[i].descriptor,i);
- colour++; break;
- default: fprintf(hfp,"%s \t Y%i \t purple \t fdiagonal1\n",(*m)[i].descriptor,i);
- colour=0; break;
- }
- }
- }
-}
-
-void print_type_constr_matrix(type_constr_matrix *m)
-{
- int i;
- char *blank="blank";
- fprintf(logFile,"Type constructor matrix\n");
- fprintf(logFile,"=======================\n");
- for (i=0; i<MAX_IDENTIFIERS; i++)
- {
- if (strcmp((*m)[i].name,blank)!=0)
- fprintf(logFile,"%i %s %s\n",i,(*m)[i].module,(*m)[i].name);
- }
-}
-
-void print_heap_sample_matrix(heap_sample_matrix *m)
-{
- int i;
- fprintf(logFile,"HeapSamples[");
- for (i=0; i<MAX_IDENTIFIERS; i++)
- {
- if ((*m)[i].count!=-1) fprintf(logFile,"(%i,%i),",i,(*m)[i].count);
- }
- fprintf(logFile,"]\n");
-}
-
-void print_ccs_matrix(ccs_matrix *m)
-{
- int i;
- fprintf(logFile,"Cost centre stack matrix\n");
- fprintf(logFile,"========================\n");
- for (i=0; i<MAX_IDENTIFIERS; i++)
- { if ((*m)[i].cc!=0)
- {
- fprintf(logFile,"%i %i %i %i %i \n",(*m)[i].cc,(*m)[i].ccs,(*m)[i].scc,
- (*m)[i].ticks,(*m)[i].bytes);
- }
- }
- fprintf(logFile,"\n");
-}
-
-
-/* No longer used */
-
-void FormStack(ccs_matrix *m, cc_matrix *n, int i, char s[])
-{
- int j = i;
- if ((*m)[j].cc != 0)
- {
- strcat(s,(*n)[(*m)[j].cc].name);
- strcat(s," ");
- while ((*m)[j].ccs != (-1))
- {
- strcat(s,(*n)[(*m)[(*m)[j].ccs].cc].name);
- strcat(s,",");
- j = (*m)[j].ccs;
- }
- }
- else fprintf(logFile,"ERROR: Form Stack %i\n",i);
-}
-
-/* This version, which is used, adds the module and group name to the cost centre name*/
-/* This means the cost centre name remains unique when it is textualised and fed into */
-/* daVinci. It also allows the module and group name to be extracted at the display */
-/* level */
-
-void FormStack2(ccs_matrix *m, cc_matrix *n, int i, char s[])
-{
- int j = i;
- if ((*m)[j].cc != 0)
- {
- strcat(s,(*n)[(*m)[j].cc].name);
- strcat(s,"&");
- strcat(s,(*n)[(*m)[j].cc].module);
- strcat(s,"&");
- strcat(s,(*n)[(*m)[j].cc].group);
- strcat(s," ");
- while ((*m)[j].ccs != (-1))
- {
- strcat(s,(*n)[(*m)[(*m)[j].ccs].cc].name);
- strcat(s,"&");
- strcat(s,(*n)[(*m)[(*m)[j].ccs].cc].module);
- strcat(s,"&");
- strcat(s,(*n)[(*m)[(*m)[j].ccs].cc].group);
- strcat(s,",");
- j = (*m)[j].ccs;
- }
- }
- else fprintf(logFile,"ERROR: Form Stack %i\n",i);
-}
-
-void PrintStack(ccs_matrix *m, cc_matrix *n, int i)
-{
- int j = i;
- if ((*m)[j].cc != 0)
- {
- fprintf(logFile,"<");
- fprintf(logFile,"%s,",(*n)[(*m)[j].cc].name);
- while ((*m)[j].ccs != (-1))
- {
- fprintf(logFile,"%s,",(*n)[(*m)[(*m)[j].ccs].cc].name);
- j = (*m)[j].ccs;
- }
- fprintf(logFile,"> ");
- fprintf(logFile,"%i scc %i ticks %i bytes ",
- (*m)[i].scc,(*m)[i].ticks,(*m)[i].bytes);
- print_heap_sample_matrix((*m)[i].hsm);
- }
- else
- { /* fprintf(logFile,"empty stack\n"); */ }
-}
-
-int CountStacks(ccs_matrix *m)
-{
- int j;
- int count = 0;
- for (j=0; j<MAX_IDENTIFIERS;j++) if ((*m)[j].cc != 0) count++;
- return count;
-}
-
-void PrintAllStacks(ccs_matrix *m, cc_matrix *n)
-{
- int i;
- fprintf(logFile,"Stacks\n======\n");
- for (i=0;i<MAX_IDENTIFIERS;i++) { PrintStack(m,n,i); }
-}
-
-
-/* -----------------------------------------------------------------------------
- * TCL Heap profile generator
- * -------------------------------------------------------------------------- */
-
-void produce_HEAP_PROFILE(FILE *HEAP_PROFILE, TheHeap *th, heap_object_matrix *ho_m)
-{
- // First the header information
- fprintf(HEAP_PROFILE,"#!/home/sj/blt2.4o/src/bltwish\n");
- fprintf(HEAP_PROFILE,"package require BLT\n");
- fprintf(HEAP_PROFILE,"if { $tcl_version >= 8.0 } {\n");
- fprintf(HEAP_PROFILE,"\t \t namespace import blt::*\n");
- fprintf(HEAP_PROFILE,"namespace import -force blt::tile::*\n");
- fprintf(HEAP_PROFILE,"}\n");
- fprintf(HEAP_PROFILE,"source scripts/demo.tcl\n");
- fprintf(HEAP_PROFILE,"proc FormatXTicks { w value } {\n");
- fprintf(HEAP_PROFILE,"\t \t set index [expr round($value)]\n");
- fprintf(HEAP_PROFILE,"\t \t if { $index != $value } {\n");
- fprintf(HEAP_PROFILE,"\t \t \t return $value\n");
- fprintf(HEAP_PROFILE,"\t \t}\n");
- fprintf(HEAP_PROFILE,"incr index -1\n");
-
- // Now the code to generate the units in the X axis
-
- fprintf(HEAP_PROFILE,"set name [lindex { ");
- PrintXaxis(HEAP_PROFILE,th);
- fprintf(HEAP_PROFILE," } $index]\n");
-
- fprintf(HEAP_PROFILE,"return $name\n");
- fprintf(HEAP_PROFILE,"}\n");
-
- // more general graph stuff
-
- fprintf(HEAP_PROFILE,"source scripts/stipples.tcl\n");
- fprintf(HEAP_PROFILE,"image create photo bgTexture -file ./images/chalk.gif\n");
- fprintf(HEAP_PROFILE,"option add *Button.padX 5\n");
- fprintf(HEAP_PROFILE,"option add *tile bgTexture\n");
- fprintf(HEAP_PROFILE,"option add *Radiobutton.font -*-courier*-medium-r-*-*-14-*-*\n");
- fprintf(HEAP_PROFILE,"option add *Radiobutton.relief flat\n");
- fprintf(HEAP_PROFILE,"option add *Radiobutton.borderWidth 2\n");
- fprintf(HEAP_PROFILE,"option add *Radiobutton.highlightThickness 0\n");
- fprintf(HEAP_PROFILE,"option add *Htext.font -*-times*-bold-r-*-*-14-*-*\n");
- fprintf(HEAP_PROFILE,"option add *Htext.tileOffset no\n");
- fprintf(HEAP_PROFILE,"option add *header.font -*-times*-medium-r-*-*-14-*-*\n");
- fprintf(HEAP_PROFILE,"option add *Barchart.font -*-helvetica-bold-r-*-*-14-*-*\n");
-
- fprintf(HEAP_PROFILE,"option add *Barchart.title \"Heap profile of program ");
- // TO DO: Add program name in here
- fprintf(HEAP_PROFILE,"\"\n");
-
- fprintf(HEAP_PROFILE,"option add *Axis.tickFont -*-helvetica-medium-r-*-*-12-*-*\n");
- fprintf(HEAP_PROFILE,"option add *Axis.titleFont -*-helvetica-bold-r-*-*-12-*-*\n");
- fprintf(HEAP_PROFILE,"option add *x.Command FormatXTicks\n");
- fprintf(HEAP_PROFILE,"option add *x.Title \"Time (seconds)\"\n");
- fprintf(HEAP_PROFILE,"option add *y.Title \"Heap usage (000 bytes)\"\n");
- fprintf(HEAP_PROFILE,"option add *activeBar.Foreground pink\noption add *activeBar.stipple dot3\noption add *Element.Background red\noption add *Element.Relief raised\n");
- fprintf(HEAP_PROFILE,"option add *Grid.dashes { 2 4 }\noption add *Grid.hide no\noption add *Grid.mapX \"\"\n");
- fprintf(HEAP_PROFILE,"option add *Legend.Font \"-*-helvetica*-bold-r-*-*-12-*-*\"\noption add *Legend.activeBorderWidth 2\noption add *Legend.activeRelief raised \noption add *Legend.anchor ne \noption add *Legend.borderWidth 0\noption add *Legend.position right\n");
- fprintf(HEAP_PROFILE,"option add *TextMarker.Font *Helvetica-Bold-R*14*\n");
- fprintf(HEAP_PROFILE,"set visual [winfo screenvisual .] \nif { $visual != \"staticgray\" && $visual != \"grayscale\" } {\n option add *print.background yellow\n option add *quit.background red\n option add *quit.activeBackground red2\n}\n");
- fprintf(HEAP_PROFILE,"htext .title -text {\n Heap profile\n}\n");
- fprintf(HEAP_PROFILE,"htext .header -text {\n %%%% \n");
- fprintf(HEAP_PROFILE," radiobutton .header.stacked -text stacked -variable barMode \\\n -anchor w -value \"stacked\" -selectcolor red -command {\n .graph configure -barmode $barMode\n } \n .header append .header.stacked -width 1.5i -anchor w\n");
- fprintf(HEAP_PROFILE," %%%% Heap usage stacked: overall height is the sum of the heap used. \n %%%% \n");
- fprintf(HEAP_PROFILE," radiobutton .header.aligned -text aligned -variable barMode \\\n -anchor w -value \"aligned\" -selectcolor yellow -command {\n .graph configure -barmode $barMode }\n .header append .header.aligned -width 1.5i -fill x\n");
- fprintf(HEAP_PROFILE," %%%% Heap usage components displayed side-by-side.\n %%%%\n");
- fprintf(HEAP_PROFILE," radiobutton .header.overlap -text \"overlap\" -variable barMode \\\n -anchor w -value \"overlap\" -selectcolor green -command {\n .graph configure -barmode $barMode\n }\n .header append .header.overlap -width 1.5i -fill x\n");
- fprintf(HEAP_PROFILE," %%%% Heap usage shown as an overlapped histogram.\n %%%%\n");
- fprintf(HEAP_PROFILE," radiobutton .header.normal -text \"normal\" -variable barMode \\\n -anchor w -value \"normal\" -selectcolor blue -command {\n .graph configure -barmode $barMode\n }\n .header append .header.normal -width 1.5i -fill x\n");
- fprintf(HEAP_PROFILE," %%%% Heap components overlayed one on top of the next. \n}\n");
- fprintf(HEAP_PROFILE,"htext .footer -text { To create a postscript file \"heap_profile.ps\", press the %%%%\n button $htext(widget).print -text print -command {\n puts stderr [time {.graph postscript output heap_profile.ps}]\n }\n $htext(widget) append $htext(widget).print\n%%%% button.}\n");
- fprintf(HEAP_PROFILE,"barchart .graph -tile bgTexture\n");
-
- // This is where the actual data comes in
-
- fprintf(HEAP_PROFILE,"vector X ");
- names_of_heap_objects(HEAP_PROFILE,ho_m);
- fprintf(HEAP_PROFILE,"\nX set { ");
- PrintXaxis(HEAP_PROFILE,th);
- fprintf(HEAP_PROFILE," }\n");
-
- print_heap_object_matrix(HEAP_PROFILE,th, ho_m);
-
- // NAMES FOR THE ATTRIBUTES
- fprintf(HEAP_PROFILE,"set attributes {\n");
- names_and_colour_assignment(HEAP_PROFILE,ho_m);
- fprintf(HEAP_PROFILE,"}\n");
-
- fprintf(HEAP_PROFILE,"foreach {label yData color stipple} $attributes {\n .graph element create $yData -label $label -bd 1 \\\n -ydata $yData -xdata X -fg ${color}3 -bg ${color}1 -stipple $stipple\n}\n");
- fprintf(HEAP_PROFILE,".header.stacked invoke\n");
- fprintf(HEAP_PROFILE,"scrollbar .xbar -command { .graph axis view x } -orient horizontal\nscrollbar .ybar -command { .graph axis view y } -orient vertical\n.graph axis configure x -scrollcommand { .xbar set } -logscale no -loose no\n.graph axis configure y -scrollcommand { .ybar set } -logscale no -loose no\n");
- fprintf(HEAP_PROFILE,"table . \\\n 0,0 .title -fill x \\\n 1,0 .header -fill x \\\n 2,0 .graph -fill both \\\n 3,0 .xbar -fill x \\\n 5,0 .footer -fill x\n");
- fprintf(HEAP_PROFILE,"table configure . r0 r1 r3 r4 r5 -resize none\n");
- fprintf(HEAP_PROFILE,"Blt_ZoomStack .graph\nBlt_Crosshairs .graph\nBlt_ActiveLegend .graph\nBlt_ClosestPoint .graph\n");
- fprintf(HEAP_PROFILE,".graph marker bind all <B2-Motion> {\n set coords [%%W invtransform %%x %%y]\n catch { %%W marker configure [%%W marker get current] -coords $coords }\n}\n.graph marker bind all <Enter> {\n set marker [%%W marker get current]\n catch { %%W marker configure $marker -bg green}\n}\n.graph marker bind all <Leave> {\n set marker [%%W marker get current]\n catch { %%W marker configure $marker -bg \"\"}\n}\n");
-
-}
-
-
-/* -----------------------------------------------------------------------------
- * Read and create the raw profile data structure
- * -------------------------------------------------------------------------- */
-
-/* void readRawProfile(FILE *fptr,int *nonodes) { */
-
-void readRawProfile(FILE *fp,int *nonodes, int MaxNoNodes) {
- char stack[MAX_PROFILE_LINE_LENGTH];
- int i,nolines,sstepline,syncs;
- char *ptr,*drag;
-
- float comp_max, comp_avg, comp_min, /* SYNCS */
- comm_max, comm_avg, comm_min, /* COMP */
- comp_idle_max, comp_idle_avg, comp_idle_min; /* COMM */
-
- /* Cost relationships are comp=scc, comm=ticks, comp_idle=bytes */
-
- long int hmax,havg,hmin; /* COMPIDLE */
-
- /* set to zero for now. Might use these later for heap costs. */
-
- /* GHC specific variables */
-
- int a,b,c,d,x,z,count, next;
- int newloop;
- char e[MAX_STRING_SIZE];
- char f[MAX_STRING_SIZE];
- char lline[MAX_PROFILE_LINE_LENGTH];
-
- /* identifiers generated by the XML handler */
- char *ccentre=">>cost_centre";
- char *ccstack=">>cost_centre_stack";
- char *sccsample=">>scc_sample";
- char *heapsample=">>heap_sample";
- char *heapupdate=">>heap_update";
- char *heapobject=">>heap_object";
- char *typeconstr=">>type_constr";
- char *ending=">>";
-
- /* FILE *fp; */
-
- cc_matrix *cc_m;
- ccs_matrix *ccs_m;
- heap_object_matrix *ho_m;
- type_constr_matrix *tc_m;
- TheHeap *th;
-
- FILE *HEAP_PROFILE;
-
- HEAP_PROFILE = fopen("GHCbarchart.tcl", "w");
- if (HEAP_PROFILE == NULL){
- fprintf(stderr,"tcl script generator: ERROR- GHCbarchart.tcl cannot be created\a\n");
- exit(1);
- }
-
- th = (p_TheHeap) malloc (sizeof(TheHeap));
- cc_m = (p_cc_matrix) malloc (sizeof(cc_matrix));
- //cc_m = (p_cc_matrix) calloc(MAX_IDENTIFIERS,sizeof(_cc_));
- ccs_m = (p_ccs_matrix) malloc (sizeof(ccs_matrix));
- ho_m = (p_heap_object_matrix) malloc (sizeof(heap_object_matrix));
- tc_m = (p_type_constr_matrix) malloc (sizeof(type_constr_matrix));
-
- /* End of GHC specific variables */
-
- //fprintf(logFile,"Number 1 %i \n",MAX_IDENTIFIERS*sizeof(_cc_));
- //fprintf(logFile,"Number 2 %i \n",sizeof(cc_matrix));
-
- nolines=0; /* Number of lines read in from profile log file */
-
- /* GHC specific */
- count = 0;
- next = 0;
-
- initialise_cc_matrix(cc_m);
- initialise_ccs_matrix(ccs_m);
- initialise_heap_object_matrix(ho_m);
- initialise_type_constr_matrix(tc_m);
- initialise_TheHeap(th);
-
- fprintf(logFile,"MAX_IDENTIFIERS = %i \n",MAX_IDENTIFIERS);
-
- /* end GHC specific */
-
- /* CAF fixing */
- fill_cc_matrix(cc_m,"CAF:REPOSITORY","PROFILER","PROFILER",MAX_IDENTIFIERS-1);
- fill_ccs_matrix(ccs_m,MAX_IDENTIFIERS-1,1,0.0,0.0,0.0,0,-1,MAX_IDENTIFIERS-1);
-
- /*
-
- This builds a node in the graph called CAF:REPOSITORY, which can be
- found off the root node. All CAFs are subsequently hung from this node
- which means the node node can be hidden using the abstraction
- mechanisms provided by daVinci.
-
- */
-
-
- /* This is the GHC file handler which reads the lines from the profile log file and */
- /* puts the stack and cost information in the raw profile data structure */
-
- while (fscanf(fp,"%s",lline))
- {
- /* Kill the end of the logfile with the ">>" string */
- if (strcmp(lline,ending)==0) break;
-
- /* Deal with the cost centres */
- if (strcmp(ccentre,lline)==0)
- {
- next = fgetc(fp);
- //while (fscanf(fp," %i %[^ ] %[^ ] %s", &z, e, f, g)!=0)
- while (fscanf(fp," %i %[^ ] %s", &z, e, f)!=0)
- {
- fprintf(logFile,"Declaring cost centre `%i %s %s %s' \n",z,e,f,f);
- fflush(logFile);
- fill_cc_matrix(cc_m,e,f,f,z);
- next = fgetc(fp);
- }
- }
- else
- {
-
- /* Deal with the cost centre stacks */
- if (strcmp(ccstack,lline)==0)
- {
- next = fgetc(fp);
- while (fscanf(fp,"%i %i %i",&a,&d,&b)!=0)
- {
- if (d==1) /* of size one */
- {
- fprintf(logFile,"Declaring cost centre stack `%i %i %i'\n",a,d,b);
- fill_ccs_matrix(ccs_m,b,-1,(*ccs_m)[a].scc,(*ccs_m)[a].ticks,(*ccs_m)[a].bytes,0,-1,a);
- }
- if (d==2) /* of size > 1 */
- {
- fscanf(fp," %i",&c);
-
- /* CAF fixing */
- fprintf(logFile,"Declaring cost centre stack `%i %i %i %i'\n",a,d,b,c);
- if ((c==1)&&!(strncmp((*cc_m)[b].name,"CAF",2)))
- // fill_ccs_matrix(ccs_m,b,MAX_IDENTIFIERS-1,(*ccs_m)[a].scc,(*ccs_m)[a].ticks,(*ccs_m)[a].bytes,0,-1,a);
- /* The line above hangs all CAFs off the CAF:REPOSITORY node
- in the daVinci graph. For programs which have a small
- number of CAFs this works nicely. However, when the
- number of CAFs become very large (eg +200) then the
- daVinci graph begins to look horid and, after (say)
- +500 CAF nodes, becomes very slow to load. So to
- fix this we replace the code with the line below.
- */
- if (!(strncmp((*cc_m)[b].name,"CAF:main",7)))
- /* Treat CAF:main as a normal node */
- fill_ccs_matrix(ccs_m,b,c,(*ccs_m)[a].scc,(*ccs_m)[a].ticks,(*ccs_m)[a].bytes,0,-1,a);
- /* merge the rest */
- else
- //add_ccs_costs(ccs_m,0,MAX_IDENTIFIERS-1,(*ccs_m)[a].scc,(*ccs_m)[a].ticks,(*ccs_m)[a].bytes,0,0);
- fill_ccs_matrix(ccs_m,MAX_IDENTIFIERS-1,1,(*ccs_m)[a].scc,(*ccs_m)[a].ticks,(*ccs_m)[a].bytes,0,-1,a);
- /* This does not even bother registering the new CAFs
- as daVinci nodes, but instead just merges the CAF
- with the CAF:REPOSITORY node. This greatly reduces
- the number of CAFs daVinci has to deal with, though
- may make the graph look a little different!
-
- Also note that now Simon has changed the semantics,
- you will want to treat adding CAF nodes in a
- different way to adding normal program nodes
- */
- else
- /* Normal mode */
- fill_ccs_matrix(ccs_m,b,c,(*ccs_m)[a].scc,(*ccs_m)[a].ticks,(*ccs_m)[a].bytes,0,-1,a);
- }
- next = fgetc(fp);
- }
- }
- else
- {
-
- /* Deal with the scc_samples */
- if (strcmp(sccsample,lline)==0)
- {
- next = fgetc(fp);
- while (fscanf(fp,"%i %i %i %i",&a,&d,&b,&c))
- {
- fprintf(logFile,"Loading scc_samples `%i %i %i %i'\n",a,d,b,c);
- add_ccs_costs(ccs_m,0,a,d,b,c,0,0);
- next = fgetc(fp);
- }
- } /* end sccsample if */
- else
- {
-
- /* Deal with the heap samples */
- if (strcmp(heapsample,lline)==0)
- {
- next = fgetc(fp);
- while (fscanf(fp,"%i %i %i",&a,&d,&b))
- {
- fprintf(logFile,"Loading heap_samples `%i %i %i'\n",a,d,b);
- add_heap_sample_costs(ccs_m,0,a,0,0,0,d,b);
- next = fgetc(fp);
- }
- } /* end heapsample if */
- else
- {
-
- /* Deal with the heap objects */
- if (strcmp(heapobject,lline)==0)
- {
- next = fgetc(fp);
- while (fscanf(fp,"%i %i",&a,&d))
- {
- if (d==1)
- {
- fscanf(fp," %s %i",e,&b);
- add_heap_object(ho_m,a,d,e,b);
- }
- else
- {
- fscanf(fp," %s",e);
- add_heap_object(ho_m,a,d,e,-1);
- }
- next = fgetc(fp);
- }
- } /* end heapobject if */
- else
- {
-
- /* Deal with the type constructors */
- if (strcmp(typeconstr,lline)==0)
- {
- next = fgetc(fp);
- while (fscanf(fp,"%i %s %s",&a,e,f))
- {
- add_type_constr_object(tc_m,a,e,f);
- next = fgetc(fp);
- }
- } /* end type constructor if */
- else
- {
-
- /* Deal with the heap_updates */
- if (strcmp(heapupdate,lline)==0)
- {
- next = fgetc(fp);
- while (fscanf(fp,"%i %i %i %i %i %i",&a,&d,&b,&c,&z,&x))
- {
- add_to_TheHeap(th,a,b,c,z);
- fprintf(logFile,"Adding heap sample %i %i %i %i\n",a,b,c,z);
- while (x) /* more than one sample */
- {
- fscanf(fp," %i %i %i %i",&b,&c,&z,&x);
- add_to_TheHeap(th,a,b,c,z);
- fprintf(logFile,"Adding heap sample %i %i %i %i\n",a,b,c,z);
- }
- next = fgetc(fp);
- }
-
- } /* end heap update if */
-
- } /* end type constructor else */
-
- } /* end heapobject else */
-
- } /* end heapsample else */
- } /* end sccsample else */
- } /* end ccstack else */
- } /* end ccstack if */
- } /* end while */
-
- print_cc_matrix(cc_m);
- print_ccs_matrix(ccs_m);
- fprintf(logFile,"There are %i stacks\n",CountStacks(ccs_m));
- print_type_constr_matrix(tc_m);
-
- /* Functions for heap profile */
- print_TheHeap(th);
- fprintf(logFile,"The units for the x axis are \n");
- PrintXaxis(logFile,th);
- fprintf(logFile,"\n");
- fprintf(logFile,"There are %i distinct heap objects\n",number_of_heap_objects(ho_m));
- names_of_heap_objects(logFile,ho_m);
- names_and_colour_assignment(logFile,ho_m);
- print_heap_object_matrix(logFile,th,ho_m);
-
- PrintAllStacks(ccs_m,cc_m);
- /* comment out line below to remove the heap profile generator */
- produce_HEAP_PROFILE(HEAP_PROFILE,th,ho_m);
- fclose(HEAP_PROFILE);
-
- /* End of GHC file handler */
-
-
- /* Now process the stack matrix */
-
- for (newloop=0;newloop<MAX_IDENTIFIERS;newloop++)
- { if ((*ccs_m)[newloop].cc != 0)
- {
-
- sstepline = 0;
- FormStack2(ccs_m,cc_m,newloop,stack);
-
- syncs = 0;
- comp_max = (float)(*ccs_m)[newloop].scc;
- comp_avg = (float)(*ccs_m)[newloop].scc;
- comp_min = (float)(*ccs_m)[newloop].scc;
- comm_max = (float)(*ccs_m)[newloop].ticks;
- comm_avg = (float)(*ccs_m)[newloop].ticks;
- comm_min = (float)(*ccs_m)[newloop].ticks;
- comp_idle_max = (float)(*ccs_m)[newloop].bytes;
- comp_idle_avg = (float)(*ccs_m)[newloop].bytes;
- comp_idle_min = (float)(*ccs_m)[newloop].bytes;
- hmax = 0.0; havg = 0.0; hmin = 0.0;
-
- /* Dynamic memory allocation for raw_profile data structure */
-
- if (raw_profile_next==raw_profile_size) enlargeRawProfile();
-
- /* Assign data from single logfile entry to raw_profile data structure */
- /* this deals with the cost metrics */
-
- raw_profile[raw_profile_next].active = 1;
- raw_profile[raw_profile_next].cost.syncs = syncs;
- raw_profile[raw_profile_next].cost.comp_max = comp_max;
- raw_profile[raw_profile_next].cost.comp_avg = comp_avg;
- raw_profile[raw_profile_next].cost.comp_min = comp_min;
- raw_profile[raw_profile_next].cost.comm_max = comm_max;
- raw_profile[raw_profile_next].cost.comm_avg = comm_avg;
- raw_profile[raw_profile_next].cost.comm_min = comm_min;
- raw_profile[raw_profile_next].cost.comp_idle_max= comp_idle_max;
- raw_profile[raw_profile_next].cost.comp_idle_avg= comp_idle_avg;
- raw_profile[raw_profile_next].cost.comp_idle_min= comp_idle_min;
- raw_profile[raw_profile_next].cost.hrel_max = hmax;
- raw_profile[raw_profile_next].cost.hrel_avg = havg;
- raw_profile[raw_profile_next].cost.hrel_min = hmin;
-
- /* this deals with the stack itself */
-
- raw_profile[raw_profile_next].stack=calloc(MAX_STACK_DEPTH,
- sizeof(int));
- if (raw_profile[raw_profile_next].stack==NULL) {
- fprintf(stderr,"{readRawProfile} unable to allocate stack entry");
- exit(1);
- }
-
- fprintf(logFile,"STACK=\"%s\"\n",stack);
- raw_profile[raw_profile_next].stack_size=1;
- /* move the stack read frame to the first space (or comma) in the stack string */
- for(ptr=stack; ((*ptr)!=' ') && (*ptr!=',');ptr++) {}
- fprintf(logFile,"TOS=%d at line %d\n",*ptr,sstepline);
-
- /* to distinguish the head of the stack from the rest */
- /* if read frame points to space you are at the head of the stack */
- if (*ptr==' ')
- /* raw_profile[raw_profile_next].stack[0]
- =lookupSymbolTable(CG_SSTEP,sstepline,(*ptr='\0',stack)); */
- /* This line has changed as GHC treats its cost-centres in a different */
- /* way to BSP. There is no distinction between 'a cost centre at line x' */
- /* and a normal cost centre. The fix is easy, just treat all cost centres, */
- /* even those at the head of the stack in the same way. */
- raw_profile[raw_profile_next].stack[0]
- =lookupSymbolTable(CG_STACK,sstepline,(*ptr='\0',stack));
- else
- /* otherwise you are looking at just another stack element */
- raw_profile[raw_profile_next].stack[0]
- =lookupSymbolTable(CG_STACK,sstepline,(*ptr='\0',stack));
-
- ptr++; /* move the read frame on one */
- drag=ptr;
- for(;*ptr;ptr++) { /* find the next element in the stack */
- if (*ptr==',') {
- *ptr='\0';
- if (Verbose) fprintf(logFile,"NAME=\"%s\"\n",drag); /* name of the next element */
- if (!ignore_function(drag)) {
- raw_profile[raw_profile_next].stack[
- raw_profile[raw_profile_next].stack_size++]
- = lookupSymbolTable(CG_STACK,0,drag); /* add element to the raw_profile */
- }
- drag = ptr+1;
- }
- }
-
- /* create cost object */
-
- raw_profile[raw_profile_next].cost.proc
- =calloc(bsp_p,sizeof(object_cost_proc));
- if (raw_profile[raw_profile_next].cost.proc==NULL) {
- fprintf(stderr,"Unable to allocate storage");
- exit(0);
- }
-
- /* process the HREL information - one set for every BSP process */
-
- for(i=0;i<bsp_p;i++) {
-
- raw_profile[raw_profile_next].cost.proc[i].proc_comp = 0.0;
- raw_profile[raw_profile_next].cost.proc[i].proc_comm = 0.0;
- raw_profile[raw_profile_next].cost.proc[i].proc_comp_idle= 0.0;
- raw_profile[raw_profile_next].cost.proc[i].proc_hrel_in = 0;
- raw_profile[raw_profile_next].cost.proc[i].proc_hrel_out = 0;
-
- }
-
- raw_profile_next++; /* Increase the raw profile data structure counter */
- nolines++; /* Increase the number of lines read */
-
- strcpy(stack,""); /* reset the stack */
- } /* end of new if statement */
- } /* end of new for loop */
-
- *nonodes = symbol_table_next;
- fprintf(logFile,"%s: read %d lines from profile.Graph contains %i nodes.\n",
- Pgm,nolines,symbol_table_next);
-
- free_cc_matrix(cc_m); /* be nice and clean up the cost centre matrix */
-}
-
-/* -----------------------------------------------------------------------------
- * Pretty print the raw profile data
- * -------------------------------------------------------------------------- */
-
-void printRawProfile() {
- int i,j;
- object_cost *cost;
- int *stack;
-
- fprintf(logFile,"\n\nRAW DATA:\n");
- for(i=0;i<raw_profile_next;i++) {
- cost = &raw_profile[i].cost;
- stack = raw_profile[i].stack;
- fprintf(logFile,"Stack=[");
- for(j=0;j<raw_profile[i].stack_size;j++)
- printSymbolTable_entry(stack[j]);
- fprintf(logFile,"] %d Syncs %f Comp %f Comm %f Wait\n\n",
- cost->syncs,cost->comp_max,cost->comm_max,cost->comp_idle_max);
- }
-}
-
-/* -----------------------------------------------------------------------------
- * Create connectivity matrix
- * -------------------------------------------------------------------------- */
-
-void createConnectivityMatrix(int NoNodes,Matrix *graph,
- Matrix *costs,int *root, int inherit) {
- object_cost zero_cost,*update;
- int i,j,this,next;
-
-
- zero_cost.comp_max =0.0;
- zero_cost.comp_avg =0.0;
- zero_cost.comp_min =0.0;
- zero_cost.comm_max =0.0;
- zero_cost.comm_avg =0.0;
- zero_cost.comm_min =0.0;
- zero_cost.comp_idle_max=0.0;
- zero_cost.comp_idle_avg=0.0;
- zero_cost.comp_idle_min=0.0;
- zero_cost.hrel_max =0;
- zero_cost.hrel_avg =0;
- zero_cost.hrel_min =0;
- zero_cost.syncs=0;
- zero_cost.proc = NULL;
- *graph = newMat(NoNodes,NoNodes,sizeof(int),(i=0,&i));
- *costs = newMat(NoNodes,1,sizeof(object_cost),&zero_cost);
- for(i=0;i<NoNodes;i++) {
- update=&Mat(object_cost,*costs,i,0);
- update->proc=calloc(bsp_p,sizeof(object_cost_proc));
- if (update->proc==NULL){
- fprintf(stderr,"Unable to allocate storage");
- exit(0);
- }
- for(j=0;j<bsp_p;j++) {
- update->proc[j].proc_comp =0.0;
- update->proc[j].proc_comm =0.0;
- update->proc[j].proc_comp_idle =0.0;
- update->proc[j].proc_hrel_in =0;
- update->proc[j].proc_hrel_out =0;
- }
- }
-
- for(i=0;i<raw_profile_next;i++) {
- if (raw_profile[i].active) {
- this = raw_profile[i].stack[0];
- next = this;
- Mat(int,*graph,this,next) = 1;
- update = &Mat(object_cost,*costs,next,0);
- add_costs(update,raw_profile[i].cost);
- for(j=1;j<raw_profile[i].stack_size;j++) {
- this = next;
- next = raw_profile[i].stack[j];
- Mat(int,*graph,next,this)=1;
- update = &Mat(object_cost,*costs,next,0);
- /* include this line for INHERITANCE; remove it for not! */
- if (inherit) add_costs(update,raw_profile[i].cost);
- }
- }
- }
- *root = raw_profile[0].stack[raw_profile[0].stack_size-1];
-
- /* Check graph isn't empty */
- if (!Mat_dense(*costs,*root,0)) *root=-1;
-}
-
-void printConnectivityMatrix(Matrix graph,Matrix costs,int root) {
- int i,j;
- object_cost cost;
-
- fprintf(logFile,"Root node is %d\n",root);
- for(i=0;i<graph.rows;i++) {
- fprintf(logFile,"%4d)",i);
- printSymbolTable_entry(i);
- cost = Mat(object_cost,costs,i,0);
- fprintf(logFile,"%d %f %f %f\n\tBranch=[",
- cost.syncs,cost.comp_max,cost.comm_max,cost.comp_idle_max);
- for(j=0;j<graph.cols;j++)
- if (Mat_dense(graph,i,j)) fprintf(logFile,"%d ",j);
- fprintf(logFile,"]\n\n");
- }
-}
diff --git a/ghc/utils/prof/cgprof/cgprof.h b/ghc/utils/prof/cgprof/cgprof.h
deleted file mode 100644
index e93f02b53e..0000000000
--- a/ghc/utils/prof/cgprof/cgprof.h
+++ /dev/null
@@ -1,82 +0,0 @@
-/* ------------------------------------------------------------------------
- * $Id: cgprof.h,v 1.2 2003/08/01 14:50:50 panne Exp $
- *
- * Copyright (C) 1995-2000 University of Oxford
- *
- * Permission to use, copy, modify, and distribute this software,
- * and to incorporate it, in whole or in part, into other software,
- * is hereby granted without fee, provided that
- * (1) the above copyright notice and this permission notice appear in
- * all copies of the source code, and the above copyright notice
- * appear in clearly visible form on all supporting documentation
- * and distribution media;
- * (2) modified versions of this software be accompanied by a complete
- * change history describing author, date, and modifications made;
- * and
- * (3) any redistribution of the software, in original or modified
- * form, be without fee and subject to these same conditions.
- * --------------------------------------------------------------------- */
-
-#include <stdlib.h>
-#include <stdio.h>
-#include <limits.h>
-#include "symbol.h"
-#include "matrix.h"
-
-/* -----------------------------------------------------------------------------
- * Data structures associated with parsed data
- * -------------------------------------------------------------------------- */
-
-/* -----------------------------------------------------------------------------
- * Cost attributes
- * -------------------------------------------------------------------------- */
-
-#ifndef _CGPROF_H_
-#define _CGPROF_H_
-
-typedef struct {
- double proc_comp;
- double proc_comm;
- double proc_comp_idle;
- long int proc_hrel_in;
- long int proc_hrel_out;
-} object_cost_proc;
-
-typedef struct {
- double comp_max, comp_avg, comp_min;
- double comm_max, comm_avg, comm_min;
- double comp_idle_max, comp_idle_avg, comp_idle_min;
- long int hrel_max, hrel_avg, hrel_min;
- object_cost_proc *proc;
- int syncs;
-} object_cost;
-
-/* -----------------------------------------------------------------------------
- * Sequence of cost centres
- * -------------------------------------------------------------------------- */
-
-typedef struct {
- object_cost cost;
- name_id *stack;
- int stack_size;
- int active;
-} parsed_cost_object;
-
-#define RAW_PROFILE_INIT_SIZE 100
-extern int raw_profile_next;
-extern int raw_profile_size;
-extern parsed_cost_object *raw_profile;
-
-/* -----------------------------------------------------------------------------
- * Misc.
- * -------------------------------------------------------------------------- */
-
-extern int Verbose;
-extern char *Pgm;
-extern void readRawProfile(FILE *,int*,int);
-extern void printRawProfile();
-extern void add_costs(object_cost *,object_cost);
-extern void createConnectivityMatrix(int,Matrix *,Matrix *,int *,int);
-extern void printConnectivityMatrix(Matrix,Matrix,int);
-extern FILE* logFile;
-#endif
diff --git a/ghc/utils/prof/cgprof/daVinci.c b/ghc/utils/prof/cgprof/daVinci.c
deleted file mode 100644
index 0a59d1c89e..0000000000
--- a/ghc/utils/prof/cgprof/daVinci.c
+++ /dev/null
@@ -1,760 +0,0 @@
-/* ------------------------------------------------------------------------
- * $Id: daVinci.c,v 1.5 2006/01/09 14:38:01 simonmar Exp $
- *
- * Copyright (C) 1995-2000 University of Oxford
- *
- * Permission to use, copy, modify, and distribute this software,
- * and to incorporate it, in whole or in part, into other software,
- * is hereby granted without fee, provided that
- * (1) the above copyright notice and this permission notice appear in
- * all copies of the source code, and the above copyright notice
- * appear in clearly visible form on all supporting documentation
- * and distribution media;
- * (2) modified versions of this software be accompanied by a complete
- * change history describing author, date, and modifications made;
- * and
- * (3) any redistribution of the software, in original or modified
- * form, be without fee and subject to these same conditions.
- * --------------------------------------------------------------------- */
-
-#include "daVinci.h"
-#include <stdarg.h>
-#include <string.h>
-#include <ctype.h>
-
-static char* extra_space(int);
-static void recur_graphToDaVinci(int,Matrix *, Matrix *,char*,int);
-static char *parse_word(char**);
-static char *parse_quoted(char**);
-static char *dup_str(char*);
-double this_total_time,
- this_total_comp_max, this_total_comp_avg,
- this_total_comm_max, this_total_comm_avg,
- this_total_comp_idle_max, this_total_comp_idle_avg;
-long int this_hrel_max, this_hrel_avg;
-int this_syncs;
-
-char *lastDavinciCmd;
-
-/* -----------------------------------------------------------------------------
- * Send a command with ok return value daVinci
- * -------------------------------------------------------------------------- */
-
-void cmdDaVinci(char* format,...) {
- va_list args;
-
- va_start(args, format);
- vfprintf(stdout, format, args);
- fprintf(stdout, "\n");
- va_end(args);
- fflush(stdout);
- lastDavinciCmd = format;
-}
-
-/* -----------------------------------------------------------------------------
- * Initialise daVinci
- * -------------------------------------------------------------------------- */
-
-void initDaVinci() {
- cmdDaVinci("window(title(\"GHC profiler: cost-centre-stack view\"))\n");
- cmdDaVinci("set(font_size(8))");
- cmdDaVinci("set(animation_speed(0))");
- cmdDaVinci("set(scrolling_on_selection(false))");
- /* SAJ */
- /* cmdDaVinci("set(no_cache(true)))"); */
- cmdDaVinci("app_menu(create_icons(["
- "icon_entry(\"delete\","
- "\"delete.xbm\","
- "\"Delete node and its children\"),"
- "icon_entry(\"undo\","
- "\"undo.xbm\","
- "\"Undo delete\"),"
- "blank,"
- "icon_entry(\"time\","
- "\"time.xbm\","
- "\"Cost metric view\"),"
- "icon_entry(\"percent\","
- "\"percent.xbm\","
- "\"Percentage view\"),"
- "blank,"
- "icon_entry(\"compress\","
- "\"compress.xbm\","
- "\"Compressed node view\"),"
- "icon_entry(\"uncompress\","
- "\"uncompress.xbm\","
- "\"Uncompressed node view\"),"
- "blank,"
- "icon_entry(\"absolute\","
- "\"absolute.xbm\","
- "\"Display inherited profile results\"),"
- "icon_entry(\"absdelta\","
- "\"absdelta.xbm\","
- "\"Display flat profile results\"),"
- "icon_entry(\"reldelta\","
- "\"reldelta.xbm\","
- "\"Trim zero-cost sub-trees\"),"
- "icon_entry(\"weightdelta\","
- "\"weightdelta.xbm\","
- "\"Trim zero-cost nodes\"),"
- "blank,"
- "icon_entry(\"sync\","
- "\"sync.xbm\","
- "\"Graph view\"),"
- "icon_entry(\"comp\","
- "\"comp.xbm\","
- "\"SCCs critical path\"),"
- "icon_entry(\"comm\","
- "\"comm.xbm\","
- "\"Computation time critical path\"),"
- "icon_entry(\"wait\","
- "\"wait.xbm\","
- "\"Heap usage critical path\"),"
- "icon_entry(\"hrel\","
- "\"hrel.xbm\","
- "\"Node spy\"),"
- "blank,"
- "icon_entry(\"help\","
- "\"help.xbm\","
- "\"Help\"),"
- "]))");
-
- activateDaVinciMenu("default");
- cmdDaVinci("app_menu(create_menus([menu_entry_mne(\"jump\",\"Goto a node\",\"G\",control,\"G\")]))\n");
- /* SAJ */
- // cmdDaVinci("app_menu(activate_menus([\"jump\"]))");
-}
-
-/* -----------------------------------------------------------------------------
- * Menu FSM
- * -------------------------------------------------------------------------- */
-
-void activateDaVinciMenu(char *pressed) {
- static int compress=1,time=1,critical_type=0,critical=0,undo=1,delete=0;
-
- if (strcmp(pressed,"absolute")==0) critical_type=0;
- if (strcmp(pressed,"absdelta")==0) critical_type=1;
- if (strcmp(pressed,"reldelta")==0) critical_type=2;
- if (strcmp(pressed,"weightdelta")==0) critical_type=3;
-
- if (strcmp(pressed,"sync")==0) critical=0;
- if (strcmp(pressed,"comp")==0) critical=1;
- if (strcmp(pressed,"comm")==0) critical=2;
- if (strcmp(pressed,"wait")==0) critical=3;
- if (strcmp(pressed,"hrel")==0) critical=4;
-
- if (strcmp(pressed,"compress")==0 || strcmp(pressed,"uncompress")==0)
- compress=!compress;
-
- if (strcmp(pressed,"time")==0 || strcmp(pressed,"percent")==0)
- time=!time;
-
- if (strcmp(pressed,"undo")==0) {undo=!undo;}
- if (strcmp(pressed,"delete")==0) {delete=!delete;}
-
- printf("app_menu(activate_icons([");
- if (critical_type!=0) printf("\"absolute\",");
- if (critical_type!=1) printf("\"absdelta\",");
- if (critical_type!=2) printf("\"reldelta\",");
- if (critical_type!=3) printf("\"weightdelta\",");
-
- if (critical!=0) printf("\"sync\",");
- if (critical!=1) printf("\"comp\",");
- if (critical!=2) printf("\"comm\",");
- if (critical!=3) printf("\"wait\",");
- if (critical!=4) printf("\"hrel\",");
-
- if (!compress) printf("\"compress\",");
- if (compress) printf("\"uncompress\",");
- if (!time) printf("\"time\",");
- if (time) printf("\"percent\",");
- if (!delete) printf("\"delete\",");
- if (!undo) printf("\"undo\",");
-
- cmdDaVinci("\"help\"]))");
-}
-
-/* -----------------------------------------------------------------------------
- * Graph to daVinci
- * -------------------------------------------------------------------------- */
-
-void graphToDaVinci(int root,Matrix *graph, Matrix *costs, int removezerocosts) {
- int i,j;
- object_cost *ptr;
- char zeronodes[MAX_PROFILE_LINE_LENGTH*2]; // is this a sen. MAX
- char TEMPzeronodes[MAX_PROFILE_LINE_LENGTH*2];
- char* p_zeronodes = zeronodes;
- char* TEMPp_zeronodes = TEMPzeronodes;
-
- printf("graph(new([");
- if (PrintLogo) {
- /* I have implemented some name changes here. They are purely for output and */
- /* following the relation (comp = scc, comm = ticks, wait = bytes */
- printf("l(\"info\",n(\"\",["
- "a(\"COLOR\",\"gold\"),"
- "a(\"FONTFAMILY\",\"courier\"),"
- //"a(\"_GO\",\"icon\"),"
- //"a(\"ICONFILE\",\"oxpara.xbm\"),"
- "a(\"OBJECT\",\""
- "Program statistics\\n\\n"
- "Time elapsed = %6.2f ticks\\n"
- "Heap usage = %6.2f bytes\\n"
- "Total scc count = %6.2f (scc)\\n"
- "\")],[])),",
- TotalComm,TotalCompIdle,
- TotalComp
- );
- }
-
- if (root==-1) {
- printf("]))\n");
- } else {
- ptr = &Mat(object_cost,*costs,root,0);
- this_total_comp_max = ptr->comp_max;
- this_total_comp_avg = ptr->comp_avg;
- this_total_comm_max = ptr->comm_max;
- this_total_comm_avg = ptr->comm_avg;
- this_total_comp_idle_max= ptr->comp_idle_max;
- this_total_comp_idle_avg= ptr->comp_idle_avg;
- this_total_time = 0.00001 +
- this_total_comp_max+ this_total_comm_max;
- this_hrel_max = ptr->hrel_max;
- this_hrel_avg = ptr->hrel_avg;
- this_syncs = ptr->syncs;
- recur_graphToDaVinci(root,graph,costs,p_zeronodes,removezerocosts);
-
- printf("]))\n");
- fflush(stdout);
- cmdDaVinci("special(focus_node(\"%d\"))\n",root);
-
- /* graph will have been altered so that visted elements are marked
- by a negative value. These are reset */
- for(i=0;i<graph->rows;i++) {
- for(j=0;j<graph->cols;j++) {
- if (Mat_dense(*graph,i,j))
- if (Mat(int,*graph,i,j)<0) Mat(int,*graph,i,j)=1;
- }
- }
-
- if (removezerocosts==1)
- {
- if (strlen(p_zeronodes)>0)
- { strncpy(TEMPp_zeronodes,p_zeronodes,strlen(p_zeronodes)-1);
- printf("select_nodes_labels([%s])\n",TEMPp_zeronodes);
- }
- strcpy(TEMPp_zeronodes,"");
- strcpy(p_zeronodes,"");
- }
- }
-}
-
-static char *printCompressNode(int node, object_cost *ptr) {
- char name[MAX_FUNNAME+20];
- char comp[MAX_FUNNAME+20];
- char comm[MAX_FUNNAME+20];
- static char res[(MAX_FUNNAME+20)*4];
- char tempstring[MAX_FUNNAME+20];
- char *padding;
- int x;
- char delimiter[] = "&";
-
- if (symbol_table[node].type==CG_SSTEP)
- sprintf(name,"%d %s",
- symbol_table[node].lineno,symbol_table[node].filename);
- else
- {
- strcpy(tempstring,symbol_table[node].filename);
- sprintf(name,"%s",strtok(tempstring,delimiter));
- }
-
- if (NodeviewTime) {
- /* changed this for GHC stats */
- sprintf(comp,"\\nTime %6.2fticks\\n",ptr->comm_max);
- sprintf(comm,"Bytes %6.2funits",ptr->comp_idle_max);
- } else {
- sprintf(comp,"\\nTime %6.2f%%\\n",(ptr->comm_max/TotalComm)*100.0);
- sprintf(comm,"Bytes %6.2f%%",(ptr->comp_idle_max/TotalCompIdle)*100.0);
- }
- /* Slightly arbitrary choice for max display length of CC string */
- /* If it is larger than this the display nodes look bad */
- if (strlen(name)>20) name[20]='\0';
- x=strlen(name);
- if (((20-(strlen(name)+3))/2)>19)
- padding = extra_space(0);
- else
- padding = extra_space((20-(strlen(name)+3))/2); /* includes \\n */
- strcpy(res,padding);
- strcat(res,name);
- strcat(res,comp);
- strcat(res,comm);
- return res;
-}
-
-static char *printUncompressNode(int node, object_cost *ptr) {
- char name [MAX_FUNNAME+40];
- char module [MAX_FUNNAME+40];
- char group [MAX_FUNNAME+40];
- char head [MAX_FUNNAME+40];
- char comp [MAX_FUNNAME+40];
- char comm [MAX_FUNNAME+40];
- char wait [MAX_FUNNAME+40];
- char hrel [MAX_FUNNAME+40];
- char tempstring[MAX_FUNNAME+20];
- char tempstring2[MAX_FUNNAME+20];
- char *tempstring3;
- char *tempstring5;
- char tempstring4[MAX_FUNNAME+20];
- char delimiter[] = "&";
-
-
- static char res[(MAX_FUNNAME+40)*7];
- char *padding;
- int width=0,x;
-
- if (symbol_table[node].type==CG_SSTEP)
- sprintf(name,"%s line %d\\n",
- symbol_table[node].filename,symbol_table[node].lineno);
- else
- {
- strcpy(tempstring,symbol_table[node].filename);
- strcpy(tempstring2,symbol_table[node].filename);
- sprintf(name,"%s",strtok(tempstring,delimiter));
- strcpy(tempstring4,tempstring2);
- tempstring5 = strpbrk(tempstring4,delimiter);
- sprintf(module,"%s",strtok(tempstring5+1,delimiter));
- tempstring3 = strrchr(tempstring2,'&');
- sprintf(group,"%s",tempstring3+1);
- }
-
- if (NodeviewTime) {
-
- sprintf(head, "Metric Total \\n");
- sprintf(comp, " Time %6.2ft \\n",ptr->comm_max);
- sprintf(comm, " Bytes %6.2fu \\n",ptr->comp_idle_max);
- sprintf(wait, " SCC %6.2fc \\n",ptr->comp_max);
-
-
- } else {
-
- sprintf(head, "Metric Total \\n");
- sprintf(comp, " Time %5.1f%% \\n",100.0*SAFEDIV(ptr->comm_max,TotalComm));
- sprintf(comm, " Bytes %5.1f%% \\n",100.0*SAFEDIV(ptr->comp_idle_max,TotalCompIdle));
- sprintf(wait, " SCC %5.1f%% \\n",100.0*SAFEDIV(ptr->comp_max,TotalComp));
-
- }
-
- if ((x=strlen(name))>width) width=x;
- if ((x=strlen(hrel))>width) width=x;
- padding = extra_space((width-strlen(name)+3)/2); /* includes \\n */
- /* strcpy(res,padding); */
- strcpy(res,"Cost centre: ");
- strcat(res,name);
- strcat(res,"\\n");
- strcat(res,"Module : ");
- strcat(res,module);
- strcat(res,"\\n");
- strcat(res,"Group : ");
- strcat(res,group);
- strcat(res,"\\n\\n");
-
- strcat(res,head);
- strcat(res,comp);
- strcat(res,comm);
- strcat(res,wait);
- /* strcat(res,hrel); */
- return res;
-}
-
-
-double nodeColour(object_cost *cost) {
-
- switch (CriticalPath + CriticalType) {
- case CRITTYPE_ABSOLUTE+CRITICAL_SYNCS:
- case CRITTYPE_ABSDELTA+CRITICAL_SYNCS:
- case CRITTYPE_RELDELTA+CRITICAL_SYNCS:
- case CRITTYPE_WEIGHTDELTA+CRITICAL_SYNCS:
- return SAFEDIV(((double)cost->syncs),((double)this_syncs));
-
- case CRITTYPE_ABSOLUTE+CRITICAL_COMP:
- return SAFEDIV(cost->comp_max,this_total_comp_max);
-
- case CRITTYPE_ABSOLUTE+CRITICAL_COMM:
- return SAFEDIV(cost->comm_max,this_total_comm_max);
-
- case CRITTYPE_ABSOLUTE+CRITICAL_WAIT:
- return SAFEDIV(cost->comp_idle_max,this_total_comp_idle_max);
-
- case CRITTYPE_ABSOLUTE+CRITICAL_HREL:
- return SAFEDIV(((double) cost->hrel_max),((double)this_hrel_max));
-
- case CRITTYPE_ABSDELTA+CRITICAL_COMP:
- return SAFEDIV(cost->comp_max,TotalComp);
-
- case CRITTYPE_ABSDELTA+CRITICAL_COMM:
- return SAFEDIV(cost->comm_max,TotalComm);
-
- case CRITTYPE_ABSDELTA+CRITICAL_WAIT:
- return SAFEDIV(cost->comp_idle_max,TotalCompIdle);
-
- case CRITTYPE_ABSDELTA+CRITICAL_HREL:
- return SAFEDIV(((double) (cost->hrel_max - cost->hrel_avg)),
- ((double) (this_hrel_max-this_hrel_avg)));
-
- case CRITTYPE_RELDELTA+CRITICAL_COMP:
- return SAFEDIV((cost->comp_max-cost->comp_avg),
- (cost->comp_avg*DeltaNormalise));
-
- case CRITTYPE_RELDELTA+CRITICAL_COMM:
- return SAFEDIV((cost->comm_max-cost->comm_avg),
- (cost->comm_avg*DeltaNormalise));
-
- case CRITTYPE_RELDELTA+CRITICAL_WAIT:
- return SAFEDIV((cost->comp_idle_max-cost->comp_idle_avg),
- (cost->comp_idle_avg*DeltaNormalise));
-
- case CRITTYPE_RELDELTA+CRITICAL_HREL:
- return SAFEDIV(((double) (cost->hrel_max - cost->hrel_avg)),
- ((double) (cost->hrel_avg*DeltaNormalise)));
-
- case CRITTYPE_WEIGHTDELTA+CRITICAL_COMP:
- return (SAFEDIV((cost->comp_max-cost->comp_avg),
- (cost->comp_avg*DeltaNormalise))*
- SAFEDIV(cost->comp_max,this_total_comp_max));
-
- case CRITTYPE_WEIGHTDELTA+CRITICAL_COMM:
- return (SAFEDIV((cost->comm_max-cost->comm_avg),
- (cost->comm_avg*DeltaNormalise))*
- SAFEDIV(cost->comm_max,this_total_comm_max));
-
- case CRITTYPE_WEIGHTDELTA+CRITICAL_WAIT:
- return (SAFEDIV((cost->comp_idle_max-cost->comp_idle_avg),
- (cost->comp_idle_avg*DeltaNormalise))*
- SAFEDIV(cost->comp_idle_max,this_total_comp_idle_max));
-
- case CRITTYPE_WEIGHTDELTA+CRITICAL_HREL:
- return (SAFEDIV(((double) (cost->hrel_max - cost->hrel_avg)),
- ((double) (cost->hrel_avg*DeltaNormalise)))*
- SAFEDIV(((double) cost->hrel_max),((double)this_hrel_max)));
-
- }
- return 0.0;
-}
-
-int percentToColour(double colour) {
- int range=255,base=0;
-
- if (!Colour) {
- base =100;
- range=155;
- }
- if (colour>1.0) return (base+range);
- else if (colour<0.0) return base;
- else return (((int) (((double)range)*colour))+base);
-}
-
-/* -----------------------------------------------------------------------------
- * Recursively draw the graph
- * -------------------------------------------------------------------------- */
-
-static void recur_graphToDaVinci(int node,Matrix *graph,Matrix *costs,char* p_zeronodes, int mode){
- object_cost *ptr;
- int i,j,no_children=0,*children=NULL,colour;
- char *node_str;
- char tempnode[MAX_FUNNAME];
- if (Mat(int,*graph,node,node)<0) {
- printf("r(\"%d\") ",node);
- } else {
- for(i=0;i<graph->cols;i++)
- if (node!=i && Mat_dense(*graph,node,i)) no_children++;
-
- if (no_children>0) {
- children = calloc(no_children,sizeof(int));
- if (children==NULL) {
- fprintf(stderr,"{printDaVinci} unable to allocate %d ",no_children);
- exit(1);
- }
- for((i=0,j=0);i<graph->cols;i++)
- if (node!=i && Mat_dense(*graph,node,i)) children[j++]=i;
-
- qsort(children,no_children,sizeof(int),
- (int (*)(const void *,const void *)) cmp_symbol_entry);
- }
- ptr = &Mat(object_cost,*costs,node,0);
- node_str=(NodeviewCompress)?
- printCompressNode(node,ptr):
- printUncompressNode(node,ptr);
- printf("l(\"%d\",n(\"\",[a(\"OBJECT\",\"%s\"),",node,node_str);
- printf("a(\"FONTFAMILY\",\"courier\"),");
-
-
- // hide the CAF:REPOSITORY as default
- if (!strncmp(node_str,"Cost centre: CAF:REPOSITORY",26))
- printf("a(\"HIDDEN\",\"true\"),"); // when uncompressed
- if (!strncmp(node_str," CAF:REPOSITORY",12))
- printf("a(\"HIDDEN\",\"true\"),"); // when compressed
-
-
- if (mode==2)
- {
- if ((ptr->comm_max+ptr->comp_idle_max+ptr->comp_max) <= 0.0)
- printf("a(\"HIDDEN\",\"true\"),");
- }
- //for pruning all zero-cost nodes
- if (mode==1)
- {
- if ((ptr->comm_max+ptr->comp_idle_max+ptr->comp_max) <= 0.0)
- { fprintf(logFile,"Node %d %s is a candidate for deletion\n",node, node_str);
- sprintf(tempnode,"\"%d\",",node);
- strcat(p_zeronodes,tempnode);
- }
- }
-
- colour=percentToColour(1.0-nodeColour(ptr));
- printf("a(\"COLOR\",\"#ff%.2x%.2x\")",colour,colour);
- printf("],[");
- Mat(int,*graph,node,node)=-1;
- for(i=0;i<no_children;i++) {
-
- printf("e(\"%d->%d\",[],",node,children[i]);
-
- recur_graphToDaVinci(children[i],graph,costs,p_zeronodes,mode);
- printf(")");
- if (i<(no_children-1)) {printf(",");}
- }
- printf("]))");
- }
-}
-
-
-
-static void recur_graphToDaVinci_old(int node,Matrix *graph, Matrix *costs) {
- object_cost *ptr;
- int i,j,no_children=0,*children=NULL,colour;
- char *node_str;
- if (Mat(int,*graph,node,node)<0) {
- fprintf(logFile,"r(\"%d\") ",node);
- printf("r(\"%d\") ",node);
- } else {
- for(i=0;i<graph->cols;i++)
- if (node!=i && Mat_dense(*graph,node,i)) no_children++;
-
- if (no_children>0) {
- children = calloc(no_children,sizeof(int));
- if (children==NULL) {
- fprintf(stderr,"{printDaVinci} unable to allocate %d ",no_children);
- exit(1);
- }
- for((i=0,j=0);i<graph->cols;i++)
- if (node!=i && Mat_dense(*graph,node,i)) children[j++]=i;
-
- qsort(children,no_children,sizeof(int),
- (int (*)(const void *,const void *)) cmp_symbol_entry);
- }
- ptr = &Mat(object_cost,*costs,node,0);
- node_str=(NodeviewCompress)?
- printCompressNode(node,ptr):
- printUncompressNode(node,ptr);
- fprintf(logFile,"l(\"%d\",n(\"\",[a(\"OBJECT\",\"%s\"),",node,node_str);
- printf("l(\"%d\",n(\"\",[a(\"OBJECT\",\"%s\"),",node,node_str);
- fprintf(logFile,"a(\"FONTFAMILY\",\"courier\"),");
- printf("a(\"FONTFAMILY\",\"courier\"),");
- if (symbol_table[node].type==CG_SSTEP)
- printf("a(\"BORDER\",\"double\"),");
- else
- //if (prune subgraphs of zero cost node)
- // minNodeSize hardwired
- if ((ptr->comm_max+ptr->comp_idle_max+ptr->comp_max) < minNodeSize)
- printf("a(\"HIDDEN\",\"true\"),");
-
- //if ((ptr->comm_max+ptr->comp_idle_max+ptr->comp_max) < 0.01)
- // small=1;
- //else small=0;
-
-
- colour=percentToColour(1.0-nodeColour(ptr));
- //if (!small)
- fprintf(logFile,"a(\"COLOR\",\"#ff%.2x%.2x\")",colour,colour);
- printf("a(\"COLOR\",\"#ff%.2x%.2x\")",colour,colour);
- //else
- // printf("a(\"COLOR\",\"yellow\"),");
- fprintf(logFile,"],[");
- printf("],[");
- Mat(int,*graph,node,node)=-1;
- for(i=0;i<no_children;i++) {
-
- //if (!small)
- fprintf(logFile,"e(\"%d->%d\",[],",node,children[i]);
- printf("e(\"%d->%d\",[],",node,children[i]);
- //else
- // printf("e(\"%d->%d\",[a(\"EDGECOLOR\",\"yellow\")],",node,children[i]);
-
- recur_graphToDaVinci_old(children[i],graph,costs);
- fprintf(logFile,")");
- printf(")");
- if (i<(no_children-1)) {fprintf(logFile,","); printf(",");}
- }
- fprintf(logFile,"]))");
- printf("]))");
- }
-}
-
-
-/* -----------------------------------------------------------------------------
- * Update colour
- * -------------------------------------------------------------------------- */
-
-void updateColours(int root, Matrix *graph, Matrix *costs) {
- int i,colour,last;
-
- printf("graph(change_attr([");
- for(last=costs->rows-1;last>=0;last--)
- if (Mat_dense(*graph,last,last)) break;
-
- for(i=0;i<costs->rows;i++) {
- if (Mat_dense(*graph,i,i)) {
- colour = percentToColour(1.0-nodeColour(&Mat(object_cost,*costs,i,0)));
- printf("node(\"%d\",[a(\"COLOR\",\"#ff%.2x%.2x\")])",
- i,colour,colour);
- if (i<last) printf(",");
- }
- }
- printf("]))\n");
-}
-
-/* -----------------------------------------------------------------------------
- * Parse answer from daVinci
- * -------------------------------------------------------------------------- */
-
-davinciCmd parseDaVinciCmd(char *input) {
- davinciCmd result;
- char *crp;
- char *word;
- int i;
-
- result.size=1;
- result.list=NULL;
- for(crp=input;*crp;crp++)
- if (*crp==',') result.size++;
-
- crp=input;
- word = parse_word(&crp);
- if (Verbose) fprintf(logFile,"{parseDaVinciCmd}=%s size=%d\n",word,result.size);
- if (strcmp(word,"node_selections_labels")==0) {
- result.type=DAVINCI_NODE;
- result.list =calloc(result.size,sizeof(char*));
- if (result.list==NULL) {
- fprintf(stderr,"{parseDaVinciCmd} failed to allocate storage");
- exit(1);
- }
- crp+=2;
- i=0;
- word = parse_quoted(&crp);
- result.list[i++] = dup_str(word);
- while (*crp++==',') {
- word = parse_quoted(&crp);
- result.list[i++] = dup_str(word);
- }
- } else if (strcmp(word,"icon_selection")==0) {
- result.type=DAVINCI_ICON;
- result.list =calloc(result.size,sizeof(char*));
- if (result.list==NULL) {
- fprintf(stderr,"{parseDaVinciCmd} failed to allocate storage");
- exit(1);
- }
- crp++;
- i=0;
- word = parse_quoted(&crp);
- result.list[i++] = dup_str(word);
- } else if (strcmp(word,"tcl_answer")==0) {
- result.type=DAVINCI_TCL;
- result.list =calloc(result.size,sizeof(char*));
- if (result.list==NULL) {
- fprintf(stderr,"{parseDaVinciCmd} failed to allocate storage");
- exit(1);
- }
- crp++;
- i=0;
- word = parse_quoted(&crp);
- result.list[i++] = dup_str(word);
- } else if (strcmp(word,"menu_selection")==0) {
- result.type=DAVINCI_MENU;
- result.list =calloc(result.size,sizeof(char*));
- if (result.list==NULL) {
- fprintf(stderr,"{parseDaVinciCmd} failed to allocate storage");
- exit(1);
- }
- crp++;
- i=0;
- word = parse_quoted(&crp);
- result.list[i++] = dup_str(word);
- }else if (strcmp(word,"node_double_click")==0) {
- result.type=DAVINCI_OK;
- } else if (strcmp(word,"edge_selection_labels")==0) {
- result.type=DAVINCI_OK;
- } else if (strcmp(word,"ok")==0) {
- result.type=DAVINCI_OK;
- } else if (strcmp(word,"quit")==0) {
- result.type=DAVINCI_QUIT;
- } else {
- result.type=DAVINCI_ERROR;
- }
- return result;
-}
-
-/* -----------------------------------------------------------------------------
- * Misc.
- * -------------------------------------------------------------------------- */
-
-
-/* Function that returns a string containing \texttt{x} spaces. */
-static char* extra_space(int x) {
- static char space[MAX_FUNNAME+1];
- int i;
-
- if (Verbose) fprintf(logFile,"Padding is %d\n",x);
- for(i=0;(i<x)&&(i<MAX_FUNNAME);i++) space[i]=' ';
- space[i]='\0';
- return space;
-}
-
-
-static char *parse_word(char **crp) {
- static char result[MAX_FUNNAME];
- int i=0;
-
- while(islower(**crp) || **crp=='_') {
- result[i++]=**crp;
- (*crp)++;
- }
- result[i]='\0';
- return result;
-}
-
-static char *parse_quoted(char **crp) {
- static char result[MAX_FUNNAME];
- int i=0;
- if (**crp=='\"') {
- (*crp)++;
- while (**crp != '\"') {
- result[i++]=**crp;
- (*crp)++;
- }
- (*crp)++;
- }
- result[i]='\0';
- return result;
-}
-
-static char *dup_str(char *xs) {
- char *result;
-
- if (xs==NULL) return NULL;
- else {
- result = malloc(strlen(xs)+1);
- if (result==NULL) {
- fprintf(stderr,"{dup_str}: unable to allocate bytes");
- exit(1);
- }
- strcpy(result,xs);
- return result;
- }
-}
diff --git a/ghc/utils/prof/cgprof/daVinci.h b/ghc/utils/prof/cgprof/daVinci.h
deleted file mode 100644
index 3f6106983d..0000000000
--- a/ghc/utils/prof/cgprof/daVinci.h
+++ /dev/null
@@ -1,95 +0,0 @@
-/* ------------------------------------------------------------------------
- * $Id: daVinci.h,v 1.1 2000/04/05 10:06:36 simonmar Exp $
- *
- * Copyright (C) 1995-2000 University of Oxford
- *
- * Permission to use, copy, modify, and distribute this software,
- * and to incorporate it, in whole or in part, into other software,
- * is hereby granted without fee, provided that
- * (1) the above copyright notice and this permission notice appear in
- * all copies of the source code, and the above copyright notice
- * appear in clearly visible form on all supporting documentation
- * and distribution media;
- * (2) modified versions of this software be accompanied by a complete
- * change history describing author, date, and modifications made;
- * and
- * (3) any redistribution of the software, in original or modified
- * form, be without fee and subject to these same conditions.
- * --------------------------------------------------------------------- */
-
-#ifndef _DAVINCI_H_
-#define _DAVINCI_H_
-#include "symbol.h"
-#include "matrix.h"
-#include "cgprof.h"
-
-#define PAIRMAX(x,y) (((x)>(y))?(x):(y))
-
-#define SAFEDIV(x,y) (((y)==0.0)?0.0:((x)/(y)))
-
-#define DAVINCI_ERROR 0
-#define DAVINCI_OK 1
-#define DAVINCI_NODE 2
-#define DAVINCI_MENU 3
-#define DAVINCI_ICON 4
-#define DAVINCI_DOUBLE_CLICK 5
-#define DAVINCI_QUIT 6
-#define DAVINCI_TCL 7
-
-#define TCL_HREL 0
-#define TCL_COMP 1
-#define TCL_COMM 2
-#define TCL_WAIT 3
-#define TCL_EXIT 4
-
-#define INCLUDEDIR "@includedir@"
-
-typedef struct {
- int type;
- char **list;
- int size;
-} davinciCmd;
-
-
-#define CRITICAL_COMP 0
-#define CRITICAL_COMM 1
-#define CRITICAL_WAIT 2
-#define CRITICAL_HREL 3
-#define CRITICAL_SYNCS 4
-
-#define CRITTYPE_ABSOLUTE 0
-#define CRITTYPE_ABSDELTA 100
-#define CRITTYPE_RELDELTA 200
-#define CRITTYPE_WEIGHTDELTA 300
-
-extern void graphToDaVinci(int,Matrix*,Matrix *,int);
-davinciCmd parseDaVinciCmd(char*);
-extern void cmdDaVinci(char*,...);
-extern void initDaVinci();
-extern void activateDaVinciMenu(char *);
-extern void updateColours(int,Matrix*,Matrix*);
-extern void tclPieUpdate(object_cost *,int,int);
-extern void tclPieInit();
-
-
-extern char* lastDavinciCmd;
-extern int NodeviewTime;
-extern int NodeviewCompress;
-extern double TotalComp;
-extern double TotalComm;
-extern double TotalCompIdle;
-extern int TotalSyncs;
-extern long int TotalH;
-extern char *dateProfiled;
-extern char *machineName;
-extern int bsp_p;
-extern double bsp_s,bsp_l,bsp_g;
-extern int CriticalPath;
-extern int CriticalType;
-extern double minNodeSize;
-extern int bsp_p;
-extern int PrintLogo;
-extern int Colour;
-extern int DeltaNormalise;
-extern int PieCombine;
-#endif
diff --git a/ghc/utils/prof/cgprof/main.c b/ghc/utils/prof/cgprof/main.c
deleted file mode 100644
index afa8fbee19..0000000000
--- a/ghc/utils/prof/cgprof/main.c
+++ /dev/null
@@ -1,436 +0,0 @@
-/* ------------------------------------------------------------------------
- * $Id: main.c,v 1.4 2005/12/02 12:45:16 simonmar Exp $
- *
- * Copyright (C) 1995-2000 University of Oxford
- *
- * Permission to use, copy, modify, and distribute this software,
- * and to incorporate it, in whole or in part, into other software,
- * is hereby granted without fee, provided that
- * (1) the above copyright notice and this permission notice appear in
- * all copies of the source code, and the above copyright notice
- * appear in clearly visible form on all supporting documentation
- * and distribution media;
- * (2) modified versions of this software be accompanied by a complete
- * change history describing author, date, and modifications made;
- * and
- * (3) any redistribution of the software, in original or modified
- * form, be without fee and subject to these same conditions.
- * --------------------------------------------------------------------- */
-
-#include "ghcconfig.h"
-
-#include <stdio.h>
-
-#if HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-#if HAVE_STRING_H
-#include <string.h>
-#endif
-
-#include "symbol.h"
-#include "cgprof.h"
-#include "matrix.h"
-#include "daVinci.h"
-
-#if HAVE_WINDOWS_H
-#include <windows.h>
-#define sleep(x) Sleep((x)*1000)
-#endif
-
-
-#define NoDeletes 80
-
-int CriticalPath=CRITICAL_SYNCS;
-int CriticalType=CRITTYPE_ABSOLUTE;
-int Verbose=1;
-int NodeviewTime=1;
-int NodeviewCompress=1;
-int PrintLogo=1;
-int Colour=1;
-int DeltaNormalise=1;
-int PieView=TCL_COMP;
-int PieCombine=0;
-char *Pgm;
-char *ProfileData;
-int NoNodes,root;
-char usage[]="usage: cgprof profile-data [See man 1 cgprof]";
-char helpUrl[]="http://www.dcs.warwick.ac.uk/people/academic/Stephen.Jarvis/profiler/";
-Matrix graph; /* NoNodes x NoNodes matrix of integers */
-Matrix costs; /* NoNodes x 1 matrix of costs */
-
-double TotalComp, TotalComm, TotalCompIdle;
-int TotalSyncs;
-long int TotalH;
-
-char *dateProfiled, *machineName;
-double minNodeSize = 0.01; /* i.e, don't show nodes with _combined_
- comp and comm % less than this */
-double bsp_s = 74.0;
-double bsp_l = 1902;
-double bsp_g = 9.3;
-int bsp_p;
-
-FILE *logFile;
-
-
-extern void printDaVinci(int);
-
-int
-main(int argc, char *argv[]) {
- char davinci_stdin[MAX_PROFILE_LINE_LENGTH];
- FILE *fptr;
- int i,j,k,going=1,*select_nodes, select_nodes_next,MaxNoNodes;
- davinciCmd cmd;
- int *undo_stack, undo_stack_next;
- float temp_f;
- char *ptr;
- int mode = 0;
- char *tempstring = malloc (80);
- char *tempstring2 = malloc (80);
-
-
- /* printf("Starting main routine of browser script\n"); */
- /* fflush(stderr); */
-
- if (argc!=14) {
- fprintf(stderr,"The perl script bspsgprof is buggered\n");
- exit(1);
- }
-
- /* Most (if not all) of these BSP specific arguments can be removed */
-
- Pgm = argv[0];
- ProfileData = argv[1];
- bsp_p = atoi(argv[2]);
- machineName = argv[3];
- dateProfiled= argv[4];
- sscanf(argv[5],"%f",&temp_f);
- bsp_s = temp_f;
- sscanf(argv[6],"%f",&temp_f);
- bsp_l = temp_f;
- sscanf(argv[7],"%f",&temp_f);
- bsp_g = temp_f;
- sscanf(argv[8],"%f",&temp_f);
- minNodeSize=temp_f;
- Verbose = atoi(argv[9]);
- PrintLogo=atoi(argv[10]);
- Colour=atoi(argv[11]);
- DeltaNormalise=atoi(argv[12]);
- MaxNoNodes=atoi(argv[13]);
-
- /* printf("Initialisation done\n"); */
-
- if (Verbose) sleep(10);
- if (!(fptr=fopen(ProfileData,"r"))) {
- fprintf(stderr,"%s: unable to open profile data in \"%s\".\n%s\n",
- Pgm,ProfileData,usage);
- exit(1);
- }
- if (!(logFile=fopen("ghcprof.log","w"))) {
- fprintf(stderr,"%s: unable to open log file for writing\n",Pgm);
- exit(1);
- }
-
- /* printf("Files opened OK\n"); */
-
- if (!fgets(davinci_stdin, MAX_PROFILE_LINE_LENGTH, stdin) ||
- strcmp(davinci_stdin,"ok\n")) {
- fprintf(stderr,"%s{%s}: failed to receive ok from daVinci.\n",
- davinci_stdin,Pgm);
- exit(1);
- }
-
- /* printf("Initialising daVinci\n"); */
-
- initDaVinci();
-
- /* printf("Ending initialisation of daVinci\n"); */
-
- if (Verbose) fprintf(logFile,"%s: opened profile file \"%s\".\n",Pgm,ProfileData);
- readRawProfile(fptr,&NoNodes,MaxNoNodes);
- fclose(fptr);
- if (Verbose) fprintf(logFile,"%s: %d nodes in profile.\n",Pgm,NoNodes);
-
- if (NoNodes<=0) {
- fprintf(logFile,"%s: no call-graph profile data in \"%s\".\n"
- "Re-run your program using the appropriate profiling flags\n",
- Pgm,ProfileData);
- exit(1);
- }
- if (Verbose) printRawProfile();
-
- /* Do we want INHERITANCE to begin with or not? Set to yes. */
- createConnectivityMatrix(NoNodes,&graph,&costs,&root,1);
-
- TotalComp = Mat(object_cost,costs,root,0).comp_max;
- TotalComm = Mat(object_cost,costs,root,0).comm_max;
- TotalCompIdle = Mat(object_cost,costs,root,0).comp_idle_max;
- TotalH = Mat(object_cost,costs,root,0).hrel_max;
- TotalSyncs = Mat(object_cost,costs,root,0).syncs;
- if (Verbose) printConnectivityMatrix(graph,costs,root);
- fflush(logFile);
- graphToDaVinci(root,&graph,&costs,0);
- fflush(stdout);
- undo_stack = calloc(NoDeletes,sizeof(int));
- select_nodes = calloc(NoNodes,sizeof(int));
- if (undo_stack==NULL || select_nodes==NULL) {
- fprintf(stderr,"Unable to allocate storage for undo stack\n");
- exit(1);
- }
- undo_stack_next=0;
- select_nodes_next=0;
- // Pie chart stuff not wanted for GHC
- // tclPieInit();
- // tclPieUpdate(&Mat(object_cost,costs,root,0),root,PieView);
- select_nodes_next=1;
- select_nodes[0]=root;
- while (fgets(davinci_stdin, MAX_PROFILE_LINE_LENGTH, stdin) && going) {
- cmd = parseDaVinciCmd(davinci_stdin);
- if (Verbose) fprintf(logFile,"From davinci=\"%s\"\n",davinci_stdin);
- switch (cmd.type) {
- case DAVINCI_OK:
- continue;
-
- case DAVINCI_QUIT:
- going=0;
- break;
-
- case DAVINCI_NODE:
- select_nodes_next=cmd.size;
- for(i=0;((i<cmd.size) && (i<NoNodes));i++)
- select_nodes[i]=atoi(cmd.list[i]);
- if (select_nodes_next>0)
- //Pie chart stuff not wanted for GHC
- //tclPieUpdate(&Mat(object_cost,costs,select_nodes[0],0),
- // select_nodes[0],
- // PieView);
- if (mode==3)
- {
- mode = atoi(cmd.list[0]);
- getNameFromSymbolTable(mode,tempstring);
- for(ptr=tempstring;*ptr!='\0';ptr++)
- if (*ptr=='&') *ptr=' ';
- mode = 3;
- strcpy(tempstring2,"window(show_status(\"");
- strcat(tempstring2,tempstring);
- strcat(tempstring2,"\"))");
- cmdDaVinci(tempstring2);
- strcpy(tempstring,"");
- strcpy(tempstring2,"");
- }
- break;
-
- case DAVINCI_MENU:
- if (cmd.size>0) {
- if (strcmp(cmd.list[0], "jump")==0) {
- if ((select_nodes_next>=0) &&
- (select_nodes[0]>0) &&
- (select_nodes[0] < NoNodes) &&
- (Mat_dense(graph,select_nodes[0],select_nodes[0]))) {
- cmdDaVinci("special(focus_node(\"%d\"))\n",select_nodes[0]);
- }
- }
- }
- break;
-
- case DAVINCI_ICON:
- if (cmd.size>0) {
- if (strcmp(cmd.list[0], "sync")==0) {
- CriticalPath=CRITICAL_SYNCS;
- activateDaVinciMenu(cmd.list[0]);
- cmdDaVinci("window(show_status(\"Graph view\"))");
- updateColours(root,&graph,&costs);
-
- } else if (strcmp(cmd.list[0], "comp")==0) {
- CriticalPath=CRITICAL_COMP;
- activateDaVinciMenu(cmd.list[0]);
- cmdDaVinci("window(show_status(\"SCCs critical path\"))");
- updateColours(root,&graph,&costs);
-
- } else if (strcmp(cmd.list[0], "comm")==0) {
- CriticalPath=CRITICAL_COMM;
- activateDaVinciMenu(cmd.list[0]);
- cmdDaVinci("window(show_status(\"Computation time critical path\"))");
- updateColours(root,&graph,&costs);
-
- } else if (strcmp(cmd.list[0], "wait")==0) {
- CriticalPath=CRITICAL_WAIT;
- activateDaVinciMenu(cmd.list[0]);
- cmdDaVinci("window(show_status(\"Heap usage critical path\"))");
- updateColours(root,&graph,&costs);
-
- } else if (strcmp(cmd.list[0], "hrel")==0) {
-
- if (mode != 3)
- {
- cmdDaVinci("window(show_status(\"Node spy on\"))");
- mode = 3;
- }
- else
- {
- mode = 0;
- cmdDaVinci("window(show_status(\"Node spy off\"))");
- }
-
- } else if (strcmp(cmd.list[0], "absolute")==0) {
- /* Now deals with inheritance profile */
- CriticalType=CRITTYPE_ABSOLUTE;
- activateDaVinciMenu(cmd.list[0]);
- cmdDaVinci("window(show_status(\"Inheritance profile\"))");
- freeMat(&graph);
- freeMat(&costs);
- createConnectivityMatrix(NoNodes,&graph,&costs,&root,1);
- graphToDaVinci(root,&graph,&costs,0);
- cmdDaVinci("window(show_status(\"Inheritance profile\"))");
- updateColours(root,&graph,&costs);
-
- } else if (strcmp(cmd.list[0], "absdelta")==0) {
- /* Now deals with flat profile */
- CriticalType=CRITTYPE_ABSDELTA;
- activateDaVinciMenu(cmd.list[0]);
- cmdDaVinci("window(show_status(\"Flat profile\"))");
- freeMat(&graph);
- freeMat(&costs);
- createConnectivityMatrix(NoNodes,&graph,&costs,&root,0);
- graphToDaVinci(root,&graph,&costs,0);
- cmdDaVinci("window(show_status(\"Flat profile\"))");
- updateColours(root,&graph,&costs);
-
- } else if (strcmp(cmd.list[0], "reldelta")==0) {
- CriticalType=CRITTYPE_ABSOLUTE;
- activateDaVinciMenu(cmd.list[0]);
- cmdDaVinci("window(show_status(\"Trimmed zero-cost sub-trees\"))");
- strcpy(cmd.list[0], "absolute");
- activateDaVinciMenu(cmd.list[0]);
- graphToDaVinci(root,&graph,&costs,2);
- updateColours(root,&graph,&costs);
-
- } else if (strcmp(cmd.list[0], "weightdelta")==0) {
- CriticalType=CRITTYPE_ABSOLUTE;
- activateDaVinciMenu(cmd.list[0]);
- cmdDaVinci("window(show_status(\"Marked zero-cost nodes ready for deletion\"))");
- strcpy(cmd.list[0], "absolute");
- activateDaVinciMenu(cmd.list[0]);
- graphToDaVinci(root,&graph,&costs,1);
- updateColours(root,&graph,&costs);
-
- } else if (strcmp(cmd.list[0],"help")==0) {
- cmdDaVinci("special(show_url(\"%s\"))",helpUrl);
-
- } else if (strcmp(cmd.list[0],"time")==0) {
- NodeviewTime=1;
- activateDaVinciMenu(cmd.list[0]);
- cmdDaVinci("window(show_status(\"Cost metric view\"))");
- graphToDaVinci(root,&graph,&costs,0);
-
- } else if (strcmp(cmd.list[0],"percent")==0) {
- NodeviewTime=0;
- activateDaVinciMenu(cmd.list[0]);
- cmdDaVinci("window(show_status(\"Percentage view\"))");
- graphToDaVinci(root,&graph,&costs,0);
-
- } else if (strcmp(cmd.list[0],"compress")==0) {
- NodeviewCompress=1;
- activateDaVinciMenu(cmd.list[0]);
- cmdDaVinci("window(show_status(\"Compressed node view\"))");
- cmdDaVinci("menu(layout(compact_all))");
- graphToDaVinci(root,&graph,&costs,0);
-
- } else if (strcmp(cmd.list[0],"uncompress")==0) {
- NodeviewCompress=0;
- activateDaVinciMenu(cmd.list[0]);
- cmdDaVinci("window(show_status(\"Uncompressed node view\"))");
- graphToDaVinci(root,&graph,&costs,0);
-
- } else if ((strcmp(cmd.list[0],"delete")==0) ||
- (strcmp(cmd.list[0],"undo")==0)) {
- if (strcmp(cmd.list[0],"delete")==0) {
- if (undo_stack_next==0)
- activateDaVinciMenu("undo");
- for(i=0;(i<select_nodes_next) && (undo_stack_next<NoNodes);i++)
- undo_stack[undo_stack_next++] = select_nodes[i];
- if (undo_stack_next==NoDeletes)
- activateDaVinciMenu("delete");
- cmdDaVinci("window(show_status(\"Deleted node (s)\"))");
- select_nodes_next=0;
- } else {
- if (undo_stack_next==NoDeletes)
- activateDaVinciMenu("delete");
- undo_stack_next--;
- if (undo_stack_next==0)
- activateDaVinciMenu("undo");
- cmdDaVinci("window(show_status(\"Undone deletion\"))");
- select_nodes_next=1;
- select_nodes[0]=undo_stack[undo_stack_next];
-
- for(i=0;i<raw_profile_next;i++)
- raw_profile[i].active=1;
- }
- activateDaVinciMenu("default");
- for(i=0;i<undo_stack_next;i++) {
- for(j=0;j<raw_profile_next;j++) {
- for(k=0;k<raw_profile[j].stack_size;k++) {
- if (raw_profile[j].stack[k]==undo_stack[i])
- raw_profile[j].active=0;
- }
- }
- }
- cmdDaVinci("window(show_message(\"Deleting node...\"))");
- freeMat(&graph);
- freeMat(&costs);
- createConnectivityMatrix(NoNodes,&graph,&costs,&root,1);
- graphToDaVinci(root,&graph,&costs,0);
- if (strcmp(cmd.list[0],"undo")==0) {
- if ((select_nodes[0]>0) &&
- (select_nodes[0] < NoNodes) &&
- (Mat_dense(graph,select_nodes[0],select_nodes[0]))) {
- cmdDaVinci("special(focus_node(\"%d\"))\n",select_nodes[0]);
- cmdDaVinci("special(select_nodes([\"%d\"]))",select_nodes[0]);
- //Pie chart stuff not wanted for GHC
- //tclPieUpdate(&Mat(object_cost,costs,select_nodes[0],0),
- // select_nodes[0],
- // PieView);
- }
- }
- }
- }
- break;
- case DAVINCI_TCL:
- // This stuff can go as it is related to the input for the Pie chart tool
- if (cmd.size>0) {
- if (strcmp(cmd.list[0], "comm")==0) {
- PieView=TCL_COMM;
- } else if (strcmp(cmd.list[0], "comp")==0) {
- PieView=TCL_COMP;
- } else if (strcmp(cmd.list[0], "hrel")==0) {
- PieView=TCL_HREL;
- } else if (strcmp(cmd.list[0], "wait")==0) {
- PieView=TCL_WAIT;
- } else if (strcmp(cmd.list[0], "combine")==0) {
- PieCombine=!PieCombine;
- } else if (strlen(cmd.list[0])==0) {
- break;
- }
- if (select_nodes_next>0) break;
- //Added a break for compiliation above since it does not compile if
- //we just remove the Pie chart code
- //tclPieUpdate(&Mat(object_cost,costs,select_nodes[0],0),
- // select_nodes[0],
- // PieView);
- }
- break;
- case DAVINCI_ERROR:
- default:
- fprintf(stderr,"CGPROF error:\n"
- "\tCommand = %s\n"
- "\tError = %s\n",lastDavinciCmd,davinci_stdin);
- exit(1);
- break;
- }
- fflush(stdout);
- fflush(logFile);
- }
-
- return 0;
-}
diff --git a/ghc/utils/prof/cgprof/matrix.c b/ghc/utils/prof/cgprof/matrix.c
deleted file mode 100644
index b4ca43f96b..0000000000
--- a/ghc/utils/prof/cgprof/matrix.c
+++ /dev/null
@@ -1,98 +0,0 @@
-/* ------------------------------------------------------------------------
- * $Id: matrix.c,v 1.3 2006/01/09 14:32:31 simonmar Exp $
- *
- * Copyright (C) 1995-2000 University of Oxford
- *
- * Permission to use, copy, modify, and distribute this software,
- * and to incorporate it, in whole or in part, into other software,
- * is hereby granted without fee, provided that
- * (1) the above copyright notice and this permission notice appear in
- * all copies of the source code, and the above copyright notice
- * appear in clearly visible form on all supporting documentation
- * and distribution media;
- * (2) modified versions of this software be accompanied by a complete
- * change history describing author, date, and modifications made;
- * and
- * (3) any redistribution of the software, in original or modified
- * form, be without fee and subject to these same conditions.
- * --------------------------------------------------------------------- */
-
-/* Not very clever sparse representation of a matrix. However, it will do
- * for the call graph profiler.
- */
-
-#include <stdlib.h>
-#include <stdio.h>
-#include <string.h>
-#include "matrix.h"
-
-Matrix newMat(int rows,int cols, int elsize, void *zero) {
- Matrix res;
-
- res.elsize= elsize;
- res.zero = malloc(elsize);
- if (res.zero==NULL) {
- fprintf(stderr,"{newMat} unable to allocate storage\n");
- exit(1);
- }
- memcpy(res.zero,zero,elsize);
- res.rows = rows;
- res.cols = cols;
- res.mat=NULL;
- return res;
-}
-
-void freeMat(Matrix *mat) {
- Matrix_element *tmp_ptr, *ptr=mat->mat;
- free(mat->zero);
-
- while(ptr!=NULL) {
- free(ptr->data);
- tmp_ptr = ptr->next;
- free(ptr);
- ptr=tmp_ptr;
- }
-}
-
-void *_Mat(Matrix *mat,int x, int y,int lineno, char *filename) {
- Matrix_element *ptr= mat->mat;
- if (x<0 || x>=mat->rows || y<0 || y>=mat->cols) {
- fprintf(stderr,"Mat[%d,%d] out of bound index at line %d of \"%s\"\n",
- x,y,lineno,filename);
- exit(1);
- }
- while(ptr) {
- if ((x==ptr->x) && (y==ptr->y)) {
- return ptr->data;
- }
- ptr=ptr->next;
- }
- /* Not in list */
- ptr = (Matrix_element*) malloc(sizeof(Matrix_element));
- if (ptr==NULL) {
- fprintf(stderr,"{_Mat} failed to allocate %zd bytes\n",
- sizeof(Matrix_element));
- exit(1);
- }
- ptr->data = (void*) malloc(mat->elsize);
- if (ptr->data==NULL) {
- fprintf(stderr,"{_Mat} failed to allocate element of size %d bytes\n",
- mat->elsize);
- exit(1);
- }
- ptr->x=x;
- ptr->y=y;
- memcpy(ptr->data,mat->zero,mat->elsize);
- ptr->next=mat->mat;
- mat->mat=ptr;
- return ptr->data;
-}
-
-int Mat_dense(Matrix mat,int x,int y) {
- Matrix_element *ptr= mat.mat;
- while (ptr) {
- if ((x==ptr->x) && (y==ptr->y)) return 1;
- ptr=ptr->next;
- }
- return 0;
-}
diff --git a/ghc/utils/prof/cgprof/matrix.h b/ghc/utils/prof/cgprof/matrix.h
deleted file mode 100644
index bf70cf7c90..0000000000
--- a/ghc/utils/prof/cgprof/matrix.h
+++ /dev/null
@@ -1,42 +0,0 @@
-/* ------------------------------------------------------------------------
- * $Id: matrix.h,v 1.1 2000/04/05 10:06:36 simonmar Exp $
- *
- * Copyright (C) 1995-2000 University of Oxford
- *
- * Permission to use, copy, modify, and distribute this software,
- * and to incorporate it, in whole or in part, into other software,
- * is hereby granted without fee, provided that
- * (1) the above copyright notice and this permission notice appear in
- * all copies of the source code, and the above copyright notice
- * appear in clearly visible form on all supporting documentation
- * and distribution media;
- * (2) modified versions of this software be accompanied by a complete
- * change history describing author, date, and modifications made;
- * and
- * (3) any redistribution of the software, in original or modified
- * form, be without fee and subject to these same conditions.
- * --------------------------------------------------------------------- */
-
-#ifndef _MATRIX_H_
-#define _MATRIX_H_
-typedef struct _Matrix_element {
- int x,y;
- void *data;
- struct _Matrix_element *next;
-} Matrix_element;
-
-typedef struct {
- int elsize;
- void *zero;
- int rows,cols;
- Matrix_element *mat;
-} Matrix;
-
-
-extern Matrix newMat(int,int,int,void*);
-extern void *_Mat(Matrix*,int,int,int,char*);
-extern int Mat_dense(Matrix,int,int);
-extern void freeMat(Matrix *);
-
-#define Mat(t,m,i,j) (*((t*) _Mat(&(m),i,j,__LINE__,__FILE__)))
-#endif
diff --git a/ghc/utils/prof/cgprof/symbol.c b/ghc/utils/prof/cgprof/symbol.c
deleted file mode 100644
index 133f59b2db..0000000000
--- a/ghc/utils/prof/cgprof/symbol.c
+++ /dev/null
@@ -1,115 +0,0 @@
-/* ------------------------------------------------------------------------
- * $Id: symbol.c,v 1.3 2003/08/01 14:50:50 panne Exp $
- *
- * Copyright (C) 1995-2000 University of Oxford
- *
- * Permission to use, copy, modify, and distribute this software,
- * and to incorporate it, in whole or in part, into other software,
- * is hereby granted without fee, provided that
- * (1) the above copyright notice and this permission notice appear in
- * all copies of the source code, and the above copyright notice
- * appear in clearly visible form on all supporting documentation
- * and distribution media;
- * (2) modified versions of this software be accompanied by a complete
- * change history describing author, date, and modifications made;
- * and
- * (3) any redistribution of the software, in original or modified
- * form, be without fee and subject to these same conditions.
- * --------------------------------------------------------------------- */
-
-#include <string.h>
-#include "symbol.h"
-
-/* -----------------------------------------------------------------------------
- * Data structures
- * -------------------------------------------------------------------------- */
-int symbol_table_next=0;
-int symbol_table_size=0;
-name_object *symbol_table=NULL;
-
-/* -----------------------------------------------------------------------------
- * Create/grow symbol table
- * -------------------------------------------------------------------------- */
-
-void enlargeSymbolTable() {
-
- if (symbol_table_size==0) {
- symbol_table_next = 0;
- symbol_table_size = SYMBOL_TABLE_INIT_SIZE;
- symbol_table = calloc(symbol_table_size,sizeof(name_object));
- } else {
- symbol_table_size += SYMBOL_TABLE_INIT_SIZE;
- symbol_table = realloc(symbol_table,
- symbol_table_size*sizeof(name_object));
- }
- if (symbol_table==NULL) {
- fprintf(stderr,"{enlargeSymbolTable} unable to allocate %d elements",
- symbol_table_size);
- exit(1);
- }
-}
-
-/* -----------------------------------------------------------------------------
- * Lookup/add name to symbol table
- * -------------------------------------------------------------------------- */
-
-name_id lookupSymbolTable(int type,int lineno,char* str) {
- int i;
- extern FILE *logFile;
-
- for(i=0;i<symbol_table_next;i++) {
- if ((type==symbol_table[i].type) &&
- (strcmp(str,symbol_table[i].filename)==0) &&
- (type==CG_STACK || (lineno==symbol_table[i].lineno))) {
- return i;
- }
- }
- fprintf(logFile,"{lookupSymbolTable} %d at %s line %d\n",type,str,lineno);
- if (symbol_table_next==symbol_table_size) enlargeSymbolTable();
- symbol_table[symbol_table_next].type = type;
- symbol_table[symbol_table_next].lineno = lineno;
- symbol_table[symbol_table_next].filename= malloc(1+strlen(str));
- if (symbol_table[symbol_table_next].filename==NULL) {
- fprintf(stderr,"{lookupSymbolTable} failed to allocate space");
- exit(1);
- }
- strcpy(symbol_table[symbol_table_next].filename,str);
- return (symbol_table_next++);
-}
-
-/* -----------------------------------------------------------------------------
- * Comparison function to be used by \texttt{qsort}
- * -------------------------------------------------------------------------- */
-
-int cmp_symbol_entry(const int *x, const int *y) {
- int i;
-
- if (symbol_table[*x].type==symbol_table[*y].type) {
- i = strcmp(symbol_table[*x].filename,symbol_table[*y].filename);
- if (i==0) return (symbol_table[*x].lineno - symbol_table[*y].lineno);
- else return i;
- } else {
- if (symbol_table[*x].type==CG_STACK) return 1;
- else return -1;
- }
-}
-
-
-/* -----------------------------------------------------------------------------
- * Pretty print a symbol table entry
- * -------------------------------------------------------------------------- */
-
-void printSymbolTable_entry(int idx) {
- extern FILE *logFile;
- if (symbol_table[idx].type==CG_SSTEP) {
- fprintf(logFile,"(line %d of %s) ",symbol_table[idx].lineno,
- symbol_table[idx].filename);
- } else {
- fprintf(logFile,"%s ",symbol_table[idx].filename);
- }
-}
-
-void getNameFromSymbolTable(int idx, char* name) {
- strcpy(name,symbol_table[idx].filename);
-}
-
diff --git a/ghc/utils/prof/cgprof/symbol.h b/ghc/utils/prof/cgprof/symbol.h
deleted file mode 100644
index 697973150c..0000000000
--- a/ghc/utils/prof/cgprof/symbol.h
+++ /dev/null
@@ -1,58 +0,0 @@
-/* ------------------------------------------------------------------------
- * $Id: symbol.h,v 1.1 2000/04/05 10:06:36 simonmar Exp $
- *
- * Copyright (C) 1995-2000 University of Oxford
- *
- * Permission to use, copy, modify, and distribute this software,
- * and to incorporate it, in whole or in part, into other software,
- * is hereby granted without fee, provided that
- * (1) the above copyright notice and this permission notice appear in
- * all copies of the source code, and the above copyright notice
- * appear in clearly visible form on all supporting documentation
- * and distribution media;
- * (2) modified versions of this software be accompanied by a complete
- * change history describing author, date, and modifications made;
- * and
- * (3) any redistribution of the software, in original or modified
- * form, be without fee and subject to these same conditions.
- * --------------------------------------------------------------------- */
-
-#include <stdlib.h>
-#include <stdio.h>
-#include <limits.h>
-
-/* -----------------------------------------------------------------------------
- * Symbol table associated with cost centres
- * -------------------------------------------------------------------------- */
-
-#ifndef _SYMBOL_H_
-#define _SYMBOL_H_
-#define CG_STACK 42
-#define CG_SSTEP 1968
-
-
-#define MAX_PROFILE_LINE_LENGTH 10000
-#define MAX_STACK_DEPTH 60
-#define MAX_FUNNAME 80
-
-
-typedef struct {
- int type; /* Either CG_STACK or CG_SSTEP */
- int lineno;
- char *filename;
-} name_object;
-
-typedef int name_id; /* i.e. index into symbol table */
-
-#define SYMBOL_TABLE_INIT_SIZE 100
-extern int symbol_table_next;
-extern int symbol_table_size;
-extern name_object *symbol_table;
-
-
-extern void printSymbolTable(int , int *);
-extern int cmp_symbol_entry(const int *, const int *);
-extern name_id lookupSymbolTable(int,int,char*);
-extern void printSymbolTable_entry(int);
-extern void getNameFromSymbolTable(int,char*);
-#endif
diff --git a/ghc/utils/prof/ghcprof.prl b/ghc/utils/prof/ghcprof.prl
deleted file mode 100644
index bc3b344228..0000000000
--- a/ghc/utils/prof/ghcprof.prl
+++ /dev/null
@@ -1,280 +0,0 @@
-# -----------------------------------------------------------------------------
-# $Id: ghcprof.prl,v 1.5 2005/04/22 08:41:00 simonmar Exp $
-#
-# (c) The GHC Team 2000
-#
-# needs: FPTOOLS_TOP_ABS, INSTALLING, DEFAULT_TMPDIR, TARGETPLATFORM, libexecdir
-#
-
-if ($ENV{'UDG_HOME'}) {
- $udrawgraphhome = $ENV{'UDG_HOME'};
- $udrawgraph = $udrawgraphhome . "/bin/uDrawGraph";
-} else {
- print STDERR "ghcprof: UDG_HOME environment variable not set\n";
- exit(1);
-}
-
-$machname = ${TARGETPLATFORM};
-$bsp_s = 10.0;
-$bsp_l = 12;
-$bsp_g = 13;
-$MaxNoNodes = 1900;
-
-$icondir = ( $INSTALLING ? "$libexecdir/icons"
- : "$FPTOOLS_TOP_ABS/ghc/utils/prof/icons" );
-
-$xmlparser = ( $INSTALLING ? "$libexecdir/xmlparser"
- : "$FPTOOLS_TOP_ABS/ghc/utils/prof/xmlparser/xmlparser" );
-
-$cgprof_dir = ( $INSTALLING ? "$libexecdir"
- : "$FPTOOLS_TOP_ABS/ghc/utils/prof/cgprof" );
-
-# where to make tmp file names?
-if ( $ENV{'TMPDIR'} ) {
- $Tmp_prefix = $ENV{'TMPDIR'} . "/ghcprof";
-} else {
- $Tmp_prefix ="${DEFAULT_TMPDIR}/ghcprof";
- $ENV{'TMPDIR'} = "${DEFAULT_TMPDIR}"; # set the env var as well
-}
-
-# Create a new temporary filename.
-$i = $$;
-$tempfile = "";
-while (-e ($tempfile = "$Tmp_prefix" . "$i")) {
- $i++;
-};
-
-# Create a second temporary filename.
-$i = $$;
-$tempfile2 = "";
-while (-e ($tempfile2 = "$Tmp_prefix" . "$i" . ".sh")) {
- $i++;
-};
-
-# Delete temp. file if script is halted.
-sub quit_upon_signal {
- if ($tempfile ne "" && -e $tempfile) {
- print STDERR "Deleting $tempfile .. \n" if $Verbose;
- unlink "$tempfile";
- };
- if ($tempfile2 ne "" && -e $tempfile2) {
- print STDERR "Deleting $tempfile2 .. \n" if $Verbose;
- unlink "$tempfile2";
- }
-}
-
-$SIG{'INT'} = 'quit_upon_signal';
-$SIG{'QUIT'} = 'quit_upon_signal';
-
-sub tidy_up_and_die {
- local($msg) = @_;
-
- print STDERR "$Pgm: $msg\n";
- quit_upon_signal;
- exit(1);
-}
-
-select(STDERR); $| = 1; select(STDOUT); # no STDERR buffering, please.
-($Pgm = $0) =~ s|.*/||;
-$Version = "v2.1 10-3-2000";
-$bug_reports_to = 'stephen.jarvis@dcs.warwick.ac.uk';
-
-$ShortUsage = "\n$Pgm usage: for basic information, try the `-help' option\n";
-
-$Usage = <<EOF
-Usage: $Pgm [option...] filename.prof
-
-Options:
- -v Verbose
- -hide (???)
- -nologo Omit the logo
- -grey Greyscale only
- -color Enable color (default)
- -normalise (???)
-EOF
- ;
-
-$Verbose = 0;
-$InputFile = "";
-$date = "";
-$nprocs = 0;
-$hide = 0.01;
-$Logo = 1;
-$Colour = 1;
-$DeltaNormalise= 2;
-
- arg: while ($_ = $ARGV[0]) {
- shift(@ARGV);
- #--------HELP------------------------------------------------
- /^-help$/ && do { print STDERR $Usage; exit(0); };
-
- /^-v$/ && do {$Verbose = 1; next arg;};
-
- /^-hide$/ && do {$hide= &grab_next_arg("-hide");
- if (($hide =~ /^(\d+.\d+)$/) || ($hide =~ /^(\d+)$/)) {
- $hide = $1/100.0;
- } else {
- print STDERR "$Pgm: -hide requires a percentage as ",
- "an argument\n";
- $Status++;
- }
- next arg;};
-
- /^-nologo$/ && do {$Logo =0; next arg;};
- /^-gr(e|a)y$/ && do {$Colour=0; next arg;};
- /^-colou?r$/ && do {$Colour=1; next arg;};
- /^-normalise$/ && do {$DeltaNormalise = &grab_next_arg("-normalise");
- if ($DeltaNormalise =~ /^(\d+)$/) {
- $DeltaNormalise = int($DeltaNormalise);
- } else {
- print STDERR "$Pgm: -normalise requires an integer ",
- "an argument\n";
- $Status++;
- }
- next arg;};
-
- /^-/ && do { print STDERR "$Pgm: unrecognised option \"",$_,"\"\n";
- $Status++;
- };
-
- if ($InputFile eq "") {
- $InputFile = $_; next arg;
- } else {
- $Status++;
- };
- }
-
-if ($InputFile eq "") {
- print STDERR "$Pgm: no input file given\n";
- $Status++;
-}
-if ($Status>0) {
- print STDERR $ShortUsage;
- exit(1);
-}
-print STDERR "$Pgm: ($Version)\n" if $Verbose;
-
-# -----------------------------------------------------------------------------
-# Parse the XML
-
-# ToDo: use the real xmlparser
-# system("$xmlparser < $InputFile > $tempfile");
-# if ($? != 0) { tidy_up_and_die("xmlparser failed"); }
-
-# Stehpen's hacky replacement for xmlparser:
-
-$cc_write = 1;
-$ccs_write = 1;
-$scc_write = 1;
-
-open(INPUT, "<$InputFile") || tidy_up_and_die("can't open `$InputFile'");
-open(TEMPFILE, ">$tempfile") || tidy_up_and_die("can't create `$tempfile'");
-
-while (<INPUT>) {
- if (/^1 (\d+) (.*)$/)
- {
- if ($cc_write) {
- print TEMPFILE ">>cost_centre\n";
- $cc_write = 0;
- }
- $cc_id = $1;
- $name = $2;
- $module = $3;
- print TEMPFILE "$cc_id $name $module\n";
- }
- if (/^2 (\d+) (\d+) (\d+)$/)
- {
- if ($ccs_write) {
- print TEMPFILE ">>cost_centre_stack\n";
- $ccs_write = 0;
- }
- $ccs_id = $1;
- $ccptr = $2;
- $ccsptr = $3;
- print TEMPFILE "$ccs_id $ccptr $ccsptr\n";
- }
- elsif (/^2 (\d+) (\d+) (\d+) (\d+)$/)
- {
- if ($ccs_write) {
- print TEMPFILE ">>cost_centre_stack\n";
- $ccs_write = 0;
- }
- $ccs_id = $1;
- $type = $2;
- $ccptr = $3;
- $ccsptr = $4;
- print TEMPFILE "$ccs_id $type $ccptr $ccsptr\n";
- }
- if (/^5 (\d+) (.*)$/)
- {
- if ($scc_write) {
- print TEMPFILE ">>scc_sample\n";
- $scc_write = 0;
- }
- $_ = $2;
- while (/^1 (\d+) (\d+) (\d+) (\d+) (.*)$/)
- {
- $rg1 = $1;
- $rg2 = $2;
- $rg3 = $3;
- $rg4 = $4;
- print TEMPFILE "$rg1 $rg2 $rg3 $rg4\n";
- $_ = $5;
- }
- }
-}
-print TEMPFILE ">>\n";
-
-close(INPUT);
-close(TEMPFILE);
-
-&readProfileHeader();
-open(TEMPFILE2, ">$tempfile2")
- || tidy_up_and_die("can't create `$tempfile2'");
-
-$shcmd = sprintf("%s/cgprof %s %d \"%s\" " .
- "\"%s\" %.1f %.1f %.1f %.1f %d %d %d %d %d",
- $cgprof_dir,$tempfile,$nprocs,$machname,$date,
- $bsp_s,$bsp_l,$bsp_g,$hide,$Verbose,$Logo,$Colour,
- $DeltaNormalise,$MaxNoNodes);
-print TEMPFILE2 "#!/bin/sh\n";
-print TEMPFILE2 "$shcmd\n";
-close(TEMPFILE2);
-
-chmod 0755, $tempfile2;
-$cmd = "env UDG_ICONDIR=$icondir UDG_HOME=$udrawgraphhome " .
- $udrawgraph . " -startappl . $tempfile2";
-print STDERR "$Pgm: exec $cmd\n" if $Verbose;
-exec $cmd;
-exit(0);
-
-sub readProfileHeader {
- local($found);
-
- open(PROFILE,$tempfile) || tidy_up_and_die("can't open `$tempfile'");
- $found=0;
-
- while(<PROFILE>) {
- if (/^F/) {
- if (/-prof/ && /-flibrary-level\s+(\d+)/) {
- $libtype = "P$1";
- } elsif (/-flibrary-level\s+(\d+)/) {
- $libtype = "O$1";
- }
- $found++;
-
- } elsif (/^P\s*/) {
- $nprocs = int($');
- $found++;
-
- } elsif (/^D\s*/) {
- chop($date = $');
- $found++;
-
- } elsif (/^X\s*/) {
- chop($device = $');
- }
- last if ($found>=3);
- }
- close(PROFILE);
-}
diff --git a/ghc/utils/prof/icons/Makefile b/ghc/utils/prof/icons/Makefile
deleted file mode 100644
index 5b3eb4d40b..0000000000
--- a/ghc/utils/prof/icons/Makefile
+++ /dev/null
@@ -1,13 +0,0 @@
-#-----------------------------------------------------------------------------
-# $Id: Makefile,v 1.1 2000/04/05 10:11:55 simonmar Exp $
-#
-# (c) The GHC Team, 2000
-#
-
-TOP=../../..
-include $(TOP)/mk/boilerplate.mk
-
-override datadir=$(libdir)/icons
-INSTALL_DATAS=$(wildcard *.xbm)
-
-include $(TOP)/mk/target.mk
diff --git a/ghc/utils/prof/icons/absdelta.xbm b/ghc/utils/prof/icons/absdelta.xbm
deleted file mode 100644
index e70e372dd0..0000000000
--- a/ghc/utils/prof/icons/absdelta.xbm
+++ /dev/null
@@ -1,8 +0,0 @@
-#define absdelta_width 18
-#define absdelta_height 18
-static unsigned char absdelta_bits[] = {
- 0xfc, 0xff, 0x00, 0x04, 0x80, 0x00, 0xe4, 0x9f, 0x00, 0x04, 0x80, 0x00,
- 0xe4, 0x9f, 0x00, 0x04, 0x83, 0x00, 0x04, 0x83, 0x00, 0x04, 0x83, 0x00,
- 0x04, 0x83, 0x00, 0x04, 0x83, 0x00, 0x04, 0x83, 0x00, 0x04, 0x83, 0x00,
- 0x04, 0x83, 0x00, 0x04, 0x83, 0x00, 0x04, 0x83, 0x00, 0xe4, 0x9f, 0x00,
- 0x04, 0x80, 0x00, 0xfc, 0xff, 0x00};
diff --git a/ghc/utils/prof/icons/absolute.xbm b/ghc/utils/prof/icons/absolute.xbm
deleted file mode 100644
index 045e1601f3..0000000000
--- a/ghc/utils/prof/icons/absolute.xbm
+++ /dev/null
@@ -1,8 +0,0 @@
-#define absolute_width 18
-#define absolute_height 18
-static unsigned char absolute_bits[] = {
- 0xfc, 0xff, 0x00, 0x04, 0x80, 0x00, 0x04, 0x80, 0x00, 0xe4, 0x9f, 0x00,
- 0x04, 0x83, 0x00, 0x04, 0x83, 0x00, 0x04, 0x83, 0x00, 0x04, 0x83, 0x00,
- 0x04, 0x83, 0x00, 0x04, 0x83, 0x00, 0x04, 0x83, 0x00, 0x04, 0x83, 0x00,
- 0x04, 0x83, 0x00, 0x04, 0x83, 0x00, 0xe4, 0x9f, 0x00, 0x04, 0x80, 0x00,
- 0x04, 0x80, 0x00, 0xfc, 0xff, 0x00};
diff --git a/ghc/utils/prof/icons/comm.xbm b/ghc/utils/prof/icons/comm.xbm
deleted file mode 100644
index 3f1fe9412b..0000000000
--- a/ghc/utils/prof/icons/comm.xbm
+++ /dev/null
@@ -1,8 +0,0 @@
-#define time_width 18
-#define time_height 18
-static unsigned char time_bits[] = {
- 0x00, 0x00, 0x00, 0xe0, 0x0f, 0x00, 0x38, 0x38, 0x00, 0x8c, 0x61, 0x00,
- 0x86, 0xc1, 0x00, 0x82, 0x81, 0x00, 0x83, 0x81, 0x01, 0x81, 0x01, 0x01,
- 0x81, 0x01, 0x01, 0x81, 0x01, 0x01, 0x01, 0x03, 0x01, 0x01, 0x06, 0x01,
- 0x03, 0x8c, 0x01, 0x02, 0x98, 0x00, 0x06, 0xc0, 0x00, 0x0c, 0x60, 0x00,
- 0x38, 0x38, 0x00, 0xe0, 0x0f, 0x00};
diff --git a/ghc/utils/prof/icons/commslack.xbm b/ghc/utils/prof/icons/commslack.xbm
deleted file mode 100644
index f53e40fa8f..0000000000
--- a/ghc/utils/prof/icons/commslack.xbm
+++ /dev/null
@@ -1,8 +0,0 @@
-#define commslack_width 18
-#define commslack_height 18
-static unsigned char commslack_bits[] = {
- 0xe0, 0x1f, 0x00, 0xfc, 0xff, 0x00, 0x67, 0x98, 0x03, 0x67, 0x98, 0x03,
- 0xc7, 0x8f, 0x03, 0x60, 0x18, 0x00, 0xb0, 0x37, 0x00, 0xb8, 0x77, 0x00,
- 0xbc, 0xf7, 0x00, 0x7c, 0xf8, 0x00, 0xfc, 0xff, 0x00, 0xfc, 0xff, 0x00,
- 0x00, 0x00, 0x00, 0xdc, 0xc4, 0x01, 0x48, 0x45, 0x00, 0x48, 0xc5, 0x01,
- 0x48, 0x45, 0x00, 0xdc, 0xdc, 0x01};
diff --git a/ghc/utils/prof/icons/comp.xbm b/ghc/utils/prof/icons/comp.xbm
deleted file mode 100644
index 923ef2f3de..0000000000
--- a/ghc/utils/prof/icons/comp.xbm
+++ /dev/null
@@ -1,8 +0,0 @@
-#define comp_width 18
-#define comp_height 18
-static unsigned char comp_bits[] = {
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0xff, 0x03,
- 0x01, 0x00, 0x02, 0x01, 0x00, 0x02, 0x19, 0x63, 0x02, 0xa5, 0x94, 0x02,
- 0x85, 0x10, 0x02, 0x99, 0x10, 0x02, 0xa1, 0x10, 0x02, 0xa5, 0x94, 0x02,
- 0x19, 0x63, 0x02, 0x01, 0x00, 0x02, 0x01, 0x00, 0x02, 0xff, 0xff, 0x03,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
diff --git a/ghc/utils/prof/icons/compress.xbm b/ghc/utils/prof/icons/compress.xbm
deleted file mode 100644
index 39ff2f828e..0000000000
--- a/ghc/utils/prof/icons/compress.xbm
+++ /dev/null
@@ -1,8 +0,0 @@
-#define compress_width 18
-#define compress_height 18
-static unsigned char compress_bits[] = {
- 0x03, 0x00, 0x03, 0x07, 0x80, 0x03, 0x0e, 0xc0, 0x01, 0x9c, 0xe4, 0x00,
- 0xb8, 0x74, 0x00, 0xf0, 0x3c, 0x00, 0xe0, 0x1c, 0x00, 0xf8, 0x7c, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xf8, 0x7c, 0x00, 0xe0, 0x1c, 0x00,
- 0xf0, 0x3c, 0x00, 0xb8, 0x74, 0x00, 0x9c, 0xe4, 0x00, 0x0e, 0xc0, 0x01,
- 0x07, 0x80, 0x03, 0x03, 0x00, 0x03};
diff --git a/ghc/utils/prof/icons/compslack.xbm b/ghc/utils/prof/icons/compslack.xbm
deleted file mode 100644
index 4592554582..0000000000
--- a/ghc/utils/prof/icons/compslack.xbm
+++ /dev/null
@@ -1,8 +0,0 @@
-#define compslack_width 18
-#define compslack_height 18
-static unsigned char compslack_bits[] = {
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xf8, 0x7f, 0x00, 0x08, 0x40, 0x00,
- 0xa8, 0x4a, 0x00, 0x48, 0x55, 0x00, 0xa8, 0x4a, 0x00, 0x48, 0x55, 0x00,
- 0xa8, 0x4a, 0x00, 0x08, 0x40, 0x00, 0xf8, 0x7f, 0x00, 0x80, 0x07, 0x00,
- 0x00, 0x00, 0x00, 0xdc, 0xc4, 0x01, 0x48, 0x45, 0x00, 0x48, 0xc5, 0x01,
- 0x48, 0x45, 0x00, 0xdc, 0xdc, 0x01};
diff --git a/ghc/utils/prof/icons/delete.xbm b/ghc/utils/prof/icons/delete.xbm
deleted file mode 100644
index 166d605a5a..0000000000
--- a/ghc/utils/prof/icons/delete.xbm
+++ /dev/null
@@ -1,8 +0,0 @@
-#define delete_width 18
-#define delete_height 18
-static unsigned char delete_bits[] = {
- 0xc0, 0x0f, 0x00, 0xe0, 0x1f, 0x00, 0xf0, 0x3f, 0x00, 0x38, 0x73, 0x00,
- 0x38, 0x73, 0x00, 0xf8, 0x7f, 0x00, 0xf8, 0x7f, 0x00, 0xf0, 0x3f, 0x00,
- 0xe0, 0x1f, 0x00, 0x80, 0x07, 0x00, 0x8c, 0xc7, 0x00, 0x0c, 0xc0, 0x00,
- 0x70, 0x38, 0x00, 0x80, 0x07, 0x00, 0x70, 0x38, 0x00, 0x0c, 0xc0, 0x00,
- 0x0c, 0xc0, 0x00, 0x00, 0x00, 0x00};
diff --git a/ghc/utils/prof/icons/help.xbm b/ghc/utils/prof/icons/help.xbm
deleted file mode 100644
index 688e7dbd28..0000000000
--- a/ghc/utils/prof/icons/help.xbm
+++ /dev/null
@@ -1,8 +0,0 @@
-#define help_width 18
-#define help_height 18
-static unsigned char help_bits[] = {
- 0xe0, 0x1f, 0x00, 0xf0, 0x3f, 0x00, 0x70, 0x38, 0x00, 0x70, 0x38, 0x00,
- 0x70, 0x38, 0x00, 0x70, 0x38, 0x00, 0x00, 0x3c, 0x00, 0x00, 0x1e, 0x00,
- 0x00, 0x0f, 0x00, 0x80, 0x07, 0x00, 0x80, 0x07, 0x00, 0x80, 0x07, 0x00,
- 0x80, 0x07, 0x00, 0x00, 0x00, 0x00, 0x00, 0x03, 0x00, 0x80, 0x07, 0x00,
- 0x80, 0x07, 0x00, 0x00, 0x03, 0x00};
diff --git a/ghc/utils/prof/icons/hrel.xbm b/ghc/utils/prof/icons/hrel.xbm
deleted file mode 100644
index 36e58a9baf..0000000000
--- a/ghc/utils/prof/icons/hrel.xbm
+++ /dev/null
@@ -1,8 +0,0 @@
-#define hrel_width 18
-#define hrel_height 18
-static unsigned char hrel_bits[] = {
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x02, 0x00, 0x01, 0x05, 0x80, 0x02, 0xe8, 0x5c, 0x00,
- 0x10, 0x23, 0x00, 0x10, 0x23, 0x00, 0x10, 0x23, 0x00, 0xe0, 0x1c, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
diff --git a/ghc/utils/prof/icons/hrelslack.xbm b/ghc/utils/prof/icons/hrelslack.xbm
deleted file mode 100644
index 8de8f0d36a..0000000000
--- a/ghc/utils/prof/icons/hrelslack.xbm
+++ /dev/null
@@ -1,8 +0,0 @@
-#define hrelslack_width 18
-#define hrelslack_height 18
-static unsigned char hrelslack_bits[] = {
- 0x33, 0x00, 0x00, 0x33, 0x00, 0x00, 0x33, 0x00, 0x00, 0x33, 0x00, 0x00,
- 0xbf, 0xbb, 0x00, 0xbf, 0x8a, 0x00, 0xb3, 0xba, 0x00, 0xb3, 0x89, 0x00,
- 0xb3, 0xba, 0x03, 0x00, 0x00, 0x00, 0xfc, 0xff, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0xdc, 0xc4, 0x01, 0x48, 0x45, 0x00, 0x48, 0xc5, 0x01,
- 0x48, 0x45, 0x00, 0xdc, 0xdc, 0x01};
diff --git a/ghc/utils/prof/icons/jump.xbm b/ghc/utils/prof/icons/jump.xbm
deleted file mode 100644
index 0e0327d45f..0000000000
--- a/ghc/utils/prof/icons/jump.xbm
+++ /dev/null
@@ -1,8 +0,0 @@
-#define jump_width 18
-#define jump_height 18
-static unsigned char jump_bits[] = {
- 0x00, 0x00, 0x00, 0x7e, 0x00, 0x00, 0x42, 0x55, 0x01, 0x42, 0x00, 0x02,
- 0x7e, 0x01, 0x00, 0x88, 0x00, 0x02, 0x08, 0x01, 0x00, 0x7e, 0x7e, 0x02,
- 0x42, 0x43, 0x00, 0x42, 0x42, 0x02, 0x7e, 0x7f, 0x00, 0x00, 0x00, 0x02,
- 0x00, 0x55, 0x01, 0x00, 0x00, 0x00, 0x57, 0xdb, 0x01, 0x52, 0x55, 0x01,
- 0x52, 0xd1, 0x01, 0x73, 0x51, 0x00};
diff --git a/ghc/utils/prof/icons/mycomm.xbm b/ghc/utils/prof/icons/mycomm.xbm
deleted file mode 100644
index 8a3adcdb25..0000000000
--- a/ghc/utils/prof/icons/mycomm.xbm
+++ /dev/null
@@ -1,8 +0,0 @@
-#define comm_width 18
-#define comm_height 18
-static unsigned char comm_bits[] = {
- 0xe0, 0x1f, 0x00, 0xfc, 0xff, 0x00, 0x67, 0x98, 0x03, 0x67, 0x98, 0x03,
- 0xc7, 0x8f, 0x03, 0x60, 0x18, 0x00, 0xb0, 0x37, 0x00, 0xb8, 0x77, 0x00,
- 0xbc, 0xf7, 0x00, 0x7c, 0xf8, 0x00, 0xfc, 0xff, 0x00, 0xfc, 0xff, 0x00,
- 0x00, 0x00, 0x00, 0x8c, 0x51, 0x00, 0x52, 0xaa, 0x00, 0x42, 0xaa, 0x00,
- 0x52, 0x8a, 0x00, 0x8c, 0x89, 0x00};
diff --git a/ghc/utils/prof/icons/oxpara.xbm b/ghc/utils/prof/icons/oxpara.xbm
deleted file mode 100644
index 323270f9dd..0000000000
--- a/ghc/utils/prof/icons/oxpara.xbm
+++ /dev/null
@@ -1,198 +0,0 @@
-#define oxpara_width 287
-#define oxpara_height 65
-static unsigned char oxpara_bits[] = {
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
diff --git a/ghc/utils/prof/icons/percent.xbm b/ghc/utils/prof/icons/percent.xbm
deleted file mode 100644
index 1dd05821c6..0000000000
--- a/ghc/utils/prof/icons/percent.xbm
+++ /dev/null
@@ -1,8 +0,0 @@
-#define percent_width 18
-#define percent_height 18
-static unsigned char percent_bits[] = {
- 0x00, 0x00, 0x00, 0x38, 0x80, 0x01, 0x7c, 0xc0, 0x01, 0xfe, 0xe0, 0x00,
- 0xfe, 0x70, 0x00, 0xfe, 0x38, 0x00, 0x7c, 0x1c, 0x00, 0x38, 0x0e, 0x00,
- 0x00, 0x07, 0x00, 0x80, 0x03, 0x00, 0xc0, 0x71, 0x00, 0xe0, 0xf8, 0x00,
- 0x70, 0xfc, 0x01, 0x38, 0xfc, 0x01, 0x1c, 0xfc, 0x01, 0x0e, 0xf8, 0x00,
- 0x06, 0x70, 0x00, 0x00, 0x00, 0x00};
diff --git a/ghc/utils/prof/icons/reldelta.xbm b/ghc/utils/prof/icons/reldelta.xbm
deleted file mode 100644
index 4e79b68ba8..0000000000
--- a/ghc/utils/prof/icons/reldelta.xbm
+++ /dev/null
@@ -1,8 +0,0 @@
-#define reldelta_width 18
-#define reldelta_height 18
-static unsigned char reldelta_bits[] = {
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x04, 0x00, 0x04, 0x06, 0x00,
- 0x0e, 0x03, 0x00, 0x91, 0x21, 0x00, 0xd1, 0x50, 0x00, 0x6a, 0x88, 0x00,
- 0x1c, 0x44, 0x01, 0x1c, 0x22, 0x02, 0x6a, 0x50, 0x00, 0xd1, 0x88, 0x00,
- 0x91, 0x41, 0x01, 0x0e, 0x23, 0x02, 0x04, 0x06, 0x00, 0x00, 0x04, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
diff --git a/ghc/utils/prof/icons/sync.xbm b/ghc/utils/prof/icons/sync.xbm
deleted file mode 100644
index 55f3e55ff4..0000000000
--- a/ghc/utils/prof/icons/sync.xbm
+++ /dev/null
@@ -1,8 +0,0 @@
-#define sync_width 18
-#define sync_height 18
-static unsigned char sync_bits[] = {
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x20, 0x00, 0x00, 0x70, 0x00, 0x00,
- 0x20, 0x00, 0x00, 0x50, 0x00, 0x00, 0x88, 0x00, 0x00, 0x04, 0x01, 0x00,
- 0x02, 0x02, 0x00, 0x07, 0x07, 0x00, 0x02, 0x02, 0x00, 0x00, 0x05, 0x00,
- 0x80, 0x08, 0x00, 0x40, 0x10, 0x00, 0x20, 0x20, 0x00, 0x70, 0x70, 0x00,
- 0x20, 0x20, 0x00, 0x00, 0x00, 0x00};
diff --git a/ghc/utils/prof/icons/time.xbm b/ghc/utils/prof/icons/time.xbm
deleted file mode 100644
index e8a79375b3..0000000000
--- a/ghc/utils/prof/icons/time.xbm
+++ /dev/null
@@ -1,8 +0,0 @@
-#define time_width 18
-#define time_height 18
-static unsigned char time_bits[] = {
- 0x80, 0x01, 0x00, 0x80, 0x01, 0x00, 0xe0, 0x0f, 0x00, 0xf8, 0x3f, 0x00,
- 0x9c, 0x31, 0x00, 0x8c, 0x01, 0x00, 0x9c, 0x01, 0x00, 0xf8, 0x0f, 0x00,
- 0xe0, 0x3f, 0x00, 0x80, 0x39, 0x00, 0x80, 0x61, 0x00, 0x80, 0x61, 0x00,
- 0x8c, 0x71, 0x00, 0x9c, 0x39, 0x00, 0xf8, 0x1f, 0x00, 0xf0, 0x07, 0x00,
- 0x80, 0x01, 0x00, 0x80, 0x01, 0x00};
diff --git a/ghc/utils/prof/icons/time1.xbm b/ghc/utils/prof/icons/time1.xbm
deleted file mode 100644
index 0d2d4d7268..0000000000
--- a/ghc/utils/prof/icons/time1.xbm
+++ /dev/null
@@ -1,8 +0,0 @@
-#define time_width 18
-#define time_height 18
-static unsigned char time_bits[] = {
- 0x80, 0x01, 0x00, 0x80, 0x01, 0x00, 0xe0, 0x1f, 0x00, 0xf0, 0x3f, 0x00,
- 0x98, 0x31, 0x00, 0x8c, 0x01, 0x00, 0x9c, 0x01, 0x00, 0xf8, 0x0f, 0x00,
- 0xe0, 0x1f, 0x00, 0x80, 0x31, 0x00, 0x80, 0x61, 0x00, 0x80, 0x61, 0x00,
- 0x80, 0x31, 0x00, 0x98, 0x19, 0x00, 0xf8, 0x0f, 0x00, 0xf0, 0x07, 0x00,
- 0x80, 0x01, 0x00, 0x80, 0x01, 0x00};
diff --git a/ghc/utils/prof/icons/uncompress.xbm b/ghc/utils/prof/icons/uncompress.xbm
deleted file mode 100644
index 56f1293316..0000000000
--- a/ghc/utils/prof/icons/uncompress.xbm
+++ /dev/null
@@ -1,8 +0,0 @@
-#define uncompress_width 18
-#define uncompress_height 18
-static unsigned char uncompress_bits[] = {
- 0x1f, 0xe0, 0x03, 0x07, 0x80, 0x03, 0x0f, 0xc0, 0x03, 0x1d, 0xe0, 0x02,
- 0x39, 0x70, 0x02, 0x70, 0x38, 0x00, 0xe0, 0x1c, 0x00, 0x40, 0x08, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x40, 0x08, 0x00, 0xe0, 0x1c, 0x00,
- 0x70, 0x38, 0x00, 0x39, 0x70, 0x02, 0x1d, 0xe0, 0x02, 0x0f, 0xc0, 0x03,
- 0x07, 0x80, 0x03, 0x1f, 0xe0, 0x03};
diff --git a/ghc/utils/prof/icons/undo.xbm b/ghc/utils/prof/icons/undo.xbm
deleted file mode 100644
index 0658dc1e8e..0000000000
--- a/ghc/utils/prof/icons/undo.xbm
+++ /dev/null
@@ -1,8 +0,0 @@
-#define undo_width 18
-#define undo_height 18
-static unsigned char undo_bits[] = {
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
- 0x95, 0x8e, 0x01, 0x95, 0x52, 0x02, 0xb5, 0x52, 0x02, 0xd5, 0x52, 0x02,
- 0x95, 0x52, 0x02, 0x97, 0x8e, 0x01, 0x00, 0x00, 0x00, 0x00, 0x40, 0x00,
- 0x00, 0x80, 0x00, 0xfe, 0xff, 0x01, 0x00, 0x00, 0x00, 0xfe, 0xff, 0x01,
- 0x04, 0x00, 0x00, 0x08, 0x00, 0x00};
diff --git a/ghc/utils/prof/icons/wait.xbm b/ghc/utils/prof/icons/wait.xbm
deleted file mode 100644
index b0c16fc014..0000000000
--- a/ghc/utils/prof/icons/wait.xbm
+++ /dev/null
@@ -1,8 +0,0 @@
-#define wait_width 18
-#define wait_height 18
-static unsigned char wait_bits[] = {
- 0x00, 0x00, 0x00, 0x80, 0x07, 0x00, 0xf0, 0x3c, 0x00, 0x08, 0x40, 0x00,
- 0x0c, 0xc0, 0x00, 0x14, 0xe0, 0x00, 0x64, 0x98, 0x00, 0x84, 0x87, 0x00,
- 0x04, 0x80, 0x00, 0x04, 0x80, 0x00, 0x04, 0x80, 0x00, 0x04, 0x80, 0x00,
- 0x04, 0x80, 0x00, 0x04, 0x80, 0x00, 0x04, 0xc0, 0x00, 0x08, 0x40, 0x00,
- 0x70, 0x38, 0x00, 0x80, 0x07, 0x00};
diff --git a/ghc/utils/prof/icons/weightdelta.xbm b/ghc/utils/prof/icons/weightdelta.xbm
deleted file mode 100644
index 9ffa012260..0000000000
--- a/ghc/utils/prof/icons/weightdelta.xbm
+++ /dev/null
@@ -1,8 +0,0 @@
-#define weightdelta_width 18
-#define weightdelta_height 18
-static unsigned char weightdelta_bits[] = {
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x04, 0x00, 0x04, 0x06, 0x00,
- 0x0e, 0x03, 0x00, 0x91, 0x01, 0x00, 0xd1, 0x00, 0x00, 0x6a, 0x04, 0x01,
- 0x1c, 0x8a, 0x02, 0x1c, 0x8a, 0x02, 0x6a, 0x24, 0x01, 0xd1, 0x00, 0x00,
- 0x91, 0x01, 0x00, 0x0e, 0x03, 0x00, 0x04, 0x06, 0x00, 0x00, 0x04, 0x00,
- 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
diff --git a/ghc/utils/pvm/README b/ghc/utils/pvm/README
deleted file mode 100644
index 5ab58ddec8..0000000000
--- a/ghc/utils/pvm/README
+++ /dev/null
@@ -1,4 +0,0 @@
-"debugger2" is our hacked version of the one that
-comes with PVM 3.3.7.
-
-Less sure about "debugger.emacs"...
diff --git a/ghc/utils/pvm/debugger.emacs b/ghc/utils/pvm/debugger.emacs
deleted file mode 100644
index ee053ca7b4..0000000000
--- a/ghc/utils/pvm/debugger.emacs
+++ /dev/null
@@ -1,37 +0,0 @@
-#!/bin/csh -f
-#
-# debugger.csh
-#
-# this script is invoked by the pvmd when a task is spawned with
-# the PvmTaskDebug flag set. it execs an xterm with script
-# debugger2 running inside.
-#
-# 06 Apr 1993 Manchek
-#
-
-if ($#argv < 1) then
- echo "usage: debugger command [args]"
- exit 1
-endif
-
-# scratch file for debugger commands
-
-set TEMPCMD=gdb$$.cmd
-set TEMPLISP=gdb$$.el
-
-# default debugger and flags
-
-#
-# run the debugger
-#
-
-echo run $argv[2-] > $TEMPCMD
-echo "(gdb "'"'"$argv[1] -q -x $TEMPCMD"'")' > $TEMPLISP
-
-emacs -l $TEMPLISP
-
-#rm -f $TEMPCMD $TEMPLISP
-
-exit 0
-
-
diff --git a/ghc/utils/pvm/debugger2 b/ghc/utils/pvm/debugger2
deleted file mode 100644
index 7cdf8b9a1a..0000000000
--- a/ghc/utils/pvm/debugger2
+++ /dev/null
@@ -1,48 +0,0 @@
-#!/bin/csh -f
-#
-# debugger2.csh
-#
-# this script is invoked in an xterm by the generic debugger script.
-# it starts the debugger and waits when it exits to prevent the
-# window from closing.
-#
-# it expects the pvmd to set envar PVM_ARCH.
-#
-# 06 Apr 1993 Manchek
-#
-
-set noglob
-
-# scratch file for debugger commands
-
-set TEMPCMD=/tmp/debugger2.$$
-
-# default debugger and flags
-
-set DBCMD="gdb"
-set DBFF="-q -x $TEMPCMD"
-
-#
-# try to pick the debugger by arch name
-#
-
-#
-# run the debugger
-#
-
-echo run $argv[2-] > $TEMPCMD
-$DBCMD $DBFF $argv[1]
-
-#$DBCMD $argv[1]
-
-#rm -f $TEMPCMD
-
-#
-# wait to go away
-#
-
-#reset
-#sleep 1
-rm -f $TEMPCMD
-exit 0
-
diff --git a/ghc/utils/runghc/Makefile b/ghc/utils/runghc/Makefile
deleted file mode 100644
index fd18313305..0000000000
--- a/ghc/utils/runghc/Makefile
+++ /dev/null
@@ -1,32 +0,0 @@
-TOP=../..
-include $(TOP)/mk/boilerplate.mk
-
-HS_PROG = runghc$(exeext)
-INSTALL_PROGS += $(HS_PROG)
-
-UseGhcForCc = YES
-SRC_MKDEPENDC_OPTS += -I$(GHC_INCLUDE_DIR)
-
-# This causes libghccompat.a to be used:
-include $(GHC_LIB_COMPAT_DIR)/compat.mk
-
-# This is required because libghccompat.a must be built with
-# $(GhcHcOpts) because it is linked to the compiler, and hence
-# we must also build with $(GhcHcOpts) here:
-SRC_HC_OPTS += $(GhcHcOpts)
-
-all :: runhaskell
-
-runhaskell : $(HS_PROG)
- $(CP) $< runhaskell$(exeext)
-
-CLEAN_FILES += runhaskell
-
-# Only install runhaskell if there isn't already one installed
-ifneq "$(findstring install, $(MAKECMDGOALS))" ""
-ifeq "$(wildcard $(bindir)/runhaskell)" ""
-INSTALL_PROGS += runhaskell$(exeext)
-endif
-endif
-
-include $(TOP)/mk/target.mk
diff --git a/ghc/utils/runghc/runghc.hs b/ghc/utils/runghc/runghc.hs
deleted file mode 100644
index f8330b5721..0000000000
--- a/ghc/utils/runghc/runghc.hs
+++ /dev/null
@@ -1,66 +0,0 @@
-{-# OPTIONS -cpp -fffi #-}
-#if __GLASGOW_HASKELL__ < 603
-#include "config.h"
-#else
-#include "ghcconfig.h"
-#endif
------------------------------------------------------------------------------
---
--- (c) The University of Glasgow, 2004
---
--- runghc program, for invoking from a #! line in a script. For example:
---
--- script.lhs:
--- #! /usr/bin/runghc
--- > main = putStrLn "hello!"
---
--- runghc accepts one flag:
---
--- -f <path> specify the path
---
--- -----------------------------------------------------------------------------
-
-module Main where
-
-import System.Environment
-import System.IO
-import Data.List
-import System.Exit
-import Data.Char
-
-import Compat.RawSystem ( rawSystem )
-import Compat.Directory ( findExecutable )
-
-main = do
- args <- getArgs
- case args of
- ('-':'f' : ghc) : args -> do
- doIt (dropWhile isSpace ghc) args
- args -> do
- mb_ghc <- findExecutable "ghc"
- case mb_ghc of
- Nothing -> dieProg ("cannot find ghc")
- Just ghc -> doIt ghc args
-
-doIt ghc args = do
- let
- (ghc_args, rest) = break notArg args
- --
- case rest of
- [] -> dieProg "syntax: runghc [-f GHCPATH] [GHC-ARGS] FILE ARG..."
- filename : prog_args -> do
- res <- rawSystem ghc (
- "-ignore-dot-ghci" : ghc_args ++
- [ "-e","System.Environment.withProgName "++show filename++" (System.Environment.withArgs ["
- ++ concat (intersperse "," (map show prog_args))
- ++ "] Main.main)", filename])
- exitWith res
-
-notArg ('-':_) = False
-notArg _ = True
-
-dieProg :: String -> IO a
-dieProg msg = do
- p <- getProgName
- hPutStrLn stderr (p ++ ": " ++ msg)
- exitWith (ExitFailure 1)
diff --git a/ghc/utils/stat2resid/Makefile b/ghc/utils/stat2resid/Makefile
deleted file mode 100644
index 42c0c4107f..0000000000
--- a/ghc/utils/stat2resid/Makefile
+++ /dev/null
@@ -1,59 +0,0 @@
-#-----------------------------------------------------------------------------
-# $Id: Makefile,v 1.11 2000/09/05 10:16:41 simonmar Exp $
-
-TOP=../..
-include $(TOP)/mk/boilerplate.mk
-
-DYN_LOADABLE_BITS = \
- parse-gcstats.prl \
- process-gcstats.prl
-
-SCRIPT_PROG=stat2resid
-SCRIPT_OBJS=stat2resid.prl
-
-#
-# Could be overridden from the cmd line (see install rule below).
-#
-INSTALLING=0
-
-ifneq "$(BIN_DIST)" "1"
-SCRIPT_SUBST_VARS=DEFAULT_TMPDIR
-endif
-
-INTERP=perl
-
-#
-# The stat2resid script is configured with a different
-# path to the supporting perl scripts, depending on whether it
-# is to be installed or not.
-#
-ifeq "$(INSTALLING)" "1"
-ifeq "$(BIN_DIST)" "1"
-SCRIPT_PREFIX_FILES += prefix.txt
-endif
-endif
-
-#
-# install setup
-#
-INSTALL_LIBS += $(DYN_LOADABLE_BITS)
-INSTALL_SCRIPTS += $(SCRIPT_PROG)
-
-
-#
-# Before really installing the script, we have to
-# reconfigure it such that the paths it refers to,
-# point to the installed utils.
-#
-install ::
- $(RM) $(SCRIPT_PROG)
- $(MAKE) $(MFLAGS) INSTALLING=1 $(SCRIPT_PROG)
-
-include $(TOP)/mk/target.mk
-
-# Hack to re-create the in-situ build tree script after
-# having just installed it.
-#
-install ::
- @$(RM) $(SCRIPT_PROG)
- @$(MAKE) $(MFLAGS) $(SCRIPT_PROG)
diff --git a/ghc/utils/stat2resid/parse-gcstats.prl b/ghc/utils/stat2resid/parse-gcstats.prl
deleted file mode 100644
index d882ee6348..0000000000
--- a/ghc/utils/stat2resid/parse-gcstats.prl
+++ /dev/null
@@ -1,232 +0,0 @@
-#
-# Subroutines to parses a ghc Garbage Collection stats file
-#
-#%gcstats = &parse_stats($ARGV[0]);
-#&print_stats(">-", %gcstats);
-#exit 0;
-
-sub to_num {
- local ($text) = @_;
- return($1 * 1000000000 + $2 * 1000000 + $3 * 1000 + $4)
- if ( $text =~ /^(\d*),(\d*),(\d*),(\d*)$/ );
- return($1 * 1000000 + $2 * 1000 + $3)
- if ( $text =~ /^(\d*),(\d*),(\d*)$/ );
- return($1 * 1000 + $2)
- if ( $text =~ /^(\d*),(\d*)$/ );
- return($1)
- if ( $text =~ /^(\d*)$/ );
- die "Error converting $text\n";
-}
-
-sub from_num {
- local ($num) = @_;
- local ($b, $m, $t, $o) = (int($num/1000000000), int($num/1000000)%1000,
- int($num/1000)%1000, $num%1000);
- return(sprintf("%d,%03d,%03d,%03d", $b, $m, $t, $o)) if $b > 0;
- return(sprintf("%d,%03d,%03d", $m, $t, $o)) if $m > 0;
- return(sprintf("%d,%03d", $t, $o)) if $t > 0;
- return(sprintf("%d", $o)) if $o > 0;
-}
-
-sub parse_stats {
- local($filename) = @_;
- local($tot_alloc, $tot_gc_user, $tot_mut_user, $tot_user,
- $tot_gc_elap, $tot_mut_elap, $tot_elap);
- local($statsfile, $line, $row, $col, $val);
- local(@stats, @hdr1, @hdr2, @line_vals);
- local(%the_stats);
- local(*STATS);
-
- open(STATS, $filename) || die "Cant open $filename \n";
- @stats = <STATS>;
-
- do {$line = shift(@stats);} until ($line !~ /^$/);
- chop($line);
- ($the_stats{"command"}, $the_stats{"args"}) = split(' ', $line, 2);
-
- do {$line = shift(@stats);} until ($line !~ /^$/);
- $line =~ /Collector:\s*([A-Z]+)\s*HeapSize:\s*([\d,]+)/;
- $the_stats{"collector"} = $1;
- $the_stats{"heapsize"} = &to_num($2);
-
- do {$line = shift(@stats);} until ($line !~ /^$/);
- chop($line);
- @hdr1 = split(' ', $line);
- $line = shift(@stats);
- chop($line);
- @hdr2 = split(' ', $line);
-
- $row = 0;
- $tot_alloc = 0;
- $tot_gc_user = 0;
- $tot_gc_elap = 0;
- $tot_mut_user = 0;
- $tot_mut_elap = 0;
- $tot_user = 0;
- $tot_elap = 0;
-
- while (($line = shift(@stats)) !~ /^\s*\d+\s*$/) {
- chop($line);
- @line_vals = split(' ', $line);
-
- $col = -1;
- word:
- while(++$col <= $#line_vals) {
-
- $val = $line_vals[$col];
- $_ = @hdr1[$col] . @hdr2[$col];
-
- /^Allocbytes$/ && do { $tot_alloc += $val;
- $the_stats{"alloc_$row"} = $val;
- next word; };
-
- /^Collectbytes$/ && do { $the_stats{"collect_$row"} = $val;
- next word; };
-
- /^Livebytes$/ && do { $the_stats{"live_$row"} = $val;
- next word; };
-
- /^Residency$/ && do { next word; };
-
- /^GCuser$/ && do { $tot_gc_user += $val;
- $the_stats{"gc_user_$row"} = $val;
- next word; };
-
- /^GCelap$/ && do { $tot_gc_elap += $val;
- $the_stats{"gc_elap_$row"} = $val;
- next word; };
-
- /^TOTuser$/ && do { $the_stats{"mut_user_$row"} =
- $val - $tot_user - $the_stats{"gc_user_$row"};
- $tot_mut_user += $the_stats{"mut_user_$row"};
- $tot_user = $val;
- next word; };
-
- /^TOTelap$/ && do { $the_stats{"mut_elap_$row"} =
- $val - $tot_elap - $the_stats{"gc_elap_$row"};
- $tot_mut_elap += $the_stats{"mut_elap_$row"};
- $tot_elap = $val;
- next word; };
-
- /^PageGC$/ && do { $the_stats{"gc_pflts_$row"} = $val;
- next word; };
-
- /^FltsMUT$/ && do { $the_stats{"mut_pflts_$row"} = $val;
- next word; };
-
- /^Collection/ && do { $the_stats{"mode_$row"} = $val;
- next word; };
-
- /^Astkbytes$/ && do {next word; };
- /^Bstkbytes$/ && do {next word; };
- /^CafNo$/ && do {next word; };
- /^Cafbytes$/ && do {next word; };
-
- /^NoAstk$/ && do {next word; };
- /^ofBstk$/ && do {next word; };
- /^RootsReg$/ && do {next word; };
- /^OldGen$/ && do {next word; };
- /^RootsCaf$/ && do {next word; };
- /^Sizebytes$/ && do {next word; };
- /^Resid\%heap$/ && do {next word; };
-
- /^$/ && do {next word; };
-
- print STDERR "Unknown: $_ = $val\n";
- };
-
- $row++;
- };
- $tot_alloc += $line;
- $the_stats{"alloc_$row"} = $line;
-
-arg: while($_ = $stats[0]) {
- shift(@stats);
-
- /^\s*([\d,]+) bytes alloc/ && do { local($a) = &to_num($1);
- $a == $tot_alloc || die "Total $a != $tot_alloc \n";
- $the_stats{"alloc_total"} = $tot_alloc;
- next arg; };
-
- /^\s*([\d]+) garbage/ && do { $1 == $row || die "GCNo $1 != $row \n";
- $the_stats{"gc_no"} = $row;
- next arg; };
-
- /Total time\s+([\d\.]+)s\s+\(\s*([\d.]+)s elapsed\)/ && do {
- $the_stats{"user_total"} = $1;
- $the_stats{"elap_total"} = $2;
- $the_stats{"mut_user_total"} = $1 - $tot_gc_user;
- $the_stats{"mut_elap_total"} = $2 - $tot_gc_elap;
- $the_stats{"mut_user_$row"} = $1 - $tot_gc_user - $tot_mut_user;
- $the_stats{"mut_elap_$row"} = $2 - $tot_gc_elap - $tot_mut_elap;
- next arg; };
-
- /GC\s+time\s+([\d\.]+)s\s+\(\s*([\d.]+)s elapsed\)/ && do {
- # $1 == $tot_gc_user || die "GCuser $1 != $tot_gc_user \n";
- # $2 == $tot_gc_elap || die "GCelap $2 != $tot_gc_elap \n";
- $the_stats{"gc_user_total"} = $tot_gc_user;
- $the_stats{"gc_elap_total"} = $tot_gc_elap;
- next arg; };
-
- /MUT\s+time/ && do { next arg; };
- /INIT\s+time/ && do { next arg; };
- /^\s*([\d,]+) bytes maximum residency/ && do { next arg; };
-
- /\%GC time/ && do { next arg; };
- /Alloc rate/ && do { next arg; };
- /Productivity/ && do { next arg; };
- /^$/ && do { next arg; };
- /^\#/ && do { next arg; }; # Allows comments to follow
-
- print STDERR "Unmatched line: $_";
- }
-
- close(STATS);
- %the_stats;
-}
-
-sub print_stats {
- local ($filename, %out_stats) = @_;
- local($statsfile, $row);
-
- open($statsfile, $filename) || die "Cant open $filename \n";
- select($statsfile);
-
- print $out_stats{"command"}, " ", $out_stats{"args"}, "\n\n";
- print "Collector: ", $out_stats{"collector"}, " HeapSize: ", &from_num($out_stats{"heapsize"}), " (bytes)\n\n";
-
- $row = 0;
- while ($row < $out_stats{"gc_no"}) {
- printf "%7d %7d %7d %5.2f %5.2f %5.2f %5.2f %4d %4d %s\n",
- $out_stats{"alloc_$row"},
- $out_stats{"collect_$row"},
- $out_stats{"live_$row"},
- $out_stats{"gc_user_$row"},
- $out_stats{"gc_elap_$row"},
- $out_stats{"mut_user_$row"},
- $out_stats{"mut_elap_$row"},
- $out_stats{"gc_pflts_$row"},
- $out_stats{"mut_pflts_$row"},
- $out_stats{"mode_$row"};
- $row++;
- };
- printf "%7d %s %5.2f %5.2f \n\n",
- $out_stats{"alloc_$row"}, " " x 27,
- $out_stats{"mut_user_$row"},
- $out_stats{"mut_elap_$row"};
-
- printf "Total Alloc: %s\n", &from_num($out_stats{"alloc_total"});
- printf " GC No: %d\n\n", $out_stats{"gc_no"};
-
- printf " MUT User: %6.2fs\n", $out_stats{"mut_user_total"};
- printf " GC User: %6.2fs\n", $out_stats{"gc_user_total"};
- printf "Total User: %6.2fs\n\n", $out_stats{"user_total"};
-
- printf " MUT Elap: %6.2fs\n", $out_stats{"mut_elap_total"};
- printf " GC Elap: %6.2fs\n", $out_stats{"gc_elap_total"};
- printf "Total Elap: %6.2fs\n", $out_stats{"elap_total"};
-
- close($statsfile);
-}
-
-1;
diff --git a/ghc/utils/stat2resid/prefix.txt b/ghc/utils/stat2resid/prefix.txt
deleted file mode 100644
index 0de9d61f25..0000000000
--- a/ghc/utils/stat2resid/prefix.txt
+++ /dev/null
@@ -1,10 +0,0 @@
-#
-# stat2resid - generating graphs from garbage collection stats.
-#
-# To use the script on your system, the following variable
-# needs to be uncommented and set, if it hasn't already
-# been set above automatically:
-#
-#$libdir='/local/fp/lib/fptools/i386-unknown-footos/ghc-2.02';
-#
-
diff --git a/ghc/utils/stat2resid/process-gcstats.prl b/ghc/utils/stat2resid/process-gcstats.prl
deleted file mode 100644
index ff41cf6af9..0000000000
--- a/ghc/utils/stat2resid/process-gcstats.prl
+++ /dev/null
@@ -1,45 +0,0 @@
-#
-# Subroutines which derive information from
-# ghc garbage collection stats -- %gcstat
-#
-
-sub max_residency {
- local(%gcstats) = @_;
- local($i, $max) = (-1, 0);
-
- if ($gcstats{"collector"} eq "APPEL") {
- die "APPEL stats: average residency not possible\n" ;
- }
-
- while(++$i < $gcstats{"gc_no"}) {
- $max = $gcstats{"live_$i"} > $max ?
- $gcstats{"live_$i"} : $max;
- }
- $max;
-}
-
-sub avg_residency {
- local(%gcstats) = @_;
- local($i, $j, $total);
-
- if ($gcstats{"collector"} eq "APPEL") {
- die "APPEL stats: average residency not possible\n" ;
- }
-
- if ($gcstats{"gc_no"} == 0) { return(0); };
-
- $i = 0; $j = 0;
- $total = $gcstats{"live_$i"} * $gcstats{"mut_user_$i"} / 2;
-
- while(++$i < $gcstats{"gc_no"}) {
- $total += ($gcstats{"live_$i"} + $gcstats{"live_$j"})
- * $gcstats{"mut_user_$i"} / 2;
- $j = $i;
- };
-
- $total += $gcstats{"live_$j"} * $gcstats{"mut_user_$i"} / 2;
-
- int($total / $gcstats{"mut_user_total"});
-}
-
-1;
diff --git a/ghc/utils/stat2resid/stat2resid.prl b/ghc/utils/stat2resid/stat2resid.prl
deleted file mode 100644
index bf0a262428..0000000000
--- a/ghc/utils/stat2resid/stat2resid.prl
+++ /dev/null
@@ -1,81 +0,0 @@
-#
-# (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-#
-# Perl script expect bindings for the following variables to be prepended
-#
-# DEFAULT_TMPDIR libdir
-#
-# without them, not much success :-(
-#
-
-$debug = 0; # first line of script, builds confidence :-)
-$outsuffix = ".resid.ps"; # change as appropriate
-
-if ( $ENV{'TMPDIR'} ) { # where to make tmp file names
- $tmpfile = $ENV{'TMPDIR'} . "/$$.resid.data";
-} else {
- $tmpfile ="${DEFAULT_TMPDIR}/$$.resid.data";
- $ENV{'TMPDIR'} = ${DEFAULT_TMPDIR}; # set the env var as well
-}
-
-@INC = ( ${libdir} );
-
-require('parse-gcstats.prl') || die "Can't load parse-gcstats.prl!\n";
-require('process-gcstats.prl') || die "Can't load process-gcstats.prl!\n";
-
-if ($#ARGV < 0) {
- $infile = "-";
- $outfile = ""; # gnuplot: set output
-} elsif ($#ARGV == 0) {
- $infile = $ARGV[0];
- if ($infile =~ /^(.*)\.stat$/) {
- $base = $1;
- } else {
- $base = $infile;
- $infile = "$base.stat";
- };
- $outfile = "\"$base$outsuffix\""; # gnuplot: set output "outfile"
-} elsif ($#ARGV == 1) {
- $infile = $ARGV[0];
- $outfile = "\"$ARGV[1]\"";
-} else {
- die "Usage: command [infile[.stat] [outfile]]";
-};
-
-%gcstats = &parse_stats($infile);
-
-&print_stats(">&STDERR", %gcstats) if $debug;
-
-if ($gcstats{"collector"} eq "APPEL") {
- die "APPEL stats: no residency plot possible\n";
-}
-
-#
-# stats are now loaded into %gcstats -- write out info
-#
-
-open(DATAFILE, ">$tmpfile") || die "Cant open >$tmpfile \n";
-$i = -1;
-$user = 0;
-printf DATAFILE "%4.2f %d\n", $user, 0;
-while (++$i < $gcstats{"gc_no"}) {
- $user += $gcstats{"mut_user_$i"};
- printf DATAFILE "%4.2f %d\n", $user, $gcstats{"live_$i"};
-};
-printf DATAFILE "%4.2f %d\n", $gcstats{"mut_user_total"}, 0;
-close(DATAFILE);
-
-open(PLOTFILE, "|gnuplot") || die "Cant pipe into |gnuplot \n";
-print PLOTFILE "set data style linespoints\n";
-print PLOTFILE "set function style lines\n";
-print PLOTFILE "set nokey\n";
-print PLOTFILE "set xlabel \"Mutator Time (secs)\"\n";
-print PLOTFILE "set ylabel \"Heap Residency (bytes)\" 0,-1\n";
-print PLOTFILE "set term post eps \"Times-Roman\" 20\n";
-printf PLOTFILE "set title \"%s %s (%s)\"\n", $gcstats{"command"}, $gcstats{"args"}, $infile;
-print PLOTFILE "set output $outfile\n" ;
-print PLOTFILE "plot \"$tmpfile\"\n";
-close(PLOTFILE);
-
-unlink($tmpfile);
-exit 0;
diff --git a/ghc/utils/touchy/Makefile b/ghc/utils/touchy/Makefile
deleted file mode 100644
index d2430df162..0000000000
--- a/ghc/utils/touchy/Makefile
+++ /dev/null
@@ -1,20 +0,0 @@
-#
-# Substitute for 'touch' on win32 platforms (without an Unix toolset installed).
-#
-TOP=../..
-include $(TOP)/mk/boilerplate.mk
-
-C_SRCS=touchy.c
-C_PROG=touchy
-SRC_CC_OPTS += -O
-
-#
-# Install touchy in lib/.*
-#
-INSTALL_LIBEXECS += $(C_PROG)
-
-include $(TOP)/mk/target.mk
-
-# Get it over with!
-boot :: all
-
diff --git a/ghc/utils/touchy/touchy.c b/ghc/utils/touchy/touchy.c
deleted file mode 100644
index 90fb31e93e..0000000000
--- a/ghc/utils/touchy/touchy.c
+++ /dev/null
@@ -1,63 +0,0 @@
-/*
- * Simple _utime() wrapper for setting the mod. time on files
- * to the current system time.
- *
- */
-#if !defined(_MSC_VER) && !defined(__MINGW32__) && !defined(_WIN32)
-#error "Win32-only, the platform you're using is supposed to have 'touch' already."
-#else
-#include <stdio.h>
-#include <sys/stat.h>
-#include <sys/types.h>
-#include <fcntl.h>
-#include <errno.h>
-
-int
-main(int argc, char** argv)
-{
- int rc;
- int i=0;
- int fd;
- int wBitSet = 0;
- struct _stat sb;
-
- if (argc == 1) {
- fprintf(stderr, "Usage: %s <files>\n", argv[0]);
- return 1;
- }
-
-
- while (i++ < (argc-1)) {
- if ( (_access(argv[i], 00) < 0) && (errno == ENOENT || errno == EACCES) ) {
- /* File doesn't exist, try creating it. */
- if ( (fd = _open(argv[i], _O_CREAT | _O_EXCL | _O_TRUNC, _S_IREAD | _S_IWRITE)) < 0 ) {
- fprintf(stderr, "Unable to create %s, skipping.\n", argv[i]);
- } else {
- _close(fd);
- }
- }
- if ( (_access(argv[i], 02)) < 0 ) {
- /* No write permission, try setting it first. */
- if (_stat(argv[i], &sb) < 0) {
- fprintf(stderr, "Unable to change mod. time for %s (%d)\n", argv[i], errno);
- continue;
- }
- if (_chmod(argv[i], (sb.st_mode & _S_IREAD) | _S_IWRITE) < 0) {
- fprintf(stderr, "Unable to change mod. time for %s (%d)\n", argv[i], errno);
- continue;
- }
- wBitSet = 1;
- }
- if ( (rc = _utime(argv[i],NULL)) < 0) {
- fprintf(stderr, "Unable to change mod. time for %s (%d)\n", argv[i], errno);
- }
- if (wBitSet) {
- /* Turn the file back into a read-only file */
- _chmod(argv[i], (sb.st_mode & _S_IREAD));
- wBitSet = 0;
- }
- }
-
- return 0;
-}
-#endif
diff --git a/ghc/utils/unlit/Makefile b/ghc/utils/unlit/Makefile
deleted file mode 100644
index 15e7fc4252..0000000000
--- a/ghc/utils/unlit/Makefile
+++ /dev/null
@@ -1,16 +0,0 @@
-TOP=../..
-include $(TOP)/mk/boilerplate.mk
-
-C_SRCS=unlit.c
-C_PROG=unlit
-SRC_CC_OPTS += -O
-
-# Get it over with!
-boot :: all
-
-#
-# Install unlit in lib/
-#
-INSTALL_LIBEXECS += $(C_PROG)
-
-include $(TOP)/mk/target.mk
diff --git a/ghc/utils/unlit/README b/ghc/utils/unlit/README
deleted file mode 100644
index 4dd2ef5132..0000000000
--- a/ghc/utils/unlit/README
+++ /dev/null
@@ -1,8 +0,0 @@
-This "unlit" program, used by the GHC driver, is originally by Mark
-Jones (then at Oxford). It is taken in its present form *directly*
-from the LML/HBC distribution (from Chalmers).
-
-We are grateful for this piece of shared code.
-
-For more "powerful" swizzling of literate scripts, please see the
-"literate" stuff from Glasgow.
diff --git a/ghc/utils/unlit/unlit.c b/ghc/utils/unlit/unlit.c
deleted file mode 100644
index 366302156a..0000000000
--- a/ghc/utils/unlit/unlit.c
+++ /dev/null
@@ -1,401 +0,0 @@
-/* unlit.c Wed Dec 5 17:16:24 GMT 1990
- *
- * Literate script filter. In contrast with the format used by most
- * programming languages, a literate script is a program in which
- * comments are given the leading role, whilst program text must be
- * explicitly flagged as such by placing a `>' character in the first
- * column on each line. It is hoped that this style of programming will
- * encourage the writing of accurate and clearly documented programs
- * in which the writer may include motivating arguments, examples
- * and explanations.
- *
- * Unlit is a filter that can be used to strip all of the comment lines
- * out of a literate script file. The command format for unlit is:
- * unlit [-n] [-q] ifile ofile
- * where ifile and ofile are the names of the input (literate script) and
- * output (raw program) files respectively. Either of these names may
- * be `-' representing the standard input or the standard output resp.
- * A number of rules are used in an attempt to guard against the most
- * common errors that are made when writing literate scripts:
- * 1) Empty script files are not permitted. A file in which no lines
- * begin with `>' usually indicates a file in which the programmer
- * has forgotten about the literate script convention.
- * 2) A line containing part of program definition (i.e. preceeded by `>')
- * cannot be used immediately before or after a comment line unless
- * the comment line is blank. This error usually indicates that
- * the `>' character has been omitted from a line in a section of
- * program spread over a number of lines.
- * Using the -q (quiet) flag suppresses the signalling of these error
- * conditions. The default behaviour can be selected explicitly using
- * the -n (noisy) option so that any potential errors in the script file
- * are reported.
- *
- * The original idea for the use of literate scripts is due to Richard
- * Bird of the programming Research Group, Oxford and was initially
- * adopted for use in the implementation of the functional programming
- * language Orwell used for teaching in Oxford. This idea has subsequently
- * been borrowed in a number of other language implementations.
- *
- * Modified to understand \begin{code} ... \end{code} used in Glasgow. -- LA
- * And \begin{pseudocode} ... \end{pseudocode}. -- LA
- */
-
-#include <string.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <ctype.h>
-
-#define NULLSTR ((char *)0)
-#define DEFNCHAR '>'
-#define MISSINGBLANK "unlit: Program line next to comment"
-#define EMPTYSCRIPT "unlit: No definitions in file (perhaps you forgot the '>'s?)"
-#define USAGE "usage: unlit [-q] [-n] [-c] [-#] [-P] [-h label] file1 file2\n"
-#define CANNOTOPEN "unlit: cannot open \"%s\"\n"
-#define CANNOTWRITE "unlit: error writing \"%s\"\n"
-#define CANNOTWRITESTDOUT "unlit: error writing standard output\n"
-#define DISTINCTNAMES "unlit: input and output filenames must differ\n"
-#define MISSINGENDCODE "unlit: missing \\end{code}\n"
-
-#define BEGINCODE "\\begin{code}"
-#define LENBEGINCODE 12
-#define ENDCODE "\\end{code}"
-#define LENENDCODE 10
-#ifdef PSEUDOCODE
-/* According to Will Partain, the inventor of pseudocode, this gone now. */
-#define MISSINGENDPSEUDOCODE "unlit: missing \\end{pseudocode}\n"
-#define BEGINPSEUDOCODE "\\begin{pseudocode}"
-#define LENBEGINPSEUDOCODE 18
-#define ENDPSEUDOCODE "\\end{pseudocode}"
-#define LENENDPSEUDOCODE 16
-#endif
-
-typedef enum { START, BLANK, TEXT, DEFN, BEGIN, /*PSEUDO,*/ END, HASH, SHEBANG } line;
-#define isWhitespace(c) (c==' ' || c=='\t' || c=='\r')
-#define isLineTerm(c) (c=='\n' || c==EOF)
-
-static int noisy = 1; /* 0 => keep quiet about errors, 1 => report errors */
-static int errors = 0; /* count the number of errors reported */
-static int crunchnl = 0; /* don't print \n for removed lines */
-static int leavecpp = 1; /* leave preprocessor lines */
-static int ignore_shebang = 1; /* Leave out shebang (#!) lines */
-static int no_line_pragma = 0; /* Leave out initial line pragma */
-
-static char* prefix_str = NULL; /* Prefix output with a string */
-
-static char *ofilename = NULL;
-
-/* complain(file,line,what)
- *
- * print error message `what' for `file' at `line'. The error is suppressed
- * if noisy is not set.
- */
-
-complain(file, lin, what)
-char *file;
-char *what;
-int lin; {
- if (noisy) {
- if (file)
- fprintf(stderr, "%s ", file);
- fprintf(stderr,"line %d: %s\n",lin,what);
- errors++;
- }
-}
-
-writeerror()
-{
- if (!strcmp(ofilename,"-")) {
- fprintf(stderr, CANNOTWRITESTDOUT);
- } else {
- fprintf(stderr, CANNOTWRITE, ofilename);
- }
- exit(1);
-}
-
-myputc(c, ostream)
-char c;
-FILE *ostream; {
- if (putc(c,ostream) == EOF) {
- writeerror();
- }
-}
-
-#define TABPOS 8
-
-/* As getc, but does TAB expansion */
-int
-egetc(istream)
-FILE *istream;
-{
- static int spleft = 0;
- static int linepos = 0;
- int c;
-
- if (spleft > 0) {
- spleft--;
- linepos++;
- return ' ';
- }
- c = getc(istream);
- if (c == EOF)
- return c;
- else if (c == '\n' || c == '\f') {
- linepos = 0;
- return c;
- } else if (c == '\t') {
- spleft = TABPOS - linepos % TABPOS;
- spleft--;
- linepos++;
- return ' ';
- } else {
- linepos++;
- return c;
- }
-
-}
-
-/* readline(istream, ostream)
- *
- * Read a line from the input stream `istream', and return a value
- * indicating whether that line was:
- * BLANK (whitespace only),
- * DEFN (first character is DEFNCHAR),
- * TEXT (a line of text)
- * BEGIN (a \begin{code} line)
- * PSEUDO (a \begin{pseodocode} line)
- * HASH (a preprocessor line)
- * or END (indicating an EOF).
- * Lines of type DEFN are copied to the output stream `ostream'
- * (without the leading DEFNCHAR). BLANK and TEXT lines are
- * replaced by empty (i.e. blank lines) in the output stream, so
- * that error messages refering to line numbers in the output file
- * can also be used to locate the corresponding line in the input
- * stream.
- */
-
-line readline(istream,ostream)
-FILE *istream, *ostream; {
- int c, c1;
- char buf[100];
- int i;
-
- c = egetc(istream);
-
- if (c==EOF)
- return END;
-
- if ( c == '#' ) {
- if ( ignore_shebang ) {
- c1 = egetc(istream);
- if ( c1 == '!' ) {
- while (c=egetc(istream), !isLineTerm(c)) ;
- return SHEBANG;
- }
- myputc(c, ostream);
- c=c1;
- }
- if ( leavecpp ) {
- myputc(c, ostream);
- while (c=egetc(istream), !isLineTerm(c))
- myputc(c,ostream);
- myputc('\n',ostream);
- return HASH;
- }
- }
-
- if (c==DEFNCHAR) {
-/* myputc(' ',ostream);*/
- while (c=egetc(istream), !isLineTerm(c))
- myputc(c,ostream);
- myputc('\n',ostream);
- return DEFN;
- }
-
- if (!crunchnl)
- myputc('\n',ostream);
-
- while (isWhitespace(c))
- c=egetc(istream);
- if (isLineTerm(c))
- return BLANK;
-
- i = 0;
- buf[i++] = c;
- while (c=egetc(istream), !isLineTerm(c))
- if (i < sizeof buf - 1)
- buf[i++] = c;
- while(i > 0 && isspace(buf[i-1]))
- i--;
- buf[i] = 0;
- if (strcmp(buf, BEGINCODE) == 0)
- return BEGIN;
-#ifdef PSEUDOCODE
- else if (strcmp(buf, BEGINPSEUDOCODE) == 0)
- return PSEUDO;
-#endif
- else
- return TEXT;
-}
-
-
-/* unlit(file,istream,ostream)
- *
- * Copy the file named `file', accessed using the input stream `istream'
- * to the output stream `ostream', removing any comments and checking
- * for bad use of literate script features:
- * - there should be at least one BLANK line between a DEFN and TEXT
- * - there should be at least one DEFN line in a script.
- */
-
-unlit(file, istream, ostream)
-char *file;
-FILE *istream;
-FILE *ostream; {
- line last, this=START;
- int linesread=0;
- int defnsread=0;
-
- do {
- last = this;
- this = readline(istream, ostream);
- linesread++;
- if (this==DEFN)
- defnsread++;
- if (last==DEFN && this==TEXT)
- complain(file, linesread-1, MISSINGBLANK);
- if (last==TEXT && this==DEFN)
- complain(file, linesread, MISSINGBLANK);
- if (this == BEGIN) {
- /* start of code, copy to end */
- char lineb[1000];
- for(;;) {
- if (fgets(lineb, sizeof lineb, istream) == NULL) {
- complain(file, linesread, MISSINGENDCODE);
- exit(1);
- }
- linesread++;
- if (strncmp(lineb,ENDCODE,LENENDCODE) == 0) {
- myputc('\n', ostream);
- break;
- }
- fputs(lineb, ostream);
- }
- defnsread++;
- }
-#ifdef PSEUDOCODE
- if (this == PSEUDO) {
- char lineb[1000];
- for(;;) {
- if (fgets(lineb, sizeof lineb, istream) == NULL) {
- complain(file, linesread, MISSINGENDPSEUDOCODE);
- exit(1);
- }
- linesread++;
- myputc('\n', ostream);
- if (strncmp(lineb,ENDPSEUDOCODE,LENENDPSEUDOCODE) == 0) {
- break;
- }
- }
- }
-#endif
- } while(this!=END);
-
- if (defnsread==0)
- complain(file,linesread,EMPTYSCRIPT);
-}
-
-/* main(argc, argv)
- *
- * Main program. Processes command line arguments, looking for leading:
- * -q quiet mode - do not complain about bad literate script files
- * -n noisy mode - complain about bad literate script files.
- * -r remove cpp droppings in output.
- * -P don't output any CPP line pragmas.
- * Expects two additional arguments, a file name for the input and a file
- * name for the output file. These two names must normally be distinct.
- * An exception is made for the special name "-" which can be used in either
- * position to specify the standard input or the standard output respectively.
- */
-
-main(argc,argv)
-int argc;
-char **argv; {
- FILE *istream, *ostream;
- char *file;
-
- for (argc--, argv++; argc > 0; argc--, argv++)
- if (strcmp(*argv,"-n")==0)
- noisy = 1;
- else if (strcmp(*argv,"-q")==0)
- noisy = 0;
- else if (strcmp(*argv,"-c")==0)
- crunchnl = 1;
- else if (strcmp(*argv,"-P")==0)
- no_line_pragma = 1;
- else if (strcmp(*argv,"-h")==0) {
- if (argc > 1) {
- argc--; argv++;
- if (prefix_str)
- free(prefix_str);
- prefix_str = (char*)malloc(sizeof(char)*(1+strlen(*argv)));
- if (prefix_str)
- strcpy(prefix_str, *argv);
- }
- } else if (strcmp(*argv,"-#")==0)
- ignore_shebang = 0;
- else
- break;
-
- if (argc!=2) {
- fprintf(stderr, USAGE);
- exit(1);
- }
-
- if (strcmp(argv[0],argv[1])==0 && strcmp(argv[0],"-")!=0) {
- fprintf(stderr, DISTINCTNAMES);
- exit(1);
- }
-
- file = argv[0];
- if (strcmp(argv[0], "-")==0) {
- istream = stdin;
- file = "stdin";
- }
- else
- if ((istream=fopen(argv[0], "r")) == NULL) {
- fprintf(stderr, CANNOTOPEN, argv[0]);
- exit(1);
- }
-
- ofilename=argv[1];
- if (strcmp(argv[1], "-")==0)
- ostream = stdout;
- else
- if ((ostream=fopen(argv[1], "w")) == NULL) {
- fprintf(stderr, CANNOTOPEN, argv[1]);
- exit(1);
- }
-
- /* Prefix the output with line pragmas */
- if (!no_line_pragma && prefix_str) {
- /* Both GHC and CPP understand the #line pragma.
- * We used to throw in both a #line and a {-# LINE #-} pragma
- * here, but CPP doesn't understand {-# LINE #-} so it thought
- * the line numbers were off by one. We could put the {-# LINE
- * #-} before the #line, but there's no point since GHC
- * understands #line anyhow. --SDM 8/2003
- */
- fprintf(ostream, "#line 1 \"%s\"\n", prefix_str);
- }
-
- unlit(file, istream, ostream);
-
- if (istream != stdin) fclose(istream);
- if (ostream != stdout) {
- if (fclose(ostream) == EOF) {
- writeerror();
- }
- }
-
- exit(errors==0 ? 0 : 1);
-}