diff options
Diffstat (limited to 'utils')
192 files changed, 30145 insertions, 0 deletions
diff --git a/utils/Makefile b/utils/Makefile new file mode 100644 index 0000000000..9416d7728b --- /dev/null +++ b/utils/Makefile @@ -0,0 +1,39 @@ +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 unlit +else +ifeq "$(BootingFromHc)" "YES" +SUBDIRS = mkdependC mkdirhier runstdtest genapply genprimopcode ghc-pkg unlit +else +SUBDIRS = mkdependC mkdirhier runstdtest ghc-pkg hasktags hp2ps hsc2hs lndir \ + parallel prof unlit genprimopcode genapply runghc +endif +endif + +ifeq "$(TARGETPLATFORM)" "i386-unknown-mingw32" +SUBDIRS += touchy +endif + +# Utils that we don't build by default: +# nofib-analyse + +# Utils that are old and/or bitrotted: +# stat2resid +# debugNCG +# ext-core +# genargs +# heap-view +# pvm +# verbatim +# ltx +# 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/utils/debugNCG/Diff_Gcc_Nat.hs b/utils/debugNCG/Diff_Gcc_Nat.hs new file mode 100644 index 0000000000..02b642821e --- /dev/null +++ b/utils/debugNCG/Diff_Gcc_Nat.hs @@ -0,0 +1,380 @@ + +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/utils/debugNCG/Makefile b/utils/debugNCG/Makefile new file mode 100644 index 0000000000..0ea51a1e06 --- /dev/null +++ b/utils/debugNCG/Makefile @@ -0,0 +1,19 @@ +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/utils/debugNCG/README b/utils/debugNCG/README new file mode 100644 index 0000000000..90eb2197cc --- /dev/null +++ b/utils/debugNCG/README @@ -0,0 +1,46 @@ + +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/utils/ext-core/Check.hs b/utils/ext-core/Check.hs new file mode 100644 index 0000000000..a9a3eac8f4 --- /dev/null +++ b/utils/ext-core/Check.hs @@ -0,0 +1,421 @@ +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/utils/ext-core/Core.hs b/utils/ext-core/Core.hs new file mode 100644 index 0000000000..2f94f80b3e --- /dev/null +++ b/utils/ext-core/Core.hs @@ -0,0 +1,150 @@ +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/utils/ext-core/Driver.hs b/utils/ext-core/Driver.hs new file mode 100644 index 0000000000..2328eca22a --- /dev/null +++ b/utils/ext-core/Driver.hs @@ -0,0 +1,86 @@ +{- 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/utils/ext-core/Env.hs b/utils/ext-core/Env.hs new file mode 100644 index 0000000000..6f6973c558 --- /dev/null +++ b/utils/ext-core/Env.hs @@ -0,0 +1,44 @@ +{- 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/utils/ext-core/Interp.hs b/utils/ext-core/Interp.hs new file mode 100644 index 0000000000..1988ae9cf3 --- /dev/null +++ b/utils/ext-core/Interp.hs @@ -0,0 +1,450 @@ +{- +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/utils/ext-core/Lex.hs b/utils/ext-core/Lex.hs new file mode 100644 index 0000000000..ad9d2eb00f --- /dev/null +++ b/utils/ext-core/Lex.hs @@ -0,0 +1,92 @@ +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/utils/ext-core/ParseGlue.hs b/utils/ext-core/ParseGlue.hs new file mode 100644 index 0000000000..3dde0c3d75 --- /dev/null +++ b/utils/ext-core/ParseGlue.hs @@ -0,0 +1,65 @@ +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/utils/ext-core/Parser.y b/utils/ext-core/Parser.y new file mode 100644 index 0000000000..1e1c6a3592 --- /dev/null +++ b/utils/ext-core/Parser.y @@ -0,0 +1,230 @@ +{ +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/utils/ext-core/Prep.hs b/utils/ext-core/Prep.hs new file mode 100644 index 0000000000..ee65eaaba2 --- /dev/null +++ b/utils/ext-core/Prep.hs @@ -0,0 +1,151 @@ +{- +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/utils/ext-core/Prims.hs b/utils/ext-core/Prims.hs new file mode 100644 index 0000000000..fd6e827c39 --- /dev/null +++ b/utils/ext-core/Prims.hs @@ -0,0 +1,834 @@ +{- 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/utils/ext-core/Printer.hs b/utils/ext-core/Printer.hs new file mode 100644 index 0000000000..ded48aadc2 --- /dev/null +++ b/utils/ext-core/Printer.hs @@ -0,0 +1,163 @@ +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/utils/ext-core/README b/utils/ext-core/README new file mode 100644 index 0000000000..7ec8adf09a --- /dev/null +++ b/utils/ext-core/README @@ -0,0 +1,9 @@ +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/utils/genapply/GenApply.hs b/utils/genapply/GenApply.hs new file mode 100644 index 0000000000..cdde66fa78 --- /dev/null +++ b/utils/genapply/GenApply.hs @@ -0,0 +1,769 @@ +{-# 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/utils/genapply/Makefile b/utils/genapply/Makefile new file mode 100644 index 0000000000..f9a10a22de --- /dev/null +++ b/utils/genapply/Makefile @@ -0,0 +1,25 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk + +HS_PROG = $(GHC_GENAPPLY_PGM) + +# genapply is needed to boot in 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/utils/genargs/Makefile b/utils/genargs/Makefile new file mode 100644 index 0000000000..3c31e6a39f --- /dev/null +++ b/utils/genargs/Makefile @@ -0,0 +1,8 @@ +comma = , +BAR= "-L\"foo bar\"" +FOO= $(patsubst %,$(comma)"%",$(BAR)) + +test: + @echo "$(FOO)" + @echo "$(BAR)" | $(PERL) genargs.pl -comma + @echo diff --git a/utils/genargs/genargs.pl b/utils/genargs/genargs.pl new file mode 100644 index 0000000000..2ef2dfa3e6 --- /dev/null +++ b/utils/genargs/genargs.pl @@ -0,0 +1,62 @@ +#!/usr/bin/perl +my $quote_open = 0; +my $quote_char = ''; +my $accum = ""; +my $once = 1; +my $c; + +# This program generates a partial Haskell list of Strings from +# words passed via stdin suitable for use in package.conf, e.g.: +# +# foo bar --> "foo", "bar" +# "foo bar" --> "foo bar" +# foo\"bar --> "foo\"bar" +# +# Invoking genargs.pl with -comma will print an initial comma if +# there's anything to print at all. +# +# Sample application in a Makefile: +# HSIFIED_EXTRA_LD_OPTS= `echo "$(EXTRA_LD_OPTS)" | $(PERL) genargs.pl` +# PACKAGE_CPP_OPTS += -DHSIFIED_EXTRA_LD_OPTS="$(HSIFIED_EXTRA_LD_OPTS)" + +sub printaccum { + if ($once) { + if ($ARGV[0] eq "-comma") { + print ", "; + } + } else { + print ", "; + } + $once=0; + print '"'; + print $accum; + print '"'; +} + +while ($c = getc) { + if ($quote_open) { + if ($c eq $quote_char) { + $quote_open = 0; + } elsif ($c eq '"') { + $accum .= '\"'; + } else { + $accum .= $c; + } + } else { + if (($c eq ' ') || ($c eq "\n")) { + if (!($accum eq "")) { + printaccum; + $accum = ""; + } + } elsif ($c eq "\\") { + $accum .= $c; + $c = getc; + $accum .= $c; + } elsif (($c eq '"') || ($c eq "\'")) { + $quote_open = 1; + $quote_char = $c; + } else { + $accum .= $c + } + } +} diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs new file mode 100644 index 0000000000..f08b7d5602 --- /dev/null +++ b/utils/genprimopcode/Main.hs @@ -0,0 +1,787 @@ +{-# 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/utils/genprimopcode/Makefile b/utils/genprimopcode/Makefile new file mode 100644 index 0000000000..dbd69f6d42 --- /dev/null +++ b/utils/genprimopcode/Makefile @@ -0,0 +1,19 @@ +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/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs new file mode 100644 index 0000000000..fb3ef07c3f --- /dev/null +++ b/utils/ghc-pkg/Main.hs @@ -0,0 +1,1184 @@ +{-# 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/utils/ghc-pkg/Makefile b/utils/ghc-pkg/Makefile new file mode 100644 index 0000000000..c8a075d5b7 --- /dev/null +++ b/utils/ghc-pkg/Makefile @@ -0,0 +1,111 @@ +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_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/config.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)/utils/ghc-pkg/$(HS_PROG) +PKGCONF=$(FPTOOLS_TOP_ABS_PLATFORM)/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 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/utils/ghc-pkg/ghc-pkg.sh b/utils/ghc-pkg/ghc-pkg.sh new file mode 100644 index 0000000000..d482fc094e --- /dev/null +++ b/utils/ghc-pkg/ghc-pkg.sh @@ -0,0 +1,2 @@ +# Mini-driver for ghc-pkg +exec $GHCPKGBIN $PKGCONFOPT ${1+"$@"} diff --git a/utils/hasktags/HaskTags.hs b/utils/hasktags/HaskTags.hs new file mode 100644 index 0000000000..f1840332d2 --- /dev/null +++ b/utils/hasktags/HaskTags.hs @@ -0,0 +1,232 @@ +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/utils/hasktags/Makefile b/utils/hasktags/Makefile new file mode 100644 index 0000000000..99afec685d --- /dev/null +++ b/utils/hasktags/Makefile @@ -0,0 +1,10 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk + +HS_PROG = hasktags + +CLEAN_FILES += Main.hi + +INSTALL_PROGS += $(HS_PROG) + +include $(TOP)/mk/target.mk diff --git a/utils/hasktags/README b/utils/hasktags/README new file mode 100644 index 0000000000..77bac8881a --- /dev/null +++ b/utils/hasktags/README @@ -0,0 +1,33 @@ + +"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/utils/heap-view/Graph.lhs b/utils/heap-view/Graph.lhs new file mode 100644 index 0000000000..b8e08dbb9b --- /dev/null +++ b/utils/heap-view/Graph.lhs @@ -0,0 +1,165 @@ +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/utils/heap-view/HaskXLib.c b/utils/heap-view/HaskXLib.c new file mode 100644 index 0000000000..b6cf1f137c --- /dev/null +++ b/utils/heap-view/HaskXLib.c @@ -0,0 +1,297 @@ +/*----------------------------------------------------------------------* + * 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/utils/heap-view/HpView.lhs b/utils/heap-view/HpView.lhs new file mode 100644 index 0000000000..a7b4cbb78e --- /dev/null +++ b/utils/heap-view/HpView.lhs @@ -0,0 +1,296 @@ +> 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/utils/heap-view/HpView2.lhs b/utils/heap-view/HpView2.lhs new file mode 100644 index 0000000000..fa8044b8b4 --- /dev/null +++ b/utils/heap-view/HpView2.lhs @@ -0,0 +1,225 @@ +> 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/utils/heap-view/MAIL b/utils/heap-view/MAIL new file mode 100644 index 0000000000..966fcdcfc7 --- /dev/null +++ b/utils/heap-view/MAIL @@ -0,0 +1,67 @@ +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/utils/heap-view/Makefile b/utils/heap-view/Makefile new file mode 100644 index 0000000000..e8fa8faf08 --- /dev/null +++ b/utils/heap-view/Makefile @@ -0,0 +1,31 @@ +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/utils/heap-view/Makefile.original b/utils/heap-view/Makefile.original new file mode 100644 index 0000000000..1e35bc2e43 --- /dev/null +++ b/utils/heap-view/Makefile.original @@ -0,0 +1,48 @@ +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/utils/heap-view/Parse.lhs b/utils/heap-view/Parse.lhs new file mode 100644 index 0000000000..9d7652fdcc --- /dev/null +++ b/utils/heap-view/Parse.lhs @@ -0,0 +1,92 @@ +> 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/utils/heap-view/README b/utils/heap-view/README new file mode 100644 index 0000000000..db9503abc4 --- /dev/null +++ b/utils/heap-view/README @@ -0,0 +1,62 @@ +@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/utils/heap-view/common-bits b/utils/heap-view/common-bits new file mode 100644 index 0000000000..f41223b7f4 --- /dev/null +++ b/utils/heap-view/common-bits @@ -0,0 +1,35 @@ + ----------------------------------------------------------------------------- + + 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/utils/hp2ps/AreaBelow.c b/utils/hp2ps/AreaBelow.c new file mode 100644 index 0000000000..ec80e1ed48 --- /dev/null +++ b/utils/hp2ps/AreaBelow.c @@ -0,0 +1,62 @@ +#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/utils/hp2ps/AreaBelow.h b/utils/hp2ps/AreaBelow.h new file mode 100644 index 0000000000..d7f713f2b4 --- /dev/null +++ b/utils/hp2ps/AreaBelow.h @@ -0,0 +1,6 @@ +#ifndef AREA_BELOW_H +#define AREA_BELOW_H + +floatish AreaBelow PROTO((void)); + +#endif /* AREA_BELOW_H */ diff --git a/utils/hp2ps/AuxFile.c b/utils/hp2ps/AuxFile.c new file mode 100644 index 0000000000..9998d3fc13 --- /dev/null +++ b/utils/hp2ps/AuxFile.c @@ -0,0 +1,168 @@ +#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/utils/hp2ps/AuxFile.h b/utils/hp2ps/AuxFile.h new file mode 100644 index 0000000000..6e962c492e --- /dev/null +++ b/utils/hp2ps/AuxFile.h @@ -0,0 +1,7 @@ +#ifndef AUX_FILE_H +#define AUX_FILE_H + +void PutAuxFile PROTO((FILE *)); +void GetAuxFile PROTO((FILE *)); + +#endif /* AUX_FILE_H */ diff --git a/utils/hp2ps/Axes.c b/utils/hp2ps/Axes.c new file mode 100644 index 0000000000..a2641cd676 --- /dev/null +++ b/utils/hp2ps/Axes.c @@ -0,0 +1,241 @@ +#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/utils/hp2ps/Axes.h b/utils/hp2ps/Axes.h new file mode 100644 index 0000000000..e4be505dfb --- /dev/null +++ b/utils/hp2ps/Axes.h @@ -0,0 +1,6 @@ +#ifndef AXES_H +#define AXES_H + +void Axes PROTO((void)); + +#endif /* AXES_H */ diff --git a/utils/hp2ps/CHANGES b/utils/hp2ps/CHANGES new file mode 100644 index 0000000000..db3b52e6d6 --- /dev/null +++ b/utils/hp2ps/CHANGES @@ -0,0 +1,37 @@ +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/utils/hp2ps/Curves.c b/utils/hp2ps/Curves.c new file mode 100644 index 0000000000..ec05c98336 --- /dev/null +++ b/utils/hp2ps/Curves.c @@ -0,0 +1,165 @@ +#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/utils/hp2ps/Curves.h b/utils/hp2ps/Curves.h new file mode 100644 index 0000000000..0aa397f42c --- /dev/null +++ b/utils/hp2ps/Curves.h @@ -0,0 +1,10 @@ +#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/utils/hp2ps/Defines.h b/utils/hp2ps/Defines.h new file mode 100644 index 0000000000..8d38546fec --- /dev/null +++ b/utils/hp2ps/Defines.h @@ -0,0 +1,61 @@ +#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/utils/hp2ps/Deviation.c b/utils/hp2ps/Deviation.c new file mode 100644 index 0000000000..ecf7faba16 --- /dev/null +++ b/utils/hp2ps/Deviation.c @@ -0,0 +1,139 @@ +#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/utils/hp2ps/Deviation.h b/utils/hp2ps/Deviation.h new file mode 100644 index 0000000000..14e4df1ad0 --- /dev/null +++ b/utils/hp2ps/Deviation.h @@ -0,0 +1,7 @@ +#ifndef DEVIATION_H +#define DEVIATION_H + +void Deviation PROTO((void)); +void Identorder PROTO((int)); + +#endif /* DEVIATION_H */ diff --git a/utils/hp2ps/Dimensions.c b/utils/hp2ps/Dimensions.c new file mode 100644 index 0000000000..e732402dac --- /dev/null +++ b/utils/hp2ps/Dimensions.c @@ -0,0 +1,203 @@ +#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/utils/hp2ps/Dimensions.h b/utils/hp2ps/Dimensions.h new file mode 100644 index 0000000000..7bcc05beee --- /dev/null +++ b/utils/hp2ps/Dimensions.h @@ -0,0 +1,22 @@ +#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/utils/hp2ps/Error.c b/utils/hp2ps/Error.c new file mode 100644 index 0000000000..809c24ea44 --- /dev/null +++ b/utils/hp2ps/Error.c @@ -0,0 +1,59 @@ +#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/utils/hp2ps/Error.h b/utils/hp2ps/Error.h new file mode 100644 index 0000000000..c1cdede415 --- /dev/null +++ b/utils/hp2ps/Error.h @@ -0,0 +1,8 @@ +#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/utils/hp2ps/HpFile.c b/utils/hp2ps/HpFile.c new file mode 100644 index 0000000000..9db94977df --- /dev/null +++ b/utils/hp2ps/HpFile.c @@ -0,0 +1,587 @@ +#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/utils/hp2ps/HpFile.h b/utils/hp2ps/HpFile.h new file mode 100644 index 0000000000..1c43f73d6d --- /dev/null +++ b/utils/hp2ps/HpFile.h @@ -0,0 +1,77 @@ +#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/utils/hp2ps/Key.c b/utils/hp2ps/Key.c new file mode 100644 index 0000000000..8c63721c74 --- /dev/null +++ b/utils/hp2ps/Key.c @@ -0,0 +1,63 @@ +#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/utils/hp2ps/Key.h b/utils/hp2ps/Key.h new file mode 100644 index 0000000000..d2a7b8eae3 --- /dev/null +++ b/utils/hp2ps/Key.h @@ -0,0 +1,6 @@ +#ifndef KEY_H +#define KEY_H + +void Key PROTO((void)); + +#endif /* KEY_H */ diff --git a/utils/hp2ps/Main.c b/utils/hp2ps/Main.c new file mode 100644 index 0000000000..3b5efed51b --- /dev/null +++ b/utils/hp2ps/Main.c @@ -0,0 +1,253 @@ +#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/utils/hp2ps/Main.h b/utils/hp2ps/Main.h new file mode 100644 index 0000000000..30e7a7e9be --- /dev/null +++ b/utils/hp2ps/Main.h @@ -0,0 +1,77 @@ +#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/utils/hp2ps/Makefile b/utils/hp2ps/Makefile new file mode 100644 index 0000000000..18cb05b1bd --- /dev/null +++ b/utils/hp2ps/Makefile @@ -0,0 +1,14 @@ +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/utils/hp2ps/Marks.c b/utils/hp2ps/Marks.c new file mode 100644 index 0000000000..8d6f924e17 --- /dev/null +++ b/utils/hp2ps/Marks.c @@ -0,0 +1,43 @@ +#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/utils/hp2ps/Marks.h b/utils/hp2ps/Marks.h new file mode 100644 index 0000000000..41956f6e83 --- /dev/null +++ b/utils/hp2ps/Marks.h @@ -0,0 +1,6 @@ +#ifndef MARKS_H +#define MARKS_H + +void Marks PROTO((void)); + +#endif /* MARKS_H */ diff --git a/utils/hp2ps/PsFile.c b/utils/hp2ps/PsFile.c new file mode 100644 index 0000000000..357f826259 --- /dev/null +++ b/utils/hp2ps/PsFile.c @@ -0,0 +1,280 @@ +#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/utils/hp2ps/PsFile.h b/utils/hp2ps/PsFile.h new file mode 100644 index 0000000000..acec0703bc --- /dev/null +++ b/utils/hp2ps/PsFile.h @@ -0,0 +1,6 @@ +#ifndef PS_FILE_H +#define PS_FILE_H + +void PutPsFile PROTO((void)); + +#endif /* PS_FILE_H */ diff --git a/utils/hp2ps/README.GHC b/utils/hp2ps/README.GHC new file mode 100644 index 0000000000..a3fb21e922 --- /dev/null +++ b/utils/hp2ps/README.GHC @@ -0,0 +1,4 @@ +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/utils/hp2ps/Reorder.c b/utils/hp2ps/Reorder.c new file mode 100644 index 0000000000..afeed52d85 --- /dev/null +++ b/utils/hp2ps/Reorder.c @@ -0,0 +1,89 @@ +#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/utils/hp2ps/Reorder.h b/utils/hp2ps/Reorder.h new file mode 100644 index 0000000000..089ef75cfc --- /dev/null +++ b/utils/hp2ps/Reorder.h @@ -0,0 +1,8 @@ +#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/utils/hp2ps/Scale.c b/utils/hp2ps/Scale.c new file mode 100644 index 0000000000..32120407b3 --- /dev/null +++ b/utils/hp2ps/Scale.c @@ -0,0 +1,86 @@ +#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/utils/hp2ps/Scale.h b/utils/hp2ps/Scale.h new file mode 100644 index 0000000000..0c19d6c3c0 --- /dev/null +++ b/utils/hp2ps/Scale.h @@ -0,0 +1,7 @@ +#ifndef SCALE_H +#define SCALE_H + +floatish MaxCombinedHeight PROTO((void)); +void Scale PROTO((void)); + +#endif /* SCALE_H */ diff --git a/utils/hp2ps/Shade.c b/utils/hp2ps/Shade.c new file mode 100644 index 0000000000..9e3274bf69 --- /dev/null +++ b/utils/hp2ps/Shade.c @@ -0,0 +1,130 @@ +#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/utils/hp2ps/Shade.h b/utils/hp2ps/Shade.h new file mode 100644 index 0000000000..0e49c90d04 --- /dev/null +++ b/utils/hp2ps/Shade.h @@ -0,0 +1,8 @@ +#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/utils/hp2ps/TopTwenty.c b/utils/hp2ps/TopTwenty.c new file mode 100644 index 0000000000..bbb6be4390 --- /dev/null +++ b/utils/hp2ps/TopTwenty.c @@ -0,0 +1,72 @@ +#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/utils/hp2ps/TopTwenty.h b/utils/hp2ps/TopTwenty.h new file mode 100644 index 0000000000..53a7aed509 --- /dev/null +++ b/utils/hp2ps/TopTwenty.h @@ -0,0 +1,6 @@ +#ifndef TOP_TWENTY_H +#define TOP_TWENTY_H + +void TopTwenty PROTO((void)); + +#endif /* TOP_TWENTY_H */ diff --git a/utils/hp2ps/TraceElement.c b/utils/hp2ps/TraceElement.c new file mode 100644 index 0000000000..c14062dced --- /dev/null +++ b/utils/hp2ps/TraceElement.c @@ -0,0 +1,96 @@ +#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/utils/hp2ps/TraceElement.h b/utils/hp2ps/TraceElement.h new file mode 100644 index 0000000000..d843392a23 --- /dev/null +++ b/utils/hp2ps/TraceElement.h @@ -0,0 +1,6 @@ +#ifndef TRACE_ELEMENT_H +#define TRACE_ELEMENT_H + +void TraceElement PROTO((void)); + +#endif /* TRACE_ELEMENT_H */ diff --git a/utils/hp2ps/Utilities.c b/utils/hp2ps/Utilities.c new file mode 100644 index 0000000000..c9fb612f0e --- /dev/null +++ b/utils/hp2ps/Utilities.c @@ -0,0 +1,132 @@ +#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/utils/hp2ps/Utilities.h b/utils/hp2ps/Utilities.h new file mode 100644 index 0000000000..10776d9613 --- /dev/null +++ b/utils/hp2ps/Utilities.h @@ -0,0 +1,13 @@ +#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/utils/hp2ps/hp2ps.1 b/utils/hp2ps/hp2ps.1 new file mode 100644 index 0000000000..fd0bca0234 --- /dev/null +++ b/utils/hp2ps/hp2ps.1 @@ -0,0 +1,145 @@ +.\" 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/utils/hp2ps/makefile.original b/utils/hp2ps/makefile.original new file mode 100644 index 0000000000..a625149552 --- /dev/null +++ b/utils/hp2ps/makefile.original @@ -0,0 +1,42 @@ +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/utils/hsc2hs/Main.hs b/utils/hsc2hs/Main.hs new file mode 100644 index 0000000000..4b39e4a7bb --- /dev/null +++ b/utils/hsc2hs/Main.hs @@ -0,0 +1,938 @@ +{-# 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/utils/hsc2hs/Makefile b/utils/hsc2hs/Makefile new file mode 100644 index 0000000000..0216983e08 --- /dev/null +++ b/utils/hsc2hs/Makefile @@ -0,0 +1,98 @@ +# ----------------------------------------------------------------------------- +# To compile with nhc98 on unix: +# nhc98 -cpp -package base -o hsc2hs-bin Main.hs + +TOP=../.. +include $(TOP)/mk/boilerplate.mk + +INSTALLING=1 + +# This causes libghccompat.a to be used: +include $(GHC_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)/$(GHC_HSC2HS_DIR_REL) +HSC2HS_DIR=$(FPTOOLS_TOP_ABS_PLATFORM)/$(GHC_HSC2HS_DIR_REL) + +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)/$(GHC_INCLUDE_DIR_REL)" +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/utils/hsc2hs/Makefile.inc b/utils/hsc2hs/Makefile.inc new file mode 100644 index 0000000000..91ac818437 --- /dev/null +++ b/utils/hsc2hs/Makefile.inc @@ -0,0 +1,7 @@ +ifeq "" "${MKDIR}" +MKDIR:=$(shell pwd) +#MKDIR:=$(PWD) +else +MKDIR:=$(patsubst %/$(notdir ${MKDIR}),%, ${MKDIR}) +endif +include ${MKDIR}/Makefile.inc diff --git a/utils/hsc2hs/Makefile.nhc98 b/utils/hsc2hs/Makefile.nhc98 new file mode 100644 index 0000000000..a35a0dc9e7 --- /dev/null +++ b/utils/hsc2hs/Makefile.nhc98 @@ -0,0 +1,48 @@ +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/utils/hsc2hs/hsc2hs.sh b/utils/hsc2hs/hsc2hs.sh new file mode 100644 index 0000000000..fe00d45036 --- /dev/null +++ b/utils/hsc2hs/hsc2hs.sh @@ -0,0 +1,13 @@ + +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/utils/hsc2hs/template-hsc.h b/utils/hsc2hs/template-hsc.h new file mode 100644 index 0000000000..bdc34eda78 --- /dev/null +++ b/utils/hsc2hs/template-hsc.h @@ -0,0 +1,105 @@ +#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/utils/hstags/Makefile b/utils/hstags/Makefile new file mode 100644 index 0000000000..981bafd897 --- /dev/null +++ b/utils/hstags/Makefile @@ -0,0 +1,70 @@ +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/utils/hstags/README b/utils/hstags/README new file mode 100644 index 0000000000..b457ef125a --- /dev/null +++ b/utils/hstags/README @@ -0,0 +1,10 @@ +"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/utils/hstags/hstags-help.c b/utils/hstags/hstags-help.c new file mode 100644 index 0000000000..92604876ff --- /dev/null +++ b/utils/hstags/hstags-help.c @@ -0,0 +1,59 @@ +#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/utils/hstags/hstags.prl b/utils/hstags/hstags.prl new file mode 100644 index 0000000000..16e770bd8a --- /dev/null +++ b/utils/hstags/hstags.prl @@ -0,0 +1,94 @@ +# +# 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/utils/hstags/prefix.txt b/utils/hstags/prefix.txt new file mode 100644 index 0000000000..b67c009c49 --- /dev/null +++ b/utils/hstags/prefix.txt @@ -0,0 +1,9 @@ +# +# 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/utils/lndir/Makefile b/utils/lndir/Makefile new file mode 100644 index 0000000000..c8223df094 --- /dev/null +++ b/utils/lndir/Makefile @@ -0,0 +1,15 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk + +C_SRCS=lndir.c +C_PROG=lndir + +CLEAN_FILES += $(C_PROG)$(exeext) $(C_OBJS) +DESTDIR=$(INSTBINDIR) + +include $(TOP)/mk/target.mk + +# Win32: cygwin supports symlinks, so make sure we +# don't feed in the mingw flags here. In other +# words, lndir.exe is a cygwin-based app. +CC_OPTS := $(filter-out -mno-cygwin,$(CC_OPTS)) diff --git a/utils/lndir/lndir-Xos.h b/utils/lndir/lndir-Xos.h new file mode 100644 index 0000000000..e91e959c73 --- /dev/null +++ b/utils/lndir/lndir-Xos.h @@ -0,0 +1,152 @@ +/* + * $XConsortium: Xos.h,v 1.47 91/08/17 17:14:38 rws Exp $ + * + * Copyright 1987 by the Massachusetts Institute of Technology + * + * Permission to use, copy, modify, and distribute this software and its + * documentation for any purpose and without fee is hereby granted, provided + * that the above copyright notice appear in all copies and that both that + * copyright notice and this permission notice appear in supporting + * documentation, and that the name of M.I.T. not be used in advertising + * or publicity pertaining to distribution of the software without specific, + * written prior permission. M.I.T. makes no representations about the + * suitability of this software for any purpose. It is provided "as is" + * without express or implied warranty. + * + * The X Window System is a Trademark of MIT. + * + */ + +/* This is a collection of things to try and minimize system dependencies + * in a "signficant" number of source files. + */ + +#ifndef _XOS_H_ +#define _XOS_H_ + +#include "lndir-Xosdefs.h" + +/* + * Get major data types (esp. caddr_t) + */ + +#ifdef USG +#ifndef __TYPES__ +#ifdef CRAY +#define word word_t +#endif /* CRAY */ +#include <sys/types.h> /* forgot to protect it... */ +#define __TYPES__ +#endif /* __TYPES__ */ +#else /* USG */ +#if defined(_POSIX_SOURCE) && defined(MOTOROLA) +#undef _POSIX_SOURCE +#include <sys/types.h> +#define _POSIX_SOURCE +#else +#include <sys/types.h> +#endif +#endif /* USG */ + + +/* + * Just about everyone needs the strings routines. We provide both forms here, + * index/rindex and strchr/strrchr, so any systems that don't provide them all + * need to have #defines here. + */ + +#ifndef X_NOT_STDC_ENV +#include <string.h> +#define index strchr +#define rindex strrchr +#else +#ifdef SYSV +#include <string.h> +#define index strchr +#define rindex strrchr +#else +#include <strings.h> +#define strchr index +#define strrchr rindex +#endif +#endif + + +/* + * Get open(2) constants + */ +#ifdef X_NOT_POSIX +#include <fcntl.h> +#ifdef USL +#include <unistd.h> +#endif /* USL */ +#ifdef CRAY +#include <unistd.h> +#endif /* CRAY */ +#ifdef MOTOROLA +#include <unistd.h> +#endif /* MOTOROLA */ +#ifdef SYSV386 +#include <unistd.h> +#endif /* SYSV386 */ +#include <sys/file.h> +#else /* X_NOT_POSIX */ +#if !defined(_POSIX_SOURCE) && defined(macII) +#define _POSIX_SOURCE +#include <fcntl.h> +#undef _POSIX_SOURCE +#else +#include <fcntl.h> +#endif +#include <unistd.h> +#endif /* X_NOT_POSIX else */ + +/* + * Get struct timeval + */ + +#ifdef SYSV + +#ifndef USL +#include <sys/time.h> +#endif +#include <time.h> +#ifdef CRAY +#undef word +#endif /* CRAY */ +#if defined(USG) && !defined(CRAY) && !defined(MOTOROLA) +struct timeval { + long tv_sec; + long tv_usec; +}; +#ifndef USL_SHARELIB +struct timezone { + int tz_minuteswest; + int tz_dsttime; +}; +#endif /* USL_SHARELIB */ +#endif /* USG */ + +#else /* not SYSV */ + +#if defined(_POSIX_SOURCE) && defined(SVR4) +/* need to omit _POSIX_SOURCE in order to get what we want in SVR4 */ +#undef _POSIX_SOURCE +#include <sys/time.h> +#define _POSIX_SOURCE +#else +#include <sys/time.h> +#endif + +#endif /* SYSV */ + +/* use POSIX name for signal */ +#if defined(X_NOT_POSIX) && defined(SYSV) && !defined(SIGCHLD) +#define SIGCHLD SIGCLD +#endif + +#ifdef ISC +#include <sys/bsdtypes.h> +#endif + +#endif /* _XOS_H_ */ diff --git a/utils/lndir/lndir-Xosdefs.h b/utils/lndir/lndir-Xosdefs.h new file mode 100644 index 0000000000..e21db4b24e --- /dev/null +++ b/utils/lndir/lndir-Xosdefs.h @@ -0,0 +1,99 @@ +/* + * O/S-dependent (mis)feature macro definitions + * + * $XConsortium: Xosdefs.h,v 1.7 91/07/19 23:22:19 rws Exp $ + * + * Copyright 1991 Massachusetts Institute of Technology + * + * Permission to use, copy, modify, distribute, and sell this software and its + * documentation for any purpose is hereby granted without fee, provided that + * the above copyright notice appear in all copies and that both that + * copyright notice and this permission notice appear in supporting + * documentation, and that the name of M.I.T. not be used in advertising or + * publicity pertaining to distribution of the software without specific, + * written prior permission. M.I.T. makes no representations about the + * suitability of this software for any purpose. It is provided "as is" + * without express or implied warranty. + * + * M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL M.I.T. + * BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION + * OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN + * CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + */ + +#ifndef _XOSDEFS_H_ +#define _XOSDEFS_H_ + +/* + * X_NOT_STDC_ENV means does not have ANSI C header files. Lack of this + * symbol does NOT mean that the system has stdarg.h. + * + * X_NOT_POSIX means does not have POSIX header files. Lack of this + * symbol does NOT mean that the POSIX environment is the default. + * You may still have to define _POSIX_SOURCE to get it. + */ + +#ifdef NOSTDHDRS +#define X_NOT_POSIX +#define X_NOT_STDC_ENV +#endif + +#ifdef NeXT +#define X_NOT_POSIX +#endif + +#ifdef sony +#ifndef SYSTYPE_SYSV +#define X_NOT_POSIX +#endif +#endif + +#ifdef UTEK +#define X_NOT_POSIX +#define X_NOT_STDC_ENV +#endif + +#ifdef CRAY +#define X_NOT_POSIX +#endif + +#ifdef vax +#ifndef ultrix /* assume vanilla BSD */ +#define X_NOT_POSIX +#define X_NOT_STDC_ENV +#endif +#endif + +#ifdef luna +#define X_NOT_POSIX +#define X_NOT_STDC_ENV +#endif + +#ifdef Mips +#define X_NOT_POSIX +#define X_NOT_STDC_ENV +#endif + +#ifdef USL +#ifdef SYSV /* (release 3.2) */ +#define X_NOT_POSIX +#define X_NOT_STDC_ENV +#endif +#endif + +#ifdef SYSV386 +#ifdef SYSV +#define X_NOT_POSIX +#define X_NOT_STDC_ENV +#endif +#endif + +#ifdef MOTOROLA +#ifdef SYSV +#define X_NOT_STDC_ENV +#endif +#endif + +#endif /* _XOSDEFS_H_ */ diff --git a/utils/lndir/lndir.c b/utils/lndir/lndir.c new file mode 100644 index 0000000000..c65715e379 --- /dev/null +++ b/utils/lndir/lndir.c @@ -0,0 +1,399 @@ +/* $XConsortium: lndir.c /main/16 1996/09/28 16:16:40 rws $ */ +/* Create shadow link tree (after X11R4 script of the same name) + Mark Reinhold (mbr@lcs.mit.edu)/3 January 1990 */ + +/* +Copyright (c) 1990, X Consortium + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN +AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +Except as contained in this notice, the name of the X Consortium shall not be +used in advertising or otherwise to promote the sale, use or other dealings +in this Software without prior written authorization from the X Consortium. + +*/ + +/* From the original /bin/sh script: + + Used to create a copy of the a directory tree that has links for all + non-directories (except those named RCS, SCCS or CVS.adm). If you are + building the distribution on more than one machine, you should use + this technique. + + If your master sources are located in /usr/local/src/X and you would like + your link tree to be in /usr/local/src/new-X, do the following: + + % mkdir /usr/local/src/new-X + % cd /usr/local/src/new-X + % lndir ../X +*/ + +#include "lndir-Xos.h" +#include <stdlib.h> +#include <stdio.h> +#include <sys/stat.h> +#include <sys/param.h> +#include <errno.h> + +#ifndef X_NOT_POSIX +#include <dirent.h> +#else +#ifdef SYSV +#include <dirent.h> +#else +#ifdef USG +#include <dirent.h> +#else +#include <sys/dir.h> +#ifndef dirent +#define dirent direct +#endif +#endif +#endif +#endif +#ifndef MAXPATHLEN +#define MAXPATHLEN 2048 +#endif + +#ifdef __CYGWIN32__ +#include <sys/cygwin.h> +#endif + +#if NeedVarargsPrototypes +#include <stdarg.h> +#endif + +#ifdef X_NOT_STDC_ENV +extern int errno; +#endif +int silent = 0; /* -silent */ +int ignore_links = 0; /* -ignorelinks */ + +char *rcurdir; +char *curdir; + +int force=0; + +void +quit ( +#if NeedVarargsPrototypes + int code, char * fmt, ...) +#else + code, fmt, a1, a2, a3) + char *fmt; +#endif +{ +#if NeedVarargsPrototypes + va_list args; + va_start(args, fmt); + vfprintf (stderr, fmt, args); + va_end(args); +#else + fprintf (stderr, fmt, a1, a2, a3); +#endif + putc ('\n', stderr); + exit (code); +} + +void +quiterr (code, s) + char *s; +{ + perror (s); + exit (code); +} + +void +msg ( +#if NeedVarargsPrototypes + char * fmt, ...) +#else + fmt, a1, a2, a3) + char *fmt; +#endif +{ +#if NeedVarargsPrototypes + va_list args; +#endif + if (curdir) { + fprintf (stderr, "%s:\n", curdir); + curdir = 0; + } +#if NeedVarargsPrototypes + va_start(args, fmt); + vfprintf (stderr, fmt, args); + va_end(args); +#else + fprintf (stderr, fmt, a1, a2, a3); +#endif + putc ('\n', stderr); +} + +void +mperror (s) + char *s; +{ + if (curdir) { + fprintf (stderr, "%s:\n", curdir); + curdir = 0; + } + perror (s); +} + + +int equivalent(lname, rname) + char *lname; + char *rname; +{ + char *s; + + if (!strcmp(lname, rname)) + return 1; + for (s = lname; *s && (s = strchr(s, '/')); s++) { + while (s[1] == '/') + strcpy(s+1, s+2); + } + return !strcmp(lname, rname); +} + + +/* Recursively create symbolic links from the current directory to the "from" + directory. Assumes that files described by fs and ts are directories. */ + +dodir (fn, fs, ts, rel) +char *fn; /* name of "from" directory, either absolute or + relative to cwd */ +struct stat *fs, *ts; /* stats for the "from" directory and cwd */ +int rel; /* if true, prepend "../" to fn before using */ +{ + DIR *df; + struct dirent *dp; + char buf[MAXPATHLEN + 1], *p; + char symbuf[MAXPATHLEN + 1]; + char basesym[MAXPATHLEN + 1]; + struct stat sb, sc; + int n_dirs; + int symlen; + int basesymlen = -1; + char *ocurdir; + + if ((fs->st_dev == ts->st_dev) && (fs->st_ino == ts->st_ino)) { + msg ("%s: From and to directories are identical!", fn); + return 1; + } + + if (rel) + strcpy (buf, "../"); + else + buf[0] = '\0'; + strcat (buf, fn); + + if (!(df = opendir (buf))) { + msg ("%s: Cannot opendir", buf); + return 1; + } + + p = buf + strlen (buf); + *p++ = '/'; + n_dirs = fs->st_nlink; + while (dp = readdir (df)) { + if (dp->d_name[strlen(dp->d_name) - 1] == '~') + continue; + if (dp->d_name[0] == '.' && dp->d_name[1] == '#') /* 'non-conflict files' left behind by CVS */ + continue; + strcpy (p, dp->d_name); + + if (n_dirs > 0) { + if (stat (buf, &sb) < 0) { + mperror (buf); + continue; + } + +#ifdef S_ISDIR + if(S_ISDIR(sb.st_mode)) +#else + if (sb.st_mode & S_IFDIR) +#endif + { + /* directory */ +#ifndef __CYGWIN32__ /* don't trust cygwin's n_dirs count */ + n_dirs--; +#endif + if (dp->d_name[0] == '.' && + (dp->d_name[1] == '\0' || (dp->d_name[1] == '.' && + dp->d_name[2] == '\0'))) + continue; + if (!strcmp (dp->d_name, "RCS")) + continue; + if (!strcmp (dp->d_name, "SCCS")) + continue; + if (!strcmp (dp->d_name, "CVS")) + continue; + if (!strcmp (dp->d_name, ".svn")) + continue; + if (!strcmp (dp->d_name, "_darcs")) + continue; + if (!strcmp (dp->d_name, "CVS.adm")) + continue; + ocurdir = rcurdir; + rcurdir = buf; + curdir = silent ? buf : (char *)0; + if (!silent) + printf ("%s:\n", buf); + if ((stat (dp->d_name, &sc) < 0) && (errno == ENOENT)) { + if (mkdir (dp->d_name, 0777) < 0 || + stat (dp->d_name, &sc) < 0) { + mperror (dp->d_name); + curdir = rcurdir = ocurdir; + continue; + } + } + if (readlink (dp->d_name, symbuf, sizeof(symbuf) - 1) >= 0) { + msg ("%s: is a link instead of a directory", dp->d_name); + curdir = rcurdir = ocurdir; + continue; + } + if (chdir (dp->d_name) < 0) { + mperror (dp->d_name); + curdir = rcurdir = ocurdir; + continue; + } + dodir (buf, &sb, &sc, (buf[0] != '/')); + if (chdir ("..") < 0) + quiterr (1, ".."); + curdir = rcurdir = ocurdir; + continue; + } + } + + /* non-directory */ + symlen = readlink (dp->d_name, symbuf, sizeof(symbuf) - 1); + if (symlen >= 0) + symbuf[symlen] = '\0'; + + /* The option to ignore links exists mostly because + checking for them slows us down by 10-20%. + But it is off by default because this really is a useful check. */ + if (!ignore_links) { + /* see if the file in the base tree was a symlink */ + basesymlen = readlink(buf, basesym, sizeof(basesym) - 1); + if (basesymlen >= 0) + basesym[basesymlen] = '\0'; + } + + if (symlen >= 0) { + if (!equivalent (basesymlen>=0 ? basesym : buf, symbuf)) { + if (force) { + unlink(dp->d_name); + if (symlink (basesymlen>=0 ? basesym : buf, dp->d_name) < 0) + mperror (dp->d_name); + } else { + /* Link exists in new tree. Print message if it doesn't match. */ + msg ("%s: %s", dp->d_name, symbuf); + } + } + } else { + if (symlink (basesymlen>=0 ? basesym : buf, dp->d_name) < 0) + mperror (dp->d_name); + } + } + + closedir (df); + return 0; +} + + +main (ac, av) +int ac; +char **av; +{ + char *prog_name = av[0]; + char* tn; + struct stat fs, ts; +#ifdef __CYGWIN32__ + /* + The lndir code assumes unix-style paths to work. cygwin + lets you get away with using dos'ish paths (e.g., "f:/oo") + in most contexts. Using them with 'lndir' will seriously + confuse the user though, so under-the-hood, we convert the + path into something POSIX-like. + */ + static char fn[MAXPATHLEN+1]; +#else + char *fn; +#endif + + while (++av, --ac) { + if (strcmp(*av, "-silent") == 0) + silent = 1; + else if (strcmp(*av, "-f") == 0) + force = 1; + else if (strcmp(*av, "-ignorelinks") == 0) + ignore_links = 1; + else if (strcmp(*av, "--") == 0) { + ++av, --ac; + break; + } else + break; + } + + if (ac < 1 || ac > 2) + quit (1, "usage: %s [-f] [-silent] [-ignorelinks] fromdir [todir]", + prog_name); + +#ifdef __CYGWIN32__ + cygwin_conv_to_full_posix_path(av[0], fn); +#else + fn = av[0]; +#endif + + if (ac == 2) + tn = av[1]; + else + tn = "."; + + /* to directory */ + if (stat (tn, &ts) < 0) { + if (force && (tn[0] != '.' || tn[1] != '\0') ) { + mkdir(tn, S_IRWXU | S_IRWXG | S_IROTH | S_IXOTH ); + } + else { + quiterr (1, tn); +#ifdef S_ISDIR + if (!(S_ISDIR(ts.st_mode))) +#else + if (!(ts.st_mode & S_IFDIR)) +#endif + quit (2, "%s: Not a directory", tn); + } + } + if (chdir (tn) < 0) + quiterr (1, tn); + + /* from directory */ + if (stat (fn, &fs) < 0) + quiterr (1, fn); +#ifdef S_ISDIR + if (!(S_ISDIR(fs.st_mode))) +#else + if (!(fs.st_mode & S_IFDIR)) +#endif + quit (2, "%s: Not a directory", fn); + + exit (dodir (fn, &fs, &ts, 0)); +} diff --git a/utils/ltx/Makefile b/utils/ltx/Makefile new file mode 100644 index 0000000000..480fa0d812 --- /dev/null +++ b/utils/ltx/Makefile @@ -0,0 +1,12 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk + +SCRIPT_PROG=ltx +SCRIPT_OBJS=ltx.prl +SCRIPT_SUBST_VARS=DEFAULT_TMPDIR CONTEXT_DIFF + +INTERP=perl +DESTDIR=$(INSTSCRIPTDIR) +CLEAN_FILES += $(SCRIPT_PROG) + +include $(TOP)/mk/target.mk diff --git a/utils/ltx/ltx.prl b/utils/ltx/ltx.prl new file mode 100644 index 0000000000..96dbc71026 --- /dev/null +++ b/utils/ltx/ltx.prl @@ -0,0 +1,229 @@ +# +# The perl script requires bindings for the following +# variables to be prepended: +# DEFAULT_TMPDIR +# CONTEXTDIFF +# + +$Pgm = $0; $Pgm =~ s/.*\/([^\/]+)$/\1/; +# +# set up signal handler +sub quit_upon_signal { &rm_temp_files_and_exit(); } +$SIG{'INT'} = 'quit_upon_signal'; +$SIG{'QUIT'} = 'quit_upon_signal'; +# +$Verbose = 0; +if ($ARGV[0] eq '-v') { + $Verbose = 1; + shift(@ARGV); +} +# +die "$Pgm: must have exactly one argument\n" if $#ARGV != 0; +# figure out input file and its filename root +if (-f $ARGV[0]) { + $TeX_input = $ARGV[0]; + if ($TeX_input =~ /(.+)\.[^\.\/\n]+$/) { + $TeX_root = $1; + } else { + $TeX_root = $TeX_input; + } +} elsif (-f $ARGV[0].'.tex') { + $TeX_input = $ARGV[0].'.tex'; + $TeX_root = $ARGV[0]; +} else { + die "$Pgm: input file $ARGV[0] doesn't exist\n"; +} + +if ( $ENV{'TMPDIR'} ) { # where to make tmp file names + $Tmp_prefix = $ENV{'TMPDIR'} ; +} else { + $Tmp_prefix ="$DEFAULT_TMPDIR"; + $ENV{'TMPDIR'} = "$DEFAULT_TMPDIR"; # set the env var as well +} + +sub rm_temp_files { + system("rm -f $Tmp_prefix/ltx-*.$$"); +} +sub rm_temp_files_and_exit { + system("rm -f $Tmp_prefix/ltx-*.$$"); + exit(1); +} +$SIG{'INT'} = 'rm_temp_files_and_exit'; +$SIG{'QUIT'} = 'rm_temp_files_and_exit'; + +sub die_gracefully { + local($msg) = @_; + + print STDERR $msg; + &rm_temp_files_and_exit(); +} + +# must read through root file to see if a \bibliography +# is there... +$Bibliography_requested = 0; +open(TEXIF, "<$TeX_input") + || &die_gracefully("$Pgm: Can't read $TeX_input\n"); +while (<TEXIF>) { + $Bibliography_requested = 1 if /^\\bibliography/; +} +close(TEXIF); +&die_gracefully("$Pgm: reading $TeX_input had errors\n") if $? >> 8; + +# run latex first time (?) +&run_latex(); # sets $Says_labels_changed +$Times_run = 1; + +while (&something_more_needed()) { + + print STDERR "labels_changed=$Says_label_changed;bibtex_needed=$BibTeX_run_needed;makeindex_needed=$MakeIndex_run_needed\n" if $Verbose; + + if ($BibTeX_run_needed) { + &run_bibtex(); + } + if ($MakeIndex_run_needed) { + unlink "$TeX_root.ind"; + (system("makeindex $TeX_root.idx") >> 8) + && &die_gracefully("$Pgm: makeindex $TeX_root.idx had errors\n"); + } + + # save (copy) .aux file as .aux-prev file for future ref + # ditto for .idx file + unlink "$TeX_root.aux-prev"; + (system("cp $TeX_root.aux $TeX_root.aux-prev") >> 8) + && &die_gracefully("$Pgm: cp $TeX_root.aux $TeX_root.aux-prev failed\n"); + if (-f "$TeX_root.idx") { + unlink "$TeX_root.idx-prev"; + (system("cp $TeX_root.idx $TeX_root.idx-prev") >> 8) + && &die_gracefully("$Pgm: cp $TeX_root.idx $TeX_root.idx-prev failed\n"); + } + + # run latex again + &run_latex(); # sets $Says_labels_changed + $Times_run++; + + if ($Times_run >= 4) { + print STDERR "*** I don't run LaTeX more than four times;\n"; + print STDERR "*** Something is probably wrong...\n"; + &rm_temp_files_and_exit(); + } +} +&rm_temp_files(); +exit(0); + +sub run_latex { + $Says_labels_changed = 0; + $Multiply_defined_labels = 0; + + select(STDERR); $| = 1; select(STDOUT); # no buffering on STDERR + print STDERR "$Pgm: *** running LaTeX...\n" if $Verbose; + unlink "$TeX_root.dvi"; + + open(LTXPIPE, "latex $TeX_input 2>&1 |") + || &die_gracefully("$Pgm: Can't run latex pipe\n"); + while (<LTXPIPE>) { + $Multiply_defined_labels = 1 if /^LaTeX Warning: Label .* multiply defined/; + $Says_labels_changed = 1 if /^LaTeX Warning: Label\(s\) may have changed/ + && ! $Multiply_defined_labels; + print STDERR $_; + } + close(LTXPIPE); + &die_gracefully("$Pgm: LaTeX run had errors\n") if $? >> 8; + + # sort .idx file, because this helps makeindex + # (can you say `bug'?) + if (-f "$TeX_root.idx") { + print STDERR "$Pgm: *** sorting $TeX_root.idx...\n" if $Verbose; + (system("sort $TeX_root.idx -o $TeX_root.idx") >> 8) + && &die_gracefully("$Pgm: sorting $TeX_root.idx failed\n"); + } + +} + +sub run_bibtex { # ugly because bibtex doesn't return a correct error status + local($bibtex_had_errors) = 0; + + print STDERR "$Pgm: *** running BibTeX...\n" if $Verbose; + unlink "$TeX_root.bbl"; + + $| = 1; # no buffering + open(BIBTXPIPE, "bibtex $TeX_root 2>&1 |") + || &die_gracefully("$Pgm: Can't run bibtex pipe\n"); + while (<BIBTXPIPE>) { + $bibtex_had_errors = 1 if /^\(There.*error message(s)?\)$/; + print STDERR $_; + } + close(BIBTXPIPE); + &die_gracefully("$Pgm: BibTeX run had errors\n") + if $? >> 8 || $bibtex_had_errors; +} + +sub something_more_needed { + # returns 1 or 0 if we need to run LaTeX + # possibly preceded by bibtex and/or makeindex run + + # $Says_labels_changed was set by previous &run_latex... + $BibTeX_run_needed = 0; + $MakeIndex_run_needed = 0; + + if ( ! -f ($TeX_root . '.aux-prev')) { # this was the first run + + print STDERR "$Pgm: *** 'twas first run of LaTeX on $TeX_input\n" if $Verbose; + + # we need makeindex to run if a non-zero-sized .idx file exists + # + $MakeIndex_run_needed = 1 + if -f "$TeX_root.idx" && -s "$TeX_root.idx"; + + # we need bibtex to run if there are \citations in the .aux file + # + &slurp_aux_file('aux'); + $BibTeX_run_needed = 1 + if $Bibliography_requested && + -f "$Tmp_prefix/ltx-aux-cite.$$" && + -s "$Tmp_prefix/ltx-aux-cite.$$"; + + + } else { # ltx had been run before (.aux-prev/.idx-prev files exist) + + # slurp both .aux and .aux-prev files + &slurp_aux_file('aux'); + &slurp_aux_file('aux-prev'); + + local($tmp_pre) = "$Tmp_prefix/ltx"; + + if ((-s "$tmp_pre-.aux-cite.$$") # there are still \cite's in there + && (system("cmp -s $tmp_pre-.aux-cite.$$ $tmp_pre-.aux-prev-cite.$$") >> 8)) { + $BibTeX_run_needed = 1 if $Bibliography_requested; + if ($Verbose) { + system("$CONTEXT_DIFF $tmp_pre-.aux-prev-cite.$$ $tmp_pre-.aux-cite.$$"); + } + } + + if (-f "$TeX_root.idx") { + $MakeIndex_run_needed = + (system("cmp -s $TeX_root.idx $TeX_root.idx-prev") >> 8) ? 1 : 0; + if ($MakeIndex_run_needed && $Verbose) { + system("$CONTEXT_DIFF $TeX_root.idx-prev $TeX_root.idx"); + } + } + } + + $Says_labels_changed || $BibTeX_run_needed || $MakeIndex_run_needed; +} + +sub slurp_aux_file { + local($ext) = @_; + + # copy all citations from slurpfile into $Tmp_prefix/ltx-$ext-cite.$$ + + open(SLURPF,"< $TeX_root.$ext") + || &die_gracefully("$Pgm: Can't open $TeX_root.$ext for reading\n"); + open(CITEF,"> $Tmp_prefix/ltx-$ext-cite.$$") + || &die_gracefully("$Pgm: Can't open $Tmp_prefix/ltx-$ext-cite.$$ for writing\n"); + + while (<SLURPF>) { + print CITEF $_ if /\\citation/; + } + close(CITEF); + close(SLURPF); +} diff --git a/utils/mkdependC/Makefile b/utils/mkdependC/Makefile new file mode 100644 index 0000000000..9b07685bb3 --- /dev/null +++ b/utils/mkdependC/Makefile @@ -0,0 +1,21 @@ +# +# Boilerplate Makefile for building perl script that +# needs some configured constants prepended to it. +# +TOP=../.. +include $(TOP)/mk/boilerplate.mk + +boot :: all + +SCRIPT_PROG=mkdependC +SCRIPT_OBJS=mkdependC.prl +# +# Prepend (perl) bindings for these Makefile variables +# when creating `mkdependC' (a more flexible way of doing msub). +# +SCRIPT_SUBST_VARS=DEFAULT_TMPDIR CPP BUILDPLATFORM + +CLEAN_FILES += $(SCRIPT_PROG) +INTERP=perl + +include $(TOP)/mk/target.mk diff --git a/utils/mkdependC/mkdependC.prl b/utils/mkdependC/mkdependC.prl new file mode 100644 index 0000000000..f7af53ac3c --- /dev/null +++ b/utils/mkdependC/mkdependC.prl @@ -0,0 +1,231 @@ +# +# This perl script template assumes that definitions for +# the following variables are prepended: +# +# DEFAULT_TMPDIR CPP BUILDPLATFORM +# +# ToDo: strip out all the .h junk +# +($Pgm = $0) =~ s/.*\/([^\/]+)$/\1/; +$Usage = "usage: $Pgm: not done yet\n"; + +$Status = 0; # just used for exit() status +$Verbose = 0; +$Dashdashes_seen = 0; + +$Begin_magic_str = "# DO NOT DELETE: Beginning of C dependencies"; +$End_magic_str = "# DO NOT DELETE: End of C dependencies"; +$Obj_suffix = 'o'; +@Defines = (); +$Include_dirs = ''; +$Makefile = ''; +@Src_files = (); +@File_suffix = (); +$baseName=''; +$ignore_output='> /dev/null'; + +if ( ${BUILDPLATFORM} eq "i386-unknown-mingw32" ) { + # Assuming the underlying perl uses cmd to exec system() calls. + $ignore_output = ">nul"; +} + +if ( $ENV{'TMPDIR'} ) { # where to make tmp file names + $Tmp_prefix = $ENV{'TMPDIR'} . "/mkdependC$$"; +} else { + $Tmp_prefix ="${DEFAULT_TMPDIR}/mkdependC$$"; + $ENV{'TMPDIR'} = "${DEFAULT_TMPDIR}"; # set the env var as well +} + +$tempfile = ''; + +sub quit_upon_signal { + if (-f $tempfile) { + print STDERR "Deleting $tempfile .. \n"; + unlink $tempfile; + } +} +$SIG{'INT'} = 'quit_upon_signal'; +$SIG{'QUIT'} = 'quit_upon_signal'; + +&mangle_command_line_args(); + +if ( ! $Makefile && -f 'makefile' ) { + $Makefile = 'makefile'; +} elsif ( ! $Makefile && -f 'Makefile') { + $Makefile = 'Makefile'; +} elsif ( ! $Makefile) { + die "$Pgm: no makefile or Makefile found\n"; +} + +@Depend_lines = (); + +print STDERR "Include_dirs=$Include_dirs\n" if $Verbose; + +foreach $sf (@Src_files) { + # just like lit-inputter + # except it puts each file through CPP and + # a de-commenter (not implemented); + # builds up @Depend_lines + print STDERR "Here we go for source file: $sf\n" if $Verbose; + ($baseName = $sf) =~ s/\.(c|hc)$//; + + &slurp_file($sf, 'fh00'); +} + +# Tiresome EOL termination issues +if ( ${BUILDPLATFORM} eq "i386-unknown-mingw32" ) { + $Begin_magic_str = $Begin_magic_str . "\r\n"; + $End_magic_str = $End_magic_str . "\r\n"; +} else { + $Begin_magic_str = $Begin_magic_str . "\n"; + $End_magic_str = $End_magic_str . "\n"; +} + +# OK, mangle the Makefile +unlink("$Makefile.bak"); +rename($Makefile,"$Makefile.bak"); +# now copy Makefile.bak into Makefile, rm'ing old dependencies +# and adding the new +open(OMKF,"< $Makefile.bak") || die "$Pgm: can't open $Makefile.bak: $!\n"; +open(NMKF,"> $Makefile") || die "$Pgm: can't open $Makefile: $!\n"; +binmode(OMKF); # Do not add stupid ^M's to the output on Win32 +binmode(NMKF); # Do not add stupid ^M's to the output on Win32 + +select(NMKF); +$_ = <OMKF>; +while ($_ && $_ ne $Begin_magic_str) { # copy through, 'til Begin_magic_str + print $_; + $_ = <OMKF>; +} +while ($_ && $_ ne $End_magic_str) { # delete 'til End_magic_str + $_ = <OMKF>; +} +# insert dependencies +print $Begin_magic_str; +print @Depend_lines; +print $End_magic_str; +while (<OMKF>) { # copy the rest through + print $_; +} +close(NMKF); +close(OMKF); +exit 0; + +sub mangle_command_line_args { + while($_ = $ARGV[0]) { + shift(@ARGV); + + if ( /^--$/ ) { + $Dashdashes_seen++; + + } elsif ( /^(-optc)?(-D.*)/ ) { # recognized wherever they occur + push(@Defines, $2); + } elsif ( /^(-optc)?(-I.*)/ ) { + $Include_dirs .= " $2"; + + } elsif ($Dashdashes_seen != 1) { # not between -- ... -- + if ( /^-v$/ ) { + $Verbose++; + } elsif ( /^-f/ ) { + $Makefile = &grab_arg_arg($_); + } elsif ( /^-o/ ) { + $Obj_suffix = &grab_arg_arg($_); + } elsif ( /^-s/ ) { + local($suff) = &grab_arg_arg($_); + push(@File_suffix, $suff); + } elsif ( /^-bs/ ) { + $Begin_magic_str = &grab_arg_arg($_); + } elsif ( /^-es/ ) { + $End_magic_str = &grab_arg_arg($_); + } elsif ( /^-w/ ) { + $Width = &grab_arg_arg($_); + } elsif ( /^-/ ) { + print STDERR "$Pgm: unknown option ignored: $_\n"; + } else { + push(@Src_files, $_); + } + + } elsif ($Dashdashes_seen == 1) { # where we ignore unknown options + push(@Src_files,$_) if ! /^-/; + } + } +} + +sub grab_arg_arg { + local($option) = @_; + local($rest_of_arg); + + ($rest_of_arg = $option) =~ s/^-.//; + + if ($rest_of_arg) { + return($rest_of_arg); + } elsif ($#ARGV >= 0) { + local($temp) = $ARGV[0]; shift(@ARGV); + return($temp); + } else { + die "$Pgm: no argument following $option option\n"; + } +} + +sub slurp_file { # follows an example in the `open' item in perl man page + local($fname,$fhandle) = @_; + local($depend,$dep); # tmp + local(@Deps); + + $fhandle++; # a string increment + + $fname = &tidy_dir_names($fname); + + ($tempfile = $fname) =~ s/\.[^\.]*$/\.d/; + $tempfile =~ s|.*/([^/]+)$|$1|g; + + # ${CPP} better be 'gcc -E', or the -x option will fail... + # ..and the -MM & -MMD. + $result = system("${CPP} -MM -MMD $Include_dirs @Defines -x c $fname $ignore_output"); + + if ($result != 0) { + # On the cheesy side..we do want to know what went wrong, so + # re-run the command. + $result = system("${CPP} -MM -MMD $Include_dirs @Defines -x c $fname "); + if ($result != 0) { + unlink($tempfile); + exit($result); + } + }; + + local($dep_contents)=''; + local($deps)=''; + open($fhandle, $tempfile) || die "$Pgm: Can't open $tempfile: $!\n"; + + while (<$fhandle>) { + chop; + $dep_contents .= $_; + } + ($deps = $dep_contents) =~ s|^[^:]+:(.*)$|$1|g; + $deps =~ s| \\| |g; + + @Deps = split(/ +/, $deps); + + $depend = "$baseName.$Obj_suffix"; + foreach $suff (@File_suffix) { + $depend .= " $baseName.${suff}_$Obj_suffix"; + } + + foreach $dep (@Deps) { + push(@Depend_lines, "$depend: $dep\n") if $dep ne ''; + } + + close($fhandle); + unlink($tempfile); + $tempfile = ''; # for quit_upon_signal +} + +sub tidy_dir_names { # rm various pernicious dir-name combinations... + local($str) = @_; + + $str =~ s|/[^/.][^/]*/\.\.||g; # nuke: /<dir>/.. + $str =~ s|/\.[^.][^/]*/\.\.||g; # nuke: /./.. (and others) + $str =~ s|"||g; + $str =~ s| \./| |; + $str; +} diff --git a/utils/mkdirhier/Makefile b/utils/mkdirhier/Makefile new file mode 100644 index 0000000000..f698112dbb --- /dev/null +++ b/utils/mkdirhier/Makefile @@ -0,0 +1,11 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk + +boot :: all + +SCRIPT_PROG=mkdirhier +SCRIPT_OBJS=mkdirhier.sh +INTERP=$(SHELL) +CLEAN_FILES += $(SCRIPT_PROG) + +include $(TOP)/mk/target.mk diff --git a/utils/mkdirhier/mkdirhier.sh b/utils/mkdirhier/mkdirhier.sh new file mode 100644 index 0000000000..3ae24b3c6e --- /dev/null +++ b/utils/mkdirhier/mkdirhier.sh @@ -0,0 +1,34 @@ +#!/bin/sh + +# +# create a hierarchy of directories +# +# Based on Noah Friedman's mkinstalldirs.. +# +errs=0 + +for f in $*; do + parts=`echo ":$f" | sed -ne 's/^:\//#/;s/^://;s/\// /g;s/^#/\//;p'` + path=""; + for p in $parts; do + path="$path$p" + case "$path" in + -* ) path=./$path ;; + esac + + if test ! -d "$path"; then + echo "mkdir $path" 1>&2 + + mkdir "$path" || lasterr=$? + + if test ! -d "$path"; then + errs=$lasterr + fi + fi + path="$path/"; + done; +done + +exit $errs + +# end of story diff --git a/utils/nofib-analyse/CmdLine.hs b/utils/nofib-analyse/CmdLine.hs new file mode 100644 index 0000000000..6e920f8c60 --- /dev/null +++ b/utils/nofib-analyse/CmdLine.hs @@ -0,0 +1,69 @@ +----------------------------------------------------------------------------- +-- CmdLine.hs + +-- (c) Simon Marlow 2005 +----------------------------------------------------------------------------- + +module CmdLine where + +import System.Console.GetOpt +import System.Environment ( getArgs ) +import System.IO.Unsafe ( unsafePerformIO ) + +----------------------------------------------------------------------------- +-- Command line arguments + +args = unsafePerformIO getArgs +(flags, other_args, cmdline_errors) = getOpt Permute argInfo args + +default_tooquick_threshold = 0.2 {- secs -} :: Float +tooquick_threshold + = case [ i | OptIgnoreSmallTimes i <- flags ] of + [] -> default_tooquick_threshold + (i:_) -> i + +devs = OptDeviations `elem` flags +nodevs = OptNoDeviations `elem` flags + +default_title = "NoFib Results" +reportTitle = case [ t | OptTitle t <- flags ] of + [] -> default_title + (t:_) -> t + +data CLIFlags + = OptASCIIOutput + | OptLaTeXOutput + | OptHTMLOutput + | OptIgnoreSmallTimes Float + | OptDeviations + | OptNoDeviations + | OptTitle String + | OptColumns String + | OptRows String + | OptHelp + deriving Eq + +argInfo :: [ OptDescr CLIFlags ] +argInfo = + [ Option ['?'] ["help"] (NoArg OptHelp) + "Display this message" + , Option ['a'] ["ascii"] (NoArg OptASCIIOutput) + "Produce ASCII output (default)" + , Option ['h'] ["html"] (NoArg OptHTMLOutput) + "Produce HTML output" + , Option ['i'] ["ignore"] (ReqArg (OptIgnoreSmallTimes . read) "secs") + "Ignore runtimes smaller than <secs>" + , Option ['d'] ["deviations"] (NoArg OptDeviations) + "Display deviations (default)" + , Option ['l'] ["latex"] (NoArg OptLaTeXOutput) + "Produce LaTeX output" + , Option [] ["columns"] (ReqArg OptColumns "COLUMNS") + "Specify columns for summary table (comma separates)" + , Option [] ["rows"] (ReqArg OptRows "ROWS") + "Specify rows for summary table (comma separates)" + , Option ['n'] ["nodeviations"] (NoArg OptNoDeviations) + "Hide deviations" + , Option ['t'] ["title"] (ReqArg OptTitle "title") + "Specify report title" + ] + diff --git a/utils/nofib-analyse/GenUtils.lhs b/utils/nofib-analyse/GenUtils.lhs new file mode 100644 index 0000000000..540199f972 --- /dev/null +++ b/utils/nofib-analyse/GenUtils.lhs @@ -0,0 +1,297 @@ +----------------------------------------------------------------------------- +-- $Id: GenUtils.lhs,v 1.1 1999/11/12 11:54:17 simonmar Exp $ + +-- Some General Utilities, including sorts, etc. +-- This is realy just an extended prelude. +-- All the code below is understood to be in the public domain. +----------------------------------------------------------------------------- + +> module GenUtils ( + +> partition', tack, +> assocMaybeErr, +> arrElem, +> memoise, +> returnMaybe,handleMaybe, findJust, +> MaybeErr(..), +> maybeMap, +> joinMaybe, +> mkClosure, +> foldb, +> sortWith, +> sort, +> cjustify, +> ljustify, +> rjustify, +> space, +> copy, +> combinePairs, +> --trace, -- re-export it +> fst3, +> snd3, +> thd3 + +#if __HASKELL1__ < 3 || ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 200 ) + +> ,Cmp(..), compare, lookup, isJust + +#endif + +> ) where + +#if __HASKELL1__ >= 3 && ( !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ >= 200 ) + +> import Ix ( Ix(..) ) +> import Array ( listArray, array, (!) ) + +#define Text Show +#define ASSOC(a,b) (a , b) +#else +#define ASSOC(a,b) (a := b) +#endif + +%------------------------------------------------------------------------------ + +Here are two defs that everyone seems to define ... +HBC has it in one of its builtin modules + +#ifdef __GOFER__ + + primitive primPrint "primPrint" :: Int -> a -> ShowS + +#endif + +#ifdef __GOFER__ + + primitive primGenericEq "primGenericEq", + primGenericNe "primGenericNe", + primGenericLe "primGenericLe", + primGenericLt "primGenericLt", + primGenericGe "primGenericGe", + primGenericGt "primGenericGt" :: a -> a -> Bool + + instance Text (Maybe a) where { showsPrec = primPrint } + instance Eq (Maybe a) where + (==) = primGenericEq + (/=) = primGenericNe + + instance (Ord a) => Ord (Maybe a) + where + Nothing <= _ = True + _ <= Nothing = True + (Just a) <= (Just b) = a <= b + +#endif + +> maybeMap :: (a -> b) -> Maybe a -> Maybe b +> maybeMap f (Just a) = Just (f a) +> maybeMap f Nothing = Nothing + +> joinMaybe :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a +> joinMaybe _ Nothing Nothing = Nothing +> joinMaybe _ (Just g) Nothing = Just g +> joinMaybe _ Nothing (Just g) = Just g +> joinMaybe f (Just g) (Just h) = Just (f g h) + +> data MaybeErr a err = Succeeded a | Failed err deriving (Eq,Text) + +@mkClosure@ makes a closure, when given a comparison and iteration loop. +Be careful, because if the functional always makes the object different, +This will never terminate. + +> mkClosure :: (a -> a -> Bool) -> (a -> a) -> a -> a +> mkClosure eq f = match . iterate f +> where +> match (a:b:c) | a `eq` b = a +> match (_:c) = match c + +> foldb :: (a -> a -> a) -> [a] -> a +> foldb f [] = error "can't reduce an empty list using foldb" +> foldb f [x] = x +> foldb f l = foldb f (foldb' l) +> where +> foldb' (x:y:x':y':xs) = f (f x y) (f x' y') : foldb' xs +> foldb' (x:y:xs) = f x y : foldb' xs +> foldb' xs = xs + +Merge two ordered lists into one ordered list. + +> mergeWith :: (a -> a -> Bool) -> [a] -> [a] -> [a] +> mergeWith _ [] ys = ys +> mergeWith _ xs [] = xs +> mergeWith le (x:xs) (y:ys) +> | x `le` y = x : mergeWith le xs (y:ys) +> | otherwise = y : mergeWith le (x:xs) ys + +> insertWith :: (a -> a -> Bool) -> a -> [a] -> [a] +> insertWith _ x [] = [x] +> insertWith le x (y:ys) +> | x `le` y = x:y:ys +> | otherwise = y:insertWith le x ys + +Sorting is something almost every program needs, and this is the +quickest sorting function I know of. + +> sortWith :: (a -> a -> Bool) -> [a] -> [a] +> sortWith le [] = [] +> sortWith le lst = foldb (mergeWith le) (splitList lst) +> where +> splitList (a1:a2:a3:a4:a5:xs) = +> insertWith le a1 +> (insertWith le a2 +> (insertWith le a3 +> (insertWith le a4 [a5]))) : splitList xs +> splitList [] = [] +> splitList (r:rs) = [foldr (insertWith le) [r] rs] + +> sort :: (Ord a) => [a] -> [a] +> sort = sortWith (<=) + +> returnMaybe :: a -> Maybe a +> returnMaybe = Just + +> handleMaybe :: Maybe a -> Maybe a -> Maybe a +> handleMaybe m k = case m of +> Nothing -> k +> _ -> m + +> findJust :: (a -> Maybe b) -> [a] -> Maybe b +> findJust f = foldr handleMaybe Nothing . map f + + +Gofer-like stuff: + +> fst3 (a,_,_) = a +> snd3 (_,a,_) = a +> thd3 (_,a,_) = a + +> cjustify, ljustify, rjustify :: Int -> String -> String +> cjustify n s = space halfm ++ s ++ space (m - halfm) +> where m = n - length s +> halfm = m `div` 2 +> ljustify n s = s ++ space (n - length s) +> rjustify n s = let s' = take n s in space (n - length s') ++ s' + +> space :: Int -> String +> space n | n < 0 = "" +> | otherwise = copy n ' ' + +> copy :: Int -> a -> [a] -- make list of n copies of x +> copy n x = take n xs where xs = x:xs + +> partition' :: (Eq b) => (a -> b) -> [a] -> [[a]] +> partition' f [] = [] +> partition' f [x] = [[x]] +> partition' f (x:x':xs) | f x == f x' +> = tack x (partition' f (x':xs)) +> | otherwise +> = [x] : partition' f (x':xs) + +> tack x xss = (x : head xss) : tail xss + +> combinePairs :: (Ord a) => [(a,b)] -> [(a,[b])] +> combinePairs xs = +> combine [ (a,[b]) | (a,b) <- sortWith (\ (a,_) (b,_) -> a <= b) xs] +> where +> combine [] = [] +> combine ((a,b):(c,d):r) | a == c = combine ((a,b++d) : r) +> combine (a:r) = a : combine r +> + +#if __HASKELL1__ < 3 || ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 200 ) + +> lookup :: (Eq a) => a -> [(a,b)] -> Maybe b +> lookup k env = case [ val | (key,val) <- env, k == key] of +> [] -> Nothing +> (val:vs) -> Just val +> + +> data Cmp = LT | EQ | GT + +> compare a b | a < b = LT +> | a == b = EQ +> | otherwise = GT + +> isJust :: Maybe a -> Bool +> isJust (Just _) = True +> isJust _ = False + +#endif + +> assocMaybeErr :: (Eq a) => [(a,b)] -> a -> MaybeErr b String +> assocMaybeErr env k = case [ val | (key,val) <- env, k == key] of +> [] -> Failed "assoc: " +> (val:vs) -> Succeeded val +> + +Now some utilties involving arrays. +Here is a version of @elem@ that uses partual application +to optimise lookup. + +> arrElem :: (Ix a) => [a] -> a -> Bool +> arrElem obj = \x -> inRange size x && arr ! x +> where +> obj' = sort obj +> size = (head obj',last obj') +> arr = listArray size [ i `elem` obj | i <- range size ] + + +You can use this function to simulate memoisation. For example: + + > fib = memoise (0,100) fib' + > where + > fib' 0 = 0 + > fib' 1 = 0 + > fib' n = fib (n-1) + fib (n-2) + +will give a very efficent variation of the fib function. + + +> memoise :: (Ix a) => (a,a) -> (a -> b) -> a -> b +> memoise bds f = (!) arr +> where arr = array bds [ ASSOC(t, f t) | t <- range bds ] + +> mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list +> -- and accumulator, returning new +> -- accumulator and elt of result list +> -> acc -- Initial accumulator +> -> [x] -- Input list +> -> (acc, [y]) -- Final accumulator and result list +> +> mapAccumR f b [] = (b, []) +> mapAccumR f b (x:xs) = (b'', x':xs') where +> (b'', x') = f b' x +> (b', xs') = mapAccumR f b xs + +> mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list +> -- and accumulator, returning new +> -- accumulator and elt of result list +> -> acc -- Initial accumulator +> -> [x] -- Input list +> -> (acc, [y]) -- Final accumulator and result list +> +> mapAccumL f b [] = (b, []) +> mapAccumL f b (x:xs) = (b'', x':xs') where +> (b', x') = f b x +> (b'', xs') = mapAccumL f b' xs + +Here is the bi-directional version ... + +> mapAccumB :: (accl -> accr -> x -> (accl, accr,y)) +> -- Function of elt of input list +> -- and accumulator, returning new +> -- accumulator and elt of result list +> -> accl -- Initial accumulator from left +> -> accr -- Initial accumulator from right +> -> [x] -- Input list +> -> (accl, accr, [y]) -- Final accumulator and result list +> +> mapAccumB f a b [] = (a,b,[]) +> mapAccumB f a b (x:xs) = (a'',b'',y:ys) +> where +> (a',b'',y) = f a b' x +> (a'',b',ys) = mapAccumB f a' b xs + + +> assert False x = error "assert Failed" +> assert True x = x diff --git a/utils/nofib-analyse/Main.hs b/utils/nofib-analyse/Main.hs new file mode 100644 index 0000000000..c2b0d42ad0 --- /dev/null +++ b/utils/nofib-analyse/Main.hs @@ -0,0 +1,757 @@ +----------------------------------------------------------------------------- +-- $Id: Main.hs,v 1.10 2005/06/07 10:58:31 simonmar Exp $ + +-- (c) Simon Marlow 1997-2005 +----------------------------------------------------------------------------- + +module Main where + +import GenUtils +import Printf +import Slurp +import CmdLine + +import Text.Html hiding ((!)) +import qualified Text.Html as Html ((!)) +import Data.FiniteMap +import System.Console.GetOpt +import System.Exit ( exitWith, ExitCode(..) ) + +import Data.Maybe ( isNothing ) +import Data.Char +import System.IO +import Data.List + +(<!) = (Html.!) + +----------------------------------------------------------------------------- +-- Top level stuff + +die :: String -> IO a +die s = hPutStr stderr s >> exitWith (ExitFailure 1) + +usageHeader = "usage: nofib-analyse [OPTION...] <logfile1> <logfile2> ..." + +main = do + + if not (null cmdline_errors) || OptHelp `elem` flags + then die (concat cmdline_errors ++ usageInfo usageHeader argInfo) + else do + + let { html = OptHTMLOutput `elem` flags; + latex = OptLaTeXOutput `elem` flags; + ascii = OptASCIIOutput `elem` flags + } + + if ascii && html + then die "Can't produce both ASCII and HTML" + else do + + if devs && nodevs + then die "Can't both display and hide deviations" + else do + + results <- parse_logs other_args + + summary_spec <- case [ cols | OptColumns cols <- flags ] of + [] -> return (pickSummary results) + (cols:_) -> namedColumns (split ',' cols) + + let summary_rows = case [ rows | OptRows rows <- flags ] of + [] -> Nothing + rows -> Just (split ',' (last rows)) + + let column_headings = map (reverse . takeWhile (/= '/') . reverse) other_args + + -- sanity check + sequence_ [ checkTimes prog res | table <- results, + (prog,res) <- fmToList table ] + + case () of + _ | html -> + putStr (renderHtml (htmlPage results column_headings)) + _ | latex -> + putStr (latexOutput results column_headings summary_spec summary_rows) + _ | otherwise -> + putStr (asciiPage results column_headings summary_spec summary_rows) + + +parse_logs :: [String] -> IO [ResultTable] +parse_logs [] = do + f <- hGetContents stdin + return [parse_log f] +parse_logs log_files = + mapM (\f -> do h <- openFile f ReadMode + c <- hGetContents h + return (parse_log c)) log_files + +----------------------------------------------------------------------------- +-- List of tables we're going to generate + +data PerProgTableSpec = + forall a . Result a => + SpecP + String -- Name of the table + String -- Short name (for column heading) + String -- HTML tag for the table + (Results -> Maybe a) -- How to get the result + (Results -> Status) -- How to get the status of this result + (a -> Bool) -- Result within reasonable limits? + +data PerModuleTableSpec = + forall a . Result a => + SpecM + String -- Name of the table + String -- HTML tag for the table + (Results -> FiniteMap String a) -- get the module map + (a -> Bool) -- Result within reasonable limits? + +-- The various per-program aspects of execution that we can generate results for. +size_spec = SpecP "Binary Sizes" "Size" "binary-sizes" binary_size compile_status always_ok +alloc_spec = SpecP "Allocations" "Allocs" "allocations" allocs run_status always_ok +runtime_spec = SpecP "Run Time" "Runtime" "run-times" (mean run_time) run_status time_ok +muttime_spec = SpecP "Mutator Time" "MutTime" "mutator-time" (mean mut_time) run_status time_ok +gctime_spec = SpecP "GC Time" "GCTime" "gc-time" (mean gc_time) run_status time_ok +gcwork_spec = SpecP "GC Work" "GCWork" "gc-work" gc_work run_status always_ok +instrs_spec = SpecP "Instructions" "Instrs" "instrs" instrs run_status always_ok +mreads_spec = SpecP "Memory Reads" "Reads" "mem-reads" mem_reads run_status always_ok +mwrite_spec = SpecP "Memory Writes" "Writes" "mem-writes" mem_writes run_status always_ok +cmiss_spec = SpecP "Cache Misses" "Misses" "cache-misses" cache_misses run_status always_ok + +all_specs = [ + size_spec, + alloc_spec, + runtime_spec, + muttime_spec, + gctime_spec, + gcwork_spec, + instrs_spec, + mreads_spec, + mwrite_spec, + cmiss_spec + ] + +namedColumns :: [String] -> IO [PerProgTableSpec] +namedColumns ss = mapM findSpec ss + where findSpec s = + case [ spec | spec@(SpecP _ short_name _ _ _ _) <- all_specs, + short_name == s ] of + [] -> die ("unknown column: " ++ s) + (spec:_) -> return spec + +mean :: (Results -> [Float]) -> Results -> Maybe Float +mean f results = go (f results) + where go [] = Nothing + go fs = Just (foldl' (+) 0 fs / fromIntegral (length fs)) + +-- Look for bogus-looking times: On Linux we occasionally get timing results +-- that are bizarrely low, and skew the average. +checkTimes :: String -> Results -> IO () +checkTimes prog results = do + check "run time" (run_time results) + check "mut time" (mut_time results) + check "GC time" (gc_time results) + where + check kind ts + | any strange ts = + hPutStrLn stderr ("warning: dubious " ++ kind + ++ " results for " ++ prog + ++ ": " ++ show ts) + | otherwise = return () + where strange t = any (\r -> time_ok r && r / t > 1.4) ts + -- looks for times that are >40% smaller than + -- any other. + + +-- These are the per-prog tables we want to generate +per_prog_result_tab = + [ size_spec, alloc_spec, runtime_spec, muttime_spec, gctime_spec, + gcwork_spec, instrs_spec, mreads_spec, mwrite_spec, cmiss_spec ] + +-- A single summary table, giving comparison figures for a number of +-- aspects, each in its own column. Only works when comparing two runs. +normal_summary_specs = + [ size_spec, alloc_spec, runtime_spec ] + +cachegrind_summary_specs = + [ size_spec, alloc_spec, instrs_spec, mreads_spec, mwrite_spec ] + +-- Pick an appropriate summary table: if we're cachegrinding, then +-- we're probably not interested in the runtime, but we are interested +-- in instructions, mem reads and mem writes (and vice-versa). +pickSummary :: [ResultTable] -> [PerProgTableSpec] +pickSummary rs + | isNothing (instrs (head (eltsFM (head rs)))) = normal_summary_specs + | otherwise = cachegrind_summary_specs + +per_module_result_tab = + [ SpecM "Module Sizes" "mod-sizes" module_size always_ok + , SpecM "Compile Times" "compile-time" compile_time time_ok + ] + +always_ok :: a -> Bool +always_ok = const True + +time_ok :: Float -> Bool +time_ok t = t > tooquick_threshold + +----------------------------------------------------------------------------- +-- HTML page generation + +--htmlPage :: Results -> [String] -> Html +htmlPage results args + = header << thetitle << reportTitle + +++ hr + +++ h1 << reportTitle + +++ gen_menu + +++ hr + +++ body (gen_tables results args) + +gen_menu = unordList (map (prog_menu_item) per_prog_result_tab + ++ map (module_menu_item) per_module_result_tab) + +prog_menu_item (SpecP name _ anc _ _ _) = anchor <! [href ('#':anc)] << name +module_menu_item (SpecM name anc _ _) = anchor <! [href ('#':anc)] << name + +gen_tables results args = + foldr1 (+++) (map (htmlGenProgTable results args) per_prog_result_tab) + +++ foldr1 (+++) (map (htmlGenModTable results args) per_module_result_tab) + +htmlGenProgTable results args (SpecP title _ anc get_result get_status result_ok) + = sectHeading title anc + +++ font <! [size "1"] + << mkTable (htmlShowResults results args get_result get_status result_ok) + +++ hr + +htmlGenModTable results args (SpecM title anc get_result result_ok) + = sectHeading title anc + +++ font <![size "1"] + << mkTable (htmlShowMultiResults results args get_result result_ok) + +++ hr + +sectHeading :: String -> String -> Html +sectHeading s nm = h2 << anchor <! [name nm] << s + +htmlShowResults + :: Result a + => [ResultTable] + -> [String] + -> (Results -> Maybe a) + -> (Results -> Status) + -> (a -> Bool) + -> HtmlTable + +htmlShowResults (r:rs) ss f stat result_ok + = tabHeader ss + </> aboves (zipWith tableRow [1..] results_per_prog) + </> aboves ((if nodevs then [] + else [tableRow (-1) ("-1 s.d.", lows), + tableRow (-1) ("+1 s.d.", highs)]) + ++ [tableRow (-1) ("Average", gms)]) + where + -- results_per_prog :: [ (String,[BoxValue a]) ] + results_per_prog = map (calc_result rs f stat result_ok) (fmToList r) + + results_per_run = transpose (map snd results_per_prog) + (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run) + +htmlShowMultiResults + :: Result a + => [ResultTable] + -> [String] + -> (Results -> FiniteMap String a) + -> (a -> Bool) + -> HtmlTable + +htmlShowMultiResults (r:rs) ss f result_ok = + multiTabHeader ss + </> aboves (map show_results_for_prog results_per_prog_mod_run) + </> aboves ((if nodevs then [] + else [td << bold << "-1 s.d." + <-> tableRow (-1) ("", lows), + td << bold << "+1 s.d." + <-> tableRow (-1) ("", highs)]) + ++ [td << bold << "Average" + <-> tableRow (-1) ("", gms)]) + + where + base_results = fmToList r :: [(String,Results)] + + -- results_per_prog_mod_run :: [(String,[(String,[BoxValue a])])] + results_per_prog_mod_run = map get_results_for_prog base_results + + -- get_results_for_prog :: (String,Results) -> (String,[BoxValue a]) + get_results_for_prog (prog,r) = (prog, map get_results_for_mod (fmToList (f r))) + + where fms = map get_run_results rs + + get_run_results fm = case lookupFM fm prog of + Nothing -> emptyFM + Just res -> f res + + get_results_for_mod (id,attr) = calc_result fms Just (const Success) + result_ok (id,attr) + + show_results_for_prog (prog,mrs) = + td <! [valign "top"] << bold << prog + <-> (if null mrs then + td << "(no modules compiled)" + else + toHtml (aboves (map (tableRow 0) mrs))) + + results_per_run = transpose [xs | (_,mods) <- results_per_prog_mod_run, + (_,xs) <- mods] + (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run) + +tableRow :: Int -> (String, [BoxValue]) -> HtmlTable +tableRow row_no (prog, results) + = td <! [bgcolor left_column_color] << prog + <-> besides (map (\s -> td <! [align "right", clr] << showBox s) + results) + where clr | row_no < 0 = bgcolor average_row_color + | even row_no = bgcolor even_row_color + | otherwise = bgcolor odd_row_color + +left_column_color = "#d0d0ff" -- light blue +odd_row_color = "#d0d0ff" -- light blue +even_row_color = "#f0f0ff" -- v. light blue +average_row_color = "#ffd0d0" -- light red + +{- +findBest :: Result a => [BoxValue a] -> [(Bool,BoxValue a)] +findBest stuff@(Result base : rest) + = map (\a -> (a==base, a)) + where + best = snd (minimumBy (\a b -> fst a < fst b) no_pcnt_stuff + + no_pcnt_stuff = map unPcnt stuff + + unPcnt (r@(Percentage f) : rest) = (base * f/100, r) : unPcnt rest + unPcnt (r@(Result a) : rest) = (a, r) : unPcnt rest + unPcnt (_ : rest) = unPcnt rest +-} + +logHeaders ss + = besides (map (\s -> (td <! [align "right", width "100"] << bold << s)) ss) + +mkTable t = table <! [cellspacing 0, cellpadding 0, border 0] << t + +tabHeader ss + = (td <! [align "left", width "100"] << bold << "Program") + <-> logHeaders ss + +multiTabHeader ss + = (td <! [align "left", width "100"] << bold << "Program") + <-> (td <! [align "left", width "100"] << bold << "Module") + <-> logHeaders ss + +-- Calculate a color ranging from bright blue for -100% to bright red for +100%. + +calcColor :: Int -> String +calcColor p | p >= 0 = "#" ++ (showHex red 2 "0000") + | otherwise = "#0000" ++ (showHex blue 2 "") + where red = p * 255 `div` 100 + blue = (-p) * 255 `div` 100 + +showHex 0 f s = if f > 0 then take f (repeat '0') ++ s else s +showHex i f s = showHex (i `div` 16) (f-1) (hexDig (i `mod` 16) : s) + +hexDig i | i > 10 = chr (i-10 + ord 'a') + | otherwise = chr (i + ord '0') + +----------------------------------------------------------------------------- +-- LaTeX table generation (just the summary for now) + +latexOutput results args summary_spec summary_rows = + (if (length results == 2) + then ascii_summary_table True results summary_spec summary_rows + . str "\n\n" + else id) "" + + +----------------------------------------------------------------------------- +-- ASCII page generation + +asciiPage results args summary_spec summary_rows = + ( str reportTitle + . str "\n\n" + -- only show the summary table if we're comparing two runs + . (if (length results == 2) + then ascii_summary_table False results summary_spec summary_rows . str "\n\n" + else id) + . interleave "\n\n" (map (asciiGenProgTable results args) per_prog_result_tab) + . str "\n" + . interleave "\n\n" (map (asciiGenModTable results args) per_module_result_tab) + ) "\n" + +asciiGenProgTable results args (SpecP title _ anc get_result get_status result_ok) + = str title + . str "\n" + . ascii_show_results results args get_result get_status result_ok + +asciiGenModTable results args (SpecM title anc get_result result_ok) + = str title + . str "\n" + . ascii_show_multi_results results args get_result result_ok + +ascii_header width ss + = str "\n-------------------------------------------------------------------------------\n" + . str (rjustify 15 "Program") + . str (space 5) + . foldr (.) id (map (str . rjustify width) ss) + . str "\n-------------------------------------------------------------------------------\n" + +ascii_show_results + :: Result a + => [ResultTable] + -> [String] + -> (Results -> Maybe a) + -> (Results -> Status) + -> (a -> Bool) + -> ShowS + +ascii_show_results (r:rs) ss f stat result_ok + = ascii_header fIELD_WIDTH ss + . interleave "\n" (map show_per_prog_results results_per_prog) + . if nodevs then id + else str "\n" + . show_per_prog_results ("-1 s.d.",lows) + . str "\n" + . show_per_prog_results ("+1 s.d.",highs) + . str "\n" + . show_per_prog_results ("Average",gms) + where + -- results_per_prog :: [ (String,[BoxValue a]) ] + results_per_prog = map (calc_result rs f stat result_ok) (fmToList r) + + results_per_run = transpose (map snd results_per_prog) + (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run) + +-- A summary table, useful only when we are comparing two runs. This table +-- shows a number of different result categories, one per column. +ascii_summary_table + :: Bool -- generate a LaTeX table? + -> [ResultTable] + -> [PerProgTableSpec] + -> Maybe [String] + -> ShowS +ascii_summary_table latex (r1:r2:_) specs mb_restrict + | latex = makeLatexTable (rows ++ TableLine : av_rows) + | otherwise = + makeTable (table_layout (length specs) width) + (TableLine : TableRow header : TableLine : rows ++ TableLine : av_rows) + where + header = BoxString "Program" : map BoxString headings + + (headings, columns, av_cols) = unzip3 (map calc_col specs) + av_heads = [BoxString "Min", BoxString "Max", BoxString "Geometric Mean"] + baseline = fmToList r1 + progs = map BoxString (keysFM r1) + rows0 = map TableRow (zipWith (:) progs (transpose columns)) + + rows1 = restrictRows mb_restrict rows0 + + rows | latex = mungeForLaTeX rows1 + | otherwise = rows1 + + av_rows = map TableRow (zipWith (:) av_heads (transpose av_cols)) + width = 10 + + calc_col (SpecP _ heading _ getr gets ok) + = (heading, column, [min,max,mean]) -- throw away the baseline result + where (_, boxes) = unzip (map calc_one_result baseline) + calc_one_result = calc_result [r2] getr gets ok + column = map (\(_:b:_) -> b) boxes + (_,mean,_) = calc_gmsd column + (min,max) = calc_minmax column + +restrictRows :: Maybe [String] -> [TableRow] -> [TableRow] +restrictRows Nothing rows = rows +restrictRows (Just these) rows = filter keep_it rows + where keep_it (TableRow (BoxString s: _)) = s `elem` these + keep_it TableLine = True + keep_it _ = False + +mungeForLaTeX :: [TableRow] -> [TableRow] +mungeForLaTeX = map transrow + where + transrow (TableRow boxes) = TableRow (map transbox boxes) + transrow row = row + + transbox (BoxString s) = BoxString (foldr transchar "" s) + transbox box = box + + transchar '_' s = '\\':'_':s + transchar c s = c:s + +table_layout n width = + (str . rjustify 15) : + (\s -> str (space 5) . str (rjustify width s)) : + replicate (n-1) (str . rjustify width) + +ascii_show_multi_results + :: Result a + => [ResultTable] + -> [String] + -> (Results -> FiniteMap String a) + -> (a -> Bool) + -> ShowS + +ascii_show_multi_results (r:rs) ss f result_ok + = ascii_header fIELD_WIDTH ss + . interleave "\n" (map show_results_for_prog results_per_prog_mod_run) + . str "\n" + . if nodevs then id + else str "\n" + . show_per_prog_results ("-1 s.d.",lows) + . str "\n" + . show_per_prog_results ("+1 s.d.",highs) + . str "\n" + . show_per_prog_results ("Average",gms) + where + base_results = fmToList r :: [(String,Results)] + + -- results_per_prog_mod_run :: [(String,[(String,[BoxValue a])])] + results_per_prog_mod_run = map get_results_for_prog base_results + + -- get_results_for_prog :: (String,Results) -> (String,[BoxValue a]) + get_results_for_prog (prog,r) = (prog, map get_results_for_mod (fmToList (f r))) + + where fms = map get_run_results rs + + get_run_results fm = case lookupFM fm prog of + Nothing -> emptyFM + Just res -> f res + + get_results_for_mod (id,attr) = calc_result fms Just (const Success) + result_ok (id,attr) + + show_results_for_prog (prog,mrs) = + str ("\n"++prog++"\n") + . (if null mrs then + str "(no modules compiled)\n" + else + interleave "\n" (map show_per_prog_results mrs)) + + results_per_run = transpose [xs | (_,mods) <- results_per_prog_mod_run, + (_,xs) <- mods] + (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run) + + +show_per_prog_results :: (String, [BoxValue]) -> ShowS +show_per_prog_results = show_per_prog_results_width fIELD_WIDTH + +show_per_prog_results_width width (prog,results) + = str (rjustify 15 prog) + . str (space 5) + . foldr (.) id (map (str . rjustify width . showBox) results) + +-- --------------------------------------------------------------------------- +-- Generic stuff for results generation + +-- calc_result is a nice exercise in higher-order programming... +calc_result + :: Result a + => [FiniteMap String b] -- accumulated results + -> (b -> Maybe a) -- get a result from the b + -> (b -> Status) -- get a status from the b + -> (a -> Bool) -- is this result ok? + -> (String,b) -- the baseline result + -> (String,[BoxValue]) + +calc_result rts get_maybe_a get_stat result_ok (prog,base_r) = + (prog, (just_result baseline base_stat : + + let + rts' = map (\rt -> get_stuff (lookupFM rt prog)) rts + + get_stuff Nothing = (Nothing, NotDone) + get_stuff (Just r) = (get_maybe_a r, get_stat r) + in + ( + case baseline of + Just base | result_ok base + -> map (\(r,s) -> percentage r s base) rts' + _other + -> map (\(r,s) -> just_result r s) rts' + ))) + where + baseline = get_maybe_a base_r + base_stat = get_stat base_r + + just_result Nothing s = RunFailed s + just_result (Just a) s = toBox a + + percentage Nothing s base = RunFailed s + percentage (Just a) s base = Percentage + (convert_to_percentage base a) +----------------------------------------------------------------------------- +-- Calculating geometric means and standard deviations + +{- +This is done using the log method, to avoid needing really large +intermediate results. The formula for a geometric mean is + + (a1 * .... * an) ^ 1/n + +which is equivalent to + + e ^ ( (log a1 + ... + log an) / n ) + +where log is the natural logarithm function. + +Similarly, to compute the geometric standard deviation we compute the +deviation of each log, take the root-mean-square, and take the +exponential again: + + e ^ sqrt( ( sqr(log a1 - lbar) + ... + sqr(log an - lbar) ) / n ) + +where lbar is the mean log, + + (log a1 + ... + log an) / n + +This is a *factor*: i.e., the 1 s.d. points are (gm/sdf,gm*sdf); do +not subtract 100 from gm before performing this calculation. + +We therefore return a (low, mean, high) triple. + +-} + +calc_gmsd :: [BoxValue] -> (BoxValue, BoxValue, BoxValue) +calc_gmsd xs + | null percentages = (RunFailed NotDone, RunFailed NotDone, RunFailed NotDone) + | otherwise = let sqr x = x * x + len = fromIntegral (length percentages) + logs = map log percentages + lbar = sum logs / len + devs = map (sqr . (lbar-)) logs + dbar = sum devs / len + gm = exp lbar + sdf = exp (sqrt dbar) + in + (Percentage (gm/sdf), + Percentage gm, + Percentage (gm*sdf)) + where + percentages = [ if f < 5 then 5 else f | Percentage f <- xs ] + -- can't do log(0.0), so exclude zeros + -- small values have inordinate effects so cap at -95%. + +calc_minmax :: [BoxValue] -> (BoxValue, BoxValue) +calc_minmax xs + | null percentages = (RunFailed NotDone, RunFailed NotDone) + | otherwise = (Percentage (minimum percentages), + Percentage (maximum percentages)) + where + percentages = [ if f < 5 then 5 else f | Percentage f <- xs ] + + +----------------------------------------------------------------------------- +-- Show the Results + +class Num a => Result a where + toBox :: a -> BoxValue + convert_to_percentage :: a -> a -> Float + +-- We assume an Int is a size, and print it in kilobytes. + +instance Result Int where + convert_to_percentage 0 size = 100 + convert_to_percentage base size = (fromIntegral size / fromIntegral base) * 100 + + toBox = BoxInt + +instance Result Integer where + convert_to_percentage 0 size = 100 + convert_to_percentage base size = (fromInteger size / fromInteger base) * 100 + toBox = BoxInteger + + +instance Result Float where + convert_to_percentage 0.0 size = 100.0 + convert_to_percentage base size = size / base * 100 + + toBox = BoxFloat + +-- ----------------------------------------------------------------------------- +-- BoxValues + +-- The contents of a box in a table +data BoxValue + = RunFailed Status + | Percentage Float + | BoxFloat Float + | BoxInt Int + | BoxInteger Integer + | BoxString String + +showBox :: BoxValue -> String +showBox (RunFailed stat) = show_stat stat +showBox (Percentage f) = show_pcntage f +showBox (BoxFloat f) = showFloat' Nothing (Just 2) f +showBox (BoxInt n) = show (n `div` 1024) ++ "k" +showBox (BoxInteger n) = show (n `div` 1024) ++ "k" +showBox (BoxString s) = s + +instance Show BoxValue where { show = showBox } + +show_pcntage n = show_float_signed (n-100) ++ "%" + +show_float_signed = showFloat False False True False False Nothing (Just 1) + +show_stat Success = "(no result)" +show_stat WrongStdout = "(stdout)" +show_stat WrongStderr = "(stderr)" +show_stat (Exit x) = "exit(" ++ show x ++")" +show_stat OutOfHeap = "(heap)" +show_stat OutOfStack = "(stack)" +show_stat NotDone = "-----" + +-- ----------------------------------------------------------------------------- +-- Table layout + +data TableRow + = TableRow [BoxValue] + | TableLine + +type Layout = [String -> ShowS] + +makeTable :: Layout -> [TableRow] -> ShowS +makeTable p = interleave "\n" . map do_row + where do_row (TableRow boxes) = applyLayout p boxes + do_row TableLine = str (take 80 (repeat '-')) + +makeLatexTable :: [TableRow] -> ShowS +makeLatexTable = foldr (.) id . map do_row + where do_row (TableRow boxes) + = applyLayout latexTableLayout boxes . str "\\\\\n" + do_row TableLine + = str "\\hline\n" + +latexTableLayout :: Layout +latexTableLayout = box : repeat (box . (" & "++)) + where box s = str (foldr transchar "" s) + + transchar '%' s = s -- leave out the percentage signs + transchar c s = c : s + +applyLayout :: Layout -> [BoxValue] -> ShowS +applyLayout layout values = + foldr (.) id [ f (show val) | (val,f) <- zip values layout ] + +-- ----------------------------------------------------------------------------- +-- General Utils + +split :: Char -> String -> [String] +split c s = case rest of + [] -> [chunk] + _:rest -> chunk : split c rest + where (chunk, rest) = break (==c) s + +str = showString + +interleave s = foldr1 (\a b -> a . str s . b) + +fIELD_WIDTH = 16 :: Int + +----------------------------------------------------------------------------- diff --git a/utils/nofib-analyse/Makefile b/utils/nofib-analyse/Makefile new file mode 100644 index 0000000000..155b8df978 --- /dev/null +++ b/utils/nofib-analyse/Makefile @@ -0,0 +1,7 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk + +SRC_HC_OPTS += -fglasgow-exts -package util -package data -package text -cpp -package lang +HS_PROG = nofib-analyse + +include $(TOP)/mk/target.mk diff --git a/utils/nofib-analyse/Printf.lhs b/utils/nofib-analyse/Printf.lhs new file mode 100644 index 0000000000..33b5290e07 --- /dev/null +++ b/utils/nofib-analyse/Printf.lhs @@ -0,0 +1,84 @@ +----------------------------------------------------------------------------- +-- $Id: Printf.lhs,v 1.5 2002/03/14 17:09:46 simonmar Exp $ + +-- (c) Simon Marlow 1997-2001 +----------------------------------------------------------------------------- + +> module Printf (showFloat, showFloat') where + +> import Foreign +> import CTypes +> import CTypesISO +> import CString +> import IOExts +> import ByteArray + +> showFloat +> :: Bool -- Always print decimal point +> -> Bool -- Left adjustment +> -> Bool -- Always print sign +> -> Bool -- Leave blank before positive number +> -> Bool -- Use zero padding +> -> Maybe Int -- Field Width +> -> Maybe Int -- Precision +> -> Float +> -> String + +> bUFSIZE = 512 :: Int + +> showFloat alt left sign blank zero width prec num = +> unsafePerformIO $ do + +#if __GLASGOW_HASKELL__ < 500 + +> buf <- malloc bUFSIZE +> snprintf buf (fromIntegral bUFSIZE) (packString format) +> (realToFrac num) +> let s = unpackCString buf +> length s `seq` -- urk! need to force the string before we +> -- free the buffer. A better solution would +> -- be to use foreign objects and finalisers, +> -- but that's just too heavyweight. +> free buf +> return s + +#else + +> allocaBytes bUFSIZE $ \buf -> +> withCString format $ \cformat -> do +> snprintf buf (fromIntegral bUFSIZE) cformat +> (realToFrac num) +> peekCString buf + +#endif + +> where +> format = '%' : +> if_bool alt "#" ++ +> if_bool left "-" ++ +> if_bool sign "+" ++ +> if_bool blank " " ++ +> if_bool zero "0" ++ +> if_maybe width show ++ +> if_maybe prec (\s -> "." ++ show s) ++ +> "f" + +> showFloat' :: Maybe Int -> Maybe Int -> Float -> String +> showFloat' = showFloat False False False False False + +> if_bool False s = [] +> if_bool True s = s + +> if_maybe Nothing f = [] +> if_maybe (Just s) f = f s + +#if __GLASGOW_HASKELL__ < 500 + +> type PackedString = ByteArray Int +> foreign import unsafe snprintf :: Addr -> CSize -> PackedString -> Double -> IO () + +#else + +> foreign import unsafe snprintf :: CString -> CSize -> CString -> Double -> IO () + +#endif diff --git a/utils/nofib-analyse/Slurp.hs b/utils/nofib-analyse/Slurp.hs new file mode 100644 index 0000000000..f775baee4f --- /dev/null +++ b/utils/nofib-analyse/Slurp.hs @@ -0,0 +1,373 @@ +----------------------------------------------------------------------------- +-- +-- (c) Simon Marlow 1997-2005 +-- +----------------------------------------------------------------------------- + +module Slurp (Status(..), Results(..), ResultTable(..), parse_log) where + +import CmdLine +import Data.FiniteMap +import RegexString +import Data.Maybe +-- import Debug.Trace + +----------------------------------------------------------------------------- +-- This is the structure into which we collect our results: + +type ResultTable = FiniteMap String Results + +data Status + = NotDone + | Success + | OutOfHeap + | OutOfStack + | Exit Int + | WrongStdout + | WrongStderr + +data Results = Results { + compile_time :: FiniteMap String Float, + module_size :: FiniteMap String Int, + binary_size :: Maybe Int, + link_time :: Maybe Float, + run_time :: [Float], + mut_time :: [Float], + instrs :: Maybe Integer, + mem_reads :: Maybe Integer, + mem_writes :: Maybe Integer, + cache_misses :: Maybe Integer, + gc_work :: Maybe Integer, + gc_time :: [Float], + allocs :: Maybe Integer, + run_status :: Status, + compile_status :: Status + } + +emptyResults = Results { + compile_time = emptyFM, + module_size = emptyFM, + binary_size = Nothing, + link_time = Nothing, + run_time = [], + mut_time = [], + instrs = Nothing, + mem_reads = Nothing, + mem_writes = Nothing, + cache_misses = Nothing, + gc_time = [], + gc_work = Nothing, + allocs = Nothing, + compile_status = NotDone, + run_status = NotDone + } + +----------------------------------------------------------------------------- +-- Parse the log file + +{- +Various banner lines: + +==nofib== awards: size of QSort.o follows... +==nofib== banner: size of banner follows... +==nofib== awards: time to link awards follows... +==nofib== awards: time to run awards follows... +==nofib== boyer2: time to compile Checker follows... +-} + +banner_re = mkRegex "^==nofib==[ \t]+([A-Za-z0-9-_]+):[ \t]+(size of|time to link|time to run|time to compile)[ \t]+([A-Za-z0-9-_]+)(\\.o)?[ \t]+follows" + +{- +This regexp for the output of "time" works on FreeBSD, other versions +of "time" will need different regexps. +-} + +time_re = mkRegex "^[ \t]*([0-9.]+)[ \t]+real[ \t]+([0-9.]+)[ \t]+user[ \t]+([0-9.]+)[ \t]+sys[ \t]*$" + +time_gnu17_re = mkRegex "^[ \t]*([0-9.]+)user[ \t]+([0-9.]+)system[ \t]+([0-9.:]+)elapsed" + -- /usr/bin/time --version reports: GNU time 1.7 + -- notice the order is different, and the elapsed time is [hh:]mm:ss.s + +size_re = mkRegex "^[ \t]*([0-9]+)[ \t]+([0-9]+)[ \t]+([0-9]+)" + +{- +<<ghc: 5820820 bytes, 0 GCs, 0/0 avg/max bytes residency (0 samples), 41087234 bytes GC work, 0.00 INIT (0.05 elapsed), 0.08 MUT (0.18 elapsed), 0.00 GC (0.00 elapsed) :ghc>> + + = (bytes, gcs, avg_resid, max_resid, samples, gc_work, + init, init_elapsed, mut, mut_elapsed, gc, gc_elapsed) + +ghc1_re = pre GHC 4.02 +ghc2_re = GHC 4.02 (includes "xxM in use") +ghc3_re = GHC 4.03 (includes "xxxx bytes GC work") +-} + +ghc1_re = mkRegex "^<<ghc:[ \t]+([0-9]+)[ \t]+bytes,[ \t]*([0-9]+)[ \t]+GCs,[ \t]*([0-9]+)/([0-9]+)[ \t]+avg/max bytes residency \\(([0-9]+) samples\\), ([0-9]+) bytes GC work, ([0-9.]+) INIT \\(([0-9.]+) elapsed\\), ([0-9.]+) MUT \\(([0-9.]+) elapsed\\), ([0-9.]+) GC \\(([0-9.]+) elapsed\\) :ghc>>" + +ghc2_re = mkRegex "^<<ghc:[ \t]+([0-9]+)[ \t]+bytes,[ \t]*([0-9]+)[ \t]+GCs,[ \t]*([0-9]+)/([0-9]+)[ \t]+avg/max bytes residency \\(([0-9]+) samples\\), ([0-9]+)M in use, ([0-9.]+) INIT \\(([0-9.]+) elapsed\\), ([0-9.]+) MUT \\(([0-9.]+) elapsed\\), ([0-9.]+) GC \\(([0-9.]+) elapsed\\) :ghc>>" + +ghc3_re = mkRegex "^<<ghc:[ \t]+([0-9]+)[ \t]+bytes,[ \t]*([0-9]+)[ \t]+GCs,[ \t]*([0-9]+)/([0-9]+)[ \t]+avg/max bytes residency \\(([0-9]+) samples\\), ([0-9]+) bytes GC work, ([0-9]+)M in use, ([0-9.]+) INIT \\(([0-9.]+) elapsed\\), ([0-9.]+) MUT \\(([0-9.]+) elapsed\\), ([0-9.]+) GC \\(([0-9.]+) elapsed\\) :ghc>>" + +ghc4_re = mkRegex "^<<ghc-instrs:[ \t]+([0-9]+)[ \t]+bytes,[ \t]*([0-9]+)[ \t]+GCs,[ \t]*([0-9]+)/([0-9]+)[ \t]+avg/max bytes residency \\(([0-9]+) samples\\), ([0-9]+) bytes GC work, ([0-9]+)M in use, ([0-9.]+) INIT \\(([0-9.]+) elapsed\\), ([0-9.]+) MUT \\(([0-9.]+) elapsed\\), ([0-9.]+) GC \\(([0-9.]+) elapsed\\), ([0-9]+) instructions, ([0-9]+) memory reads, ([0-9]+) memory writes, ([0-9]+) L2 cache misses :ghc-instrs>>" + +wrong_exit_status = mkRegex "^\\**[ \t]*expected exit status ([0-9]+) not seen ; got ([0-9]+)" + +wrong_output = mkRegex "^expected (stdout|stderr) not matched by reality$" + +out_of_heap = mkRegex "^\\+ Heap exhausted;$" + +out_of_stack = mkRegex "^\\+ Stack space overflow:" + +parse_log :: String -> ResultTable +parse_log + = combine_results -- collate information + . concat + . map process_chunk -- get information from each chunk + . tail -- first chunk is junk + . chunk_log [] [] -- break at banner lines + . lines + +combine_results :: [(String,Results)] -> FiniteMap String Results +combine_results = foldr f emptyFM + where + f (prog,results) fm = addToFM_C combine2Results fm prog results + + +combine2Results + Results{ compile_time = ct1, link_time = lt1, + module_size = ms1, + run_time = rt1, mut_time = mt1, + instrs = is1, mem_reads = mr1, mem_writes = mw1, + cache_misses = cm1, + gc_time = gt1, gc_work = gw1, + binary_size = bs1, allocs = al1, + run_status = rs1, compile_status = cs1 } + Results{ compile_time = ct2, link_time = lt2, + module_size = ms2, + run_time = rt2, mut_time = mt2, + instrs = is2, mem_reads = mr2, mem_writes = mw2, + cache_misses = cm2, + gc_time = gt2, gc_work = gw2, + binary_size = bs2, allocs = al2, + run_status = rs2, compile_status = cs2 } + = Results{ compile_time = plusFM_C const ct1 ct2, + module_size = plusFM_C const ms1 ms2, + link_time = combMaybes lt1 lt2, + run_time = rt1 ++ rt2, + mut_time = mt1 ++ mt2, + instrs = combMaybes is1 is2, + mem_reads = combMaybes mr1 mr2, + mem_writes = combMaybes mw1 mw2, + cache_misses = combMaybes cm1 cm2, + gc_time = gt1 ++ gt2, + gc_work = combMaybes gw1 gw2, + binary_size = combMaybes bs1 bs2, + allocs = combMaybes al1 al2, + run_status = combStatus rs1 rs2, + compile_status = combStatus cs1 cs2 } + +combMaybes m1 m2 = case maybeToList m1 ++ maybeToList m2 of + [] -> Nothing + (x:_) -> Just x + +combStatus NotDone x = x +combStatus x NotDone = x +combStatus x y = x + +chunk_log :: [String] -> [String] -> [String] -> [([String],[String])] +chunk_log header chunk [] = [(header,chunk)] +chunk_log header chunk (l:ls) = + case matchRegex banner_re l of + Nothing -> chunk_log header (l:chunk) ls + Just stuff -> (header,chunk) : chunk_log stuff [] ls + +process_chunk :: ([String],[String]) -> [(String,Results)] +process_chunk (prog : what : mod : _, chk) = + case what of + "time to compile" -> parse_compile_time prog mod chk + "time to run" -> parse_run_time prog (reverse chk) emptyResults NotDone + "time to link" -> parse_link_time prog chk + "size of" -> parse_size prog mod chk + _ -> error ("process_chunk: "++what) + +parse_compile_time prog mod [] = [] +parse_compile_time prog mod (l:ls) = + case matchRegex time_re l of { + Just (real:user:system:_) -> + let ct = addToFM emptyFM mod (read user) + in + [(prog,emptyResults{compile_time = ct})]; + Nothing -> + + case matchRegex time_gnu17_re l of { + Just (user:system:elapsed:_) -> + let ct = addToFM emptyFM mod (read user) + in + [(prog,emptyResults{compile_time = ct})]; + Nothing -> + + case matchRegex ghc1_re l of { + Just (allocs:_:_:_:_:init:_:mut:_:gc:_) -> + let + read_mut = read mut + read_gc = read gc + time = (read init + read_mut + read_gc) :: Float + ct = addToFM emptyFM mod time + in + [(prog,emptyResults{compile_time = ct})]; + Nothing -> + + case matchRegex ghc2_re l of { + Just (allocs:_:_:_:_:_:init:_:mut:_:gc:_) -> + let + read_mut = read mut + read_gc = read gc + time = (read init + read_mut + read_gc) :: Float + ct = addToFM emptyFM mod time + in + [(prog,emptyResults{compile_time = ct})]; + Nothing -> + + case matchRegex ghc3_re l of { + Just (allocs:_:_:_:_:_:_:init:_:mut:_:gc:_) -> + let + read_mut = read mut + read_gc = read gc + time = (read init + read_mut + read_gc) :: Float + ct = addToFM emptyFM mod time + in + [(prog,emptyResults{compile_time = ct})]; + Nothing -> + + case matchRegex ghc4_re l of { + Just (allocs:_:_:_:_:_:_:init:_:mut:_:gc:_:_:_:_) -> + let + read_mut = read mut + read_gc = read gc + time = (read init + read_mut + read_gc) :: Float + ct = addToFM emptyFM mod time + in + [(prog,emptyResults{compile_time = ct})]; + Nothing -> + + parse_compile_time prog mod ls + }}}}}} + +parse_link_time prog [] = [] +parse_link_time prog (l:ls) = + case matchRegex time_re l of { + Just (real:user:system:_) -> + [(prog,emptyResults{link_time = Just (read user)})]; + Nothing -> + + case matchRegex time_gnu17_re l of { + Just (user:system:elapsed:_) -> + [(prog,emptyResults{link_time = Just (read user)})]; + Nothing -> + + parse_link_time prog ls + }} + + +-- There might be multiple runs of the program, so we have to collect up +-- all the results. Variable results like runtimes are aggregated into +-- a list, whereas the non-variable aspects are just kept singly. +parse_run_time prog [] res NotDone = [] +parse_run_time prog [] res ex = [(prog, res{run_status=ex})] +parse_run_time prog (l:ls) res ex = + case matchRegex ghc1_re l of { + Just (allocs:_:_:_:_:init:_:mut:_:gc:_) -> + got_run_result allocs init mut gc Nothing + Nothing Nothing Nothing Nothing; + Nothing -> + + case matchRegex ghc2_re l of { + Just (allocs:_:_:_:_:_:init:_:mut:_:gc:_) -> + got_run_result allocs init mut gc Nothing + Nothing Nothing Nothing Nothing; + + Nothing -> + + case matchRegex ghc3_re l of { + Just (allocs:_:_:_:_:gc_work:_:init:_:mut:_:gc:_) -> + got_run_result allocs init mut gc (Just (read gc_work)) + Nothing Nothing Nothing Nothing; + + Nothing -> + + case matchRegex ghc4_re l of { + Just (allocs:_:_:_:_:gc_work:_:init:_:mut:_:gc:_:is:mem_rs:mem_ws:cache_misses:_) -> + got_run_result allocs init mut gc (Just (read gc_work)) + (Just (read is)) (Just (read mem_rs)) + (Just (read mem_ws)) (Just (read cache_misses)); + + Nothing -> + + case matchRegex wrong_output l of { + Just ("stdout":_) -> + parse_run_time prog ls res (combineRunResult WrongStdout ex); + Just ("stderr":_) -> + parse_run_time prog ls res (combineRunResult WrongStderr ex); + Nothing -> + + case matchRegex wrong_exit_status l of { + Just (wanted:got:_) -> + parse_run_time prog ls res (combineRunResult (Exit (read got)) ex); + Nothing -> + + case matchRegex out_of_heap l of { + Just _ -> + parse_run_time prog ls res (combineRunResult OutOfHeap ex); + Nothing -> + + case matchRegex out_of_stack l of { + Just _ -> + parse_run_time prog ls res (combineRunResult OutOfStack ex); + Nothing -> + parse_run_time prog ls res ex; + + }}}}}}}} + where + got_run_result allocs init mut gc gc_work instrs mem_rs mem_ws cache_misses + = -- trace ("got_run_result: " ++ init ++ ", " ++ mut ++ ", " ++ gc) $ + let + read_mut = read mut + read_gc = read gc + time = (read init + read_mut + read_gc) :: Float + res' = combine2Results res + emptyResults{ run_time = [time], + mut_time = [read_mut], + gc_time = [read_gc], + gc_work = gc_work, + allocs = Just (read allocs), + instrs = instrs, + mem_reads = mem_rs, + mem_writes = mem_ws, + cache_misses = cache_misses, + run_status = Success + } + in + parse_run_time prog ls res' Success + + +combineRunResult OutOfHeap _ = OutOfHeap +combineRunResult _ OutOfHeap = OutOfHeap +combineRunResult OutOfStack _ = OutOfStack +combineRunResult _ OutOfStack = OutOfStack +combineRunResult (Exit e) _ = Exit e +combineRunResult _ (Exit e) = Exit e +combineRunResult exit _ = exit + +parse_size prog mod [] = [] +parse_size prog mod (l:ls) = + case matchRegex size_re l of + Nothing -> parse_size prog mod ls + Just (text:datas:bss:_) + | prog == mod -> + [(prog,emptyResults{binary_size = + Just (read text + read datas), + compile_status = Success})] + | otherwise -> + let ms = addToFM emptyFM mod (read text + read datas) + in + [(prog,emptyResults{module_size = ms})] + diff --git a/utils/parallel/AVG.pl b/utils/parallel/AVG.pl new file mode 100644 index 0000000000..9ec42aee2f --- /dev/null +++ b/utils/parallel/AVG.pl @@ -0,0 +1,108 @@ +#!/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/utils/parallel/GrAnSim.el b/utils/parallel/GrAnSim.el new file mode 100644 index 0000000000..49330a9749 --- /dev/null +++ b/utils/parallel/GrAnSim.el @@ -0,0 +1,432 @@ +;; --------------------------------------------------------------------------- +;; 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/utils/parallel/Makefile b/utils/parallel/Makefile new file mode 100644 index 0000000000..094c5cbba1 --- /dev/null +++ b/utils/parallel/Makefile @@ -0,0 +1,49 @@ +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/utils/parallel/RTS2gran.pl b/utils/parallel/RTS2gran.pl new file mode 100644 index 0000000000..32012afac8 --- /dev/null +++ b/utils/parallel/RTS2gran.pl @@ -0,0 +1,684 @@ +#!/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/utils/parallel/SN.pl b/utils/parallel/SN.pl new file mode 100644 index 0000000000..bc33e2a60c --- /dev/null +++ b/utils/parallel/SN.pl @@ -0,0 +1,280 @@ +#!/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/utils/parallel/SPLIT.pl b/utils/parallel/SPLIT.pl new file mode 100644 index 0000000000..b4fe46f5b0 --- /dev/null +++ b/utils/parallel/SPLIT.pl @@ -0,0 +1,379 @@ +#!/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/utils/parallel/avg-RTS.pl b/utils/parallel/avg-RTS.pl new file mode 100644 index 0000000000..4f25d55f80 --- /dev/null +++ b/utils/parallel/avg-RTS.pl @@ -0,0 +1,15 @@ +#!/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/utils/parallel/get_SN.pl b/utils/parallel/get_SN.pl new file mode 100644 index 0000000000..e9426855bf --- /dev/null +++ b/utils/parallel/get_SN.pl @@ -0,0 +1,40 @@ +#!/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/utils/parallel/ghc-fool-sort.pl b/utils/parallel/ghc-fool-sort.pl new file mode 100644 index 0000000000..dfa65a1875 --- /dev/null +++ b/utils/parallel/ghc-fool-sort.pl @@ -0,0 +1,23 @@ +############################################################################## +# +# 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/utils/parallel/ghc-unfool-sort.pl b/utils/parallel/ghc-unfool-sort.pl new file mode 100644 index 0000000000..90da222a5a --- /dev/null +++ b/utils/parallel/ghc-unfool-sort.pl @@ -0,0 +1,16 @@ +############################################################################## +# +# 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/utils/parallel/gp-ext-imp.pl b/utils/parallel/gp-ext-imp.pl new file mode 100644 index 0000000000..fa7c4e06d8 --- /dev/null +++ b/utils/parallel/gp-ext-imp.pl @@ -0,0 +1,86 @@ +#!/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/utils/parallel/gr2RTS.pl b/utils/parallel/gr2RTS.pl new file mode 100644 index 0000000000..c609334c28 --- /dev/null +++ b/utils/parallel/gr2RTS.pl @@ -0,0 +1,138 @@ +#!/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/utils/parallel/gr2ap.bash b/utils/parallel/gr2ap.bash new file mode 100644 index 0000000000..7818fe112b --- /dev/null +++ b/utils/parallel/gr2ap.bash @@ -0,0 +1,124 @@ +#!/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/utils/parallel/gr2gran.bash b/utils/parallel/gr2gran.bash new file mode 100644 index 0000000000..d281d2c5bc --- /dev/null +++ b/utils/parallel/gr2gran.bash @@ -0,0 +1,113 @@ +#!/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/utils/parallel/gr2java.pl b/utils/parallel/gr2java.pl new file mode 100644 index 0000000000..acd0b5e631 --- /dev/null +++ b/utils/parallel/gr2java.pl @@ -0,0 +1,322 @@ +#!/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/utils/parallel/gr2jv.bash b/utils/parallel/gr2jv.bash new file mode 100644 index 0000000000..7eeacfe556 --- /dev/null +++ b/utils/parallel/gr2jv.bash @@ -0,0 +1,123 @@ +#!/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/utils/parallel/gr2pe.pl b/utils/parallel/gr2pe.pl new file mode 100644 index 0000000000..6026300758 --- /dev/null +++ b/utils/parallel/gr2pe.pl @@ -0,0 +1,1434 @@ +#!/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/utils/parallel/gr2ps.bash b/utils/parallel/gr2ps.bash new file mode 100644 index 0000000000..4d4d3da3e6 --- /dev/null +++ b/utils/parallel/gr2ps.bash @@ -0,0 +1,169 @@ +#!/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/utils/parallel/gr2qp.pl b/utils/parallel/gr2qp.pl new file mode 100644 index 0000000000..e87f21b1e4 --- /dev/null +++ b/utils/parallel/gr2qp.pl @@ -0,0 +1,329 @@ +#!/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/utils/parallel/gran-extr.pl b/utils/parallel/gran-extr.pl new file mode 100644 index 0000000000..509da499d6 --- /dev/null +++ b/utils/parallel/gran-extr.pl @@ -0,0 +1,2114 @@ +#!/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/utils/parallel/grs2gr.pl b/utils/parallel/grs2gr.pl new file mode 100644 index 0000000000..ab398a53d9 --- /dev/null +++ b/utils/parallel/grs2gr.pl @@ -0,0 +1,48 @@ +#!/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/utils/parallel/par-aux.pl b/utils/parallel/par-aux.pl new file mode 100644 index 0000000000..8484057aab --- /dev/null +++ b/utils/parallel/par-aux.pl @@ -0,0 +1,89 @@ +#!/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/utils/parallel/ps-scale-y.pl b/utils/parallel/ps-scale-y.pl new file mode 100644 index 0000000000..0e1242081c --- /dev/null +++ b/utils/parallel/ps-scale-y.pl @@ -0,0 +1,188 @@ +#!/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/utils/parallel/qp2ap.pl b/utils/parallel/qp2ap.pl new file mode 100644 index 0000000000..b3c3bcf122 --- /dev/null +++ b/utils/parallel/qp2ap.pl @@ -0,0 +1,495 @@ +#! /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/utils/parallel/qp2ps.pl b/utils/parallel/qp2ps.pl new file mode 100644 index 0000000000..2fb090346a --- /dev/null +++ b/utils/parallel/qp2ps.pl @@ -0,0 +1,988 @@ +#! /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/utils/parallel/sn_filter.pl b/utils/parallel/sn_filter.pl new file mode 100644 index 0000000000..4bfc2d1721 --- /dev/null +++ b/utils/parallel/sn_filter.pl @@ -0,0 +1,92 @@ +#!/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/utils/parallel/stats.pl b/utils/parallel/stats.pl new file mode 100644 index 0000000000..6cf826b5cd --- /dev/null +++ b/utils/parallel/stats.pl @@ -0,0 +1,168 @@ +#!/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/utils/parallel/template.pl b/utils/parallel/template.pl new file mode 100644 index 0000000000..7fbe4cf797 --- /dev/null +++ b/utils/parallel/template.pl @@ -0,0 +1,141 @@ +#!/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/utils/parallel/tf.pl b/utils/parallel/tf.pl new file mode 100644 index 0000000000..40cff09f2c --- /dev/null +++ b/utils/parallel/tf.pl @@ -0,0 +1,148 @@ +#!/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/utils/prof/Makefile b/utils/prof/Makefile new file mode 100644 index 0000000000..994d8c83f5 --- /dev/null +++ b/utils/prof/Makefile @@ -0,0 +1,40 @@ +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/utils/prof/cgprof/Makefile b/utils/prof/cgprof/Makefile new file mode 100644 index 0000000000..17c567537a --- /dev/null +++ b/utils/prof/cgprof/Makefile @@ -0,0 +1,9 @@ +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/utils/prof/cgprof/README b/utils/prof/cgprof/README new file mode 100644 index 0000000000..2c4ca16bc9 --- /dev/null +++ b/utils/prof/cgprof/README @@ -0,0 +1,7 @@ + +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/utils/prof/cgprof/cgprof.c b/utils/prof/cgprof/cgprof.c new file mode 100644 index 0000000000..8ee66e1f52 --- /dev/null +++ b/utils/prof/cgprof/cgprof.c @@ -0,0 +1,1284 @@ +/* ------------------------------------------------------------------------ + * $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/utils/prof/cgprof/cgprof.h b/utils/prof/cgprof/cgprof.h new file mode 100644 index 0000000000..e93f02b53e --- /dev/null +++ b/utils/prof/cgprof/cgprof.h @@ -0,0 +1,82 @@ +/* ------------------------------------------------------------------------ + * $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/utils/prof/cgprof/daVinci.c b/utils/prof/cgprof/daVinci.c new file mode 100644 index 0000000000..0a59d1c89e --- /dev/null +++ b/utils/prof/cgprof/daVinci.c @@ -0,0 +1,760 @@ +/* ------------------------------------------------------------------------ + * $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/utils/prof/cgprof/daVinci.h b/utils/prof/cgprof/daVinci.h new file mode 100644 index 0000000000..3f6106983d --- /dev/null +++ b/utils/prof/cgprof/daVinci.h @@ -0,0 +1,95 @@ +/* ------------------------------------------------------------------------ + * $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/utils/prof/cgprof/main.c b/utils/prof/cgprof/main.c new file mode 100644 index 0000000000..afa8fbee19 --- /dev/null +++ b/utils/prof/cgprof/main.c @@ -0,0 +1,436 @@ +/* ------------------------------------------------------------------------ + * $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/utils/prof/cgprof/matrix.c b/utils/prof/cgprof/matrix.c new file mode 100644 index 0000000000..b4ca43f96b --- /dev/null +++ b/utils/prof/cgprof/matrix.c @@ -0,0 +1,98 @@ +/* ------------------------------------------------------------------------ + * $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/utils/prof/cgprof/matrix.h b/utils/prof/cgprof/matrix.h new file mode 100644 index 0000000000..bf70cf7c90 --- /dev/null +++ b/utils/prof/cgprof/matrix.h @@ -0,0 +1,42 @@ +/* ------------------------------------------------------------------------ + * $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/utils/prof/cgprof/symbol.c b/utils/prof/cgprof/symbol.c new file mode 100644 index 0000000000..133f59b2db --- /dev/null +++ b/utils/prof/cgprof/symbol.c @@ -0,0 +1,115 @@ +/* ------------------------------------------------------------------------ + * $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/utils/prof/cgprof/symbol.h b/utils/prof/cgprof/symbol.h new file mode 100644 index 0000000000..697973150c --- /dev/null +++ b/utils/prof/cgprof/symbol.h @@ -0,0 +1,58 @@ +/* ------------------------------------------------------------------------ + * $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/utils/prof/ghcprof.prl b/utils/prof/ghcprof.prl new file mode 100644 index 0000000000..bc3b344228 --- /dev/null +++ b/utils/prof/ghcprof.prl @@ -0,0 +1,280 @@ +# ----------------------------------------------------------------------------- +# $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/utils/prof/icons/Makefile b/utils/prof/icons/Makefile new file mode 100644 index 0000000000..fde1b16d3a --- /dev/null +++ b/utils/prof/icons/Makefile @@ -0,0 +1,7 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk + +override datadir=$(libdir)/icons +INSTALL_DATAS=$(wildcard *.xbm) + +include $(TOP)/mk/target.mk diff --git a/utils/prof/icons/absdelta.xbm b/utils/prof/icons/absdelta.xbm new file mode 100644 index 0000000000..e70e372dd0 --- /dev/null +++ b/utils/prof/icons/absdelta.xbm @@ -0,0 +1,8 @@ +#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/utils/prof/icons/absolute.xbm b/utils/prof/icons/absolute.xbm new file mode 100644 index 0000000000..045e1601f3 --- /dev/null +++ b/utils/prof/icons/absolute.xbm @@ -0,0 +1,8 @@ +#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/utils/prof/icons/comm.xbm b/utils/prof/icons/comm.xbm new file mode 100644 index 0000000000..3f1fe9412b --- /dev/null +++ b/utils/prof/icons/comm.xbm @@ -0,0 +1,8 @@ +#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/utils/prof/icons/commslack.xbm b/utils/prof/icons/commslack.xbm new file mode 100644 index 0000000000..f53e40fa8f --- /dev/null +++ b/utils/prof/icons/commslack.xbm @@ -0,0 +1,8 @@ +#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/utils/prof/icons/comp.xbm b/utils/prof/icons/comp.xbm new file mode 100644 index 0000000000..923ef2f3de --- /dev/null +++ b/utils/prof/icons/comp.xbm @@ -0,0 +1,8 @@ +#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/utils/prof/icons/compress.xbm b/utils/prof/icons/compress.xbm new file mode 100644 index 0000000000..39ff2f828e --- /dev/null +++ b/utils/prof/icons/compress.xbm @@ -0,0 +1,8 @@ +#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/utils/prof/icons/compslack.xbm b/utils/prof/icons/compslack.xbm new file mode 100644 index 0000000000..4592554582 --- /dev/null +++ b/utils/prof/icons/compslack.xbm @@ -0,0 +1,8 @@ +#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/utils/prof/icons/delete.xbm b/utils/prof/icons/delete.xbm new file mode 100644 index 0000000000..166d605a5a --- /dev/null +++ b/utils/prof/icons/delete.xbm @@ -0,0 +1,8 @@ +#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/utils/prof/icons/help.xbm b/utils/prof/icons/help.xbm new file mode 100644 index 0000000000..688e7dbd28 --- /dev/null +++ b/utils/prof/icons/help.xbm @@ -0,0 +1,8 @@ +#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/utils/prof/icons/hrel.xbm b/utils/prof/icons/hrel.xbm new file mode 100644 index 0000000000..36e58a9baf --- /dev/null +++ b/utils/prof/icons/hrel.xbm @@ -0,0 +1,8 @@ +#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/utils/prof/icons/hrelslack.xbm b/utils/prof/icons/hrelslack.xbm new file mode 100644 index 0000000000..8de8f0d36a --- /dev/null +++ b/utils/prof/icons/hrelslack.xbm @@ -0,0 +1,8 @@ +#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/utils/prof/icons/jump.xbm b/utils/prof/icons/jump.xbm new file mode 100644 index 0000000000..0e0327d45f --- /dev/null +++ b/utils/prof/icons/jump.xbm @@ -0,0 +1,8 @@ +#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/utils/prof/icons/mycomm.xbm b/utils/prof/icons/mycomm.xbm new file mode 100644 index 0000000000..8a3adcdb25 --- /dev/null +++ b/utils/prof/icons/mycomm.xbm @@ -0,0 +1,8 @@ +#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/utils/prof/icons/oxpara.xbm b/utils/prof/icons/oxpara.xbm new file mode 100644 index 0000000000..323270f9dd --- /dev/null +++ b/utils/prof/icons/oxpara.xbm @@ -0,0 +1,198 @@ +#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/utils/prof/icons/percent.xbm b/utils/prof/icons/percent.xbm new file mode 100644 index 0000000000..1dd05821c6 --- /dev/null +++ b/utils/prof/icons/percent.xbm @@ -0,0 +1,8 @@ +#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/utils/prof/icons/reldelta.xbm b/utils/prof/icons/reldelta.xbm new file mode 100644 index 0000000000..4e79b68ba8 --- /dev/null +++ b/utils/prof/icons/reldelta.xbm @@ -0,0 +1,8 @@ +#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/utils/prof/icons/sync.xbm b/utils/prof/icons/sync.xbm new file mode 100644 index 0000000000..55f3e55ff4 --- /dev/null +++ b/utils/prof/icons/sync.xbm @@ -0,0 +1,8 @@ +#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/utils/prof/icons/time.xbm b/utils/prof/icons/time.xbm new file mode 100644 index 0000000000..e8a79375b3 --- /dev/null +++ b/utils/prof/icons/time.xbm @@ -0,0 +1,8 @@ +#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/utils/prof/icons/time1.xbm b/utils/prof/icons/time1.xbm new file mode 100644 index 0000000000..0d2d4d7268 --- /dev/null +++ b/utils/prof/icons/time1.xbm @@ -0,0 +1,8 @@ +#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/utils/prof/icons/uncompress.xbm b/utils/prof/icons/uncompress.xbm new file mode 100644 index 0000000000..56f1293316 --- /dev/null +++ b/utils/prof/icons/uncompress.xbm @@ -0,0 +1,8 @@ +#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/utils/prof/icons/undo.xbm b/utils/prof/icons/undo.xbm new file mode 100644 index 0000000000..0658dc1e8e --- /dev/null +++ b/utils/prof/icons/undo.xbm @@ -0,0 +1,8 @@ +#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/utils/prof/icons/wait.xbm b/utils/prof/icons/wait.xbm new file mode 100644 index 0000000000..b0c16fc014 --- /dev/null +++ b/utils/prof/icons/wait.xbm @@ -0,0 +1,8 @@ +#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/utils/prof/icons/weightdelta.xbm b/utils/prof/icons/weightdelta.xbm new file mode 100644 index 0000000000..9ffa012260 --- /dev/null +++ b/utils/prof/icons/weightdelta.xbm @@ -0,0 +1,8 @@ +#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/utils/pvm/README b/utils/pvm/README new file mode 100644 index 0000000000..5ab58ddec8 --- /dev/null +++ b/utils/pvm/README @@ -0,0 +1,4 @@ +"debugger2" is our hacked version of the one that +comes with PVM 3.3.7. + +Less sure about "debugger.emacs"... diff --git a/utils/pvm/debugger.emacs b/utils/pvm/debugger.emacs new file mode 100644 index 0000000000..ee053ca7b4 --- /dev/null +++ b/utils/pvm/debugger.emacs @@ -0,0 +1,37 @@ +#!/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/utils/pvm/debugger2 b/utils/pvm/debugger2 new file mode 100644 index 0000000000..7cdf8b9a1a --- /dev/null +++ b/utils/pvm/debugger2 @@ -0,0 +1,48 @@ +#!/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/utils/runghc/Makefile b/utils/runghc/Makefile new file mode 100644 index 0000000000..90e4949530 --- /dev/null +++ b/utils/runghc/Makefile @@ -0,0 +1,32 @@ +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_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/utils/runghc/runghc.hs b/utils/runghc/runghc.hs new file mode 100644 index 0000000000..f8330b5721 --- /dev/null +++ b/utils/runghc/runghc.hs @@ -0,0 +1,66 @@ +{-# 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/utils/runstdtest/Makefile b/utils/runstdtest/Makefile new file mode 100644 index 0000000000..0bd2babfc2 --- /dev/null +++ b/utils/runstdtest/Makefile @@ -0,0 +1,12 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk + +SCRIPT_PROG=runstdtest +SCRIPT_OBJS=runstdtest.prl +SCRIPT_SUBST_VARS=RM DEFAULT_TMPDIR CONTEXT_DIFF +INTERP=perl + +CLEAN_FILES += $(SCRIPT_PROG) +DESTDIR=$(INSTSCRIPTDIR) + +include $(TOP)/mk/target.mk diff --git a/utils/runstdtest/runstdtest.prl b/utils/runstdtest/runstdtest.prl new file mode 100644 index 0000000000..1b1af9fb4d --- /dev/null +++ b/utils/runstdtest/runstdtest.prl @@ -0,0 +1,475 @@ +# +# The perl script requires the following variables to be bound +# to something meaningful before it will operate correctly: +# +# DEFAULT_TMPDIR +# CONTEXT_DIFF +# RM +# +# Given: +# * a program to run (1st arg) +# * some "command-line opts" ( -O<opt1> -O<opt2> ... ) +# [default: anything on the cmd line this script doesn't recognise ] +# the first opt not starting w/ "-" is taken to be an input +# file and (if it exists) is grepped for "what's going on here" +# comments (^-- !!!). +# * a file to feed to stdin ( -i<file> ) [default: /dev/null ] +# * a "time" command to use (-t <cmd>). +# +# * alternatively, a "-script <script>" argument says: run the +# named Bourne-shell script to do the test. It's passed the +# pgm-to-run as the one-and-only arg. +# +# Run the program with those options and that input, and check: +# if we get... +# +# * an expected exit status ( -x <val> ) [ default 0 ] +# * expected output on stdout ( -o1 <file> ) [ default /dev/null ] +# ( we'll accept one of several...) +# * expected output on stderr ( -o2 <file> ) [ default /dev/null ] +# ( we'll accept one of several...) +# +# (if the expected-output files' names end in .Z, then +# they are uncompressed before doing the comparison) +# +# (This is supposed to be a "prettier" replacement for runstdtest.) +# +# Flags +# ~~~~~ +# -accept-output replace output files with the ones actually generated by running +# the program +# +($Pgm = $0) =~ s|.*/||; +$Verbose = 0; +$SaveStderr = 0; +$SaveStdout = 0; +$Status = 0; +@PgmArgs = (); +$PgmFail=0; +$PgmExitStatus = 0; +$PgmStdinFile = '/dev/null'; +if ( $ENV{'TMPDIR'} ) { # where to make tmp file names + $TmpPrefix = $ENV{'TMPDIR'}; +} else { + $TmpPrefix ="$DEFAULT_TMPDIR"; + $ENV{'TMPDIR'} = "$DEFAULT_TMPDIR"; # set the env var as well +} +# If this is Cygwin, ignore eol and CR characters. +# Perhaps required for MSYS too, although the cygpath +# bit is hopefully unnecessary. +if ( `uname | grep CYGWIN` ) { + $CONTEXT_DIFF=$CONTEXT_DIFF . " --strip-trailing-cr" ; + $TmpPrefix = `cygpath -m $TmpPrefix | tr -d \\\\n`; +} +$ScriptFile = "$TmpPrefix/run_me$$"; +$DefaultStdoutFile = "$TmpPrefix/no_stdout$$"; # can't use /dev/null (e.g. Alphas) +$DefaultStderrFile = "$TmpPrefix/no_stderr$$"; +@PgmStdoutFile = (); +@PgmStderrFile = (); +$PreScript = ''; +$PostScript = ''; +$TimeCmd = ''; +$StatsFile = "$TmpPrefix/stats$$"; +$CachegrindStats = "cachegrind.out.summary"; +$SysSpecificTiming = ''; +$Cachegrind = 'no'; + +die "$Pgm: program to run not given as first argument\n" if $#ARGV < 0; +$ToRun = $ARGV[0]; shift(@ARGV); +# avoid picking up same-named thing from somewhere else on $PATH... +$ToRun = "./$ToRun" if -e "./$ToRun"; + +arg: while ($_ = $ARGV[0]) { + shift(@ARGV); + + /^--$/ && do { # let anything past after -- + push(@PgmArgs, @ARGV); + last arg; }; + + /^-v$/ && do { $Verbose = 1; next arg; }; + /^-accept-output-stderr$/ && do { $SaveStderr = 1; next arg; }; + /^-accept-output-stdout$/ && do { $SaveStdout = 1; next arg; }; + /^-accept-output$/ && do { $SaveStdout = 1; $SaveStderr = 1; next arg; }; + + /^-O(.*)/ && do { push(@PgmArgs, &grab_arg_arg('-O',$1)); next arg; }; + /^-i(.*)/ && do { $PgmStdinFile = &grab_arg_arg('-i',$1); + $Status++, + print STDERR "$Pgm: bogus -i input file: $PgmStdinFile\n" + if $PgmStdinFile !~ /^\/dev\/.*$/ && ! -f $PgmStdinFile; + next arg; }; + /^-fail/ && do { $PgmFail=1; next arg; }; + /^-x(.*)/ && do { $PgmExitStatus = &grab_arg_arg('-x',$1); + $Status++ , + print STDERR "$Pgm: bogus -x expected exit status: $PgmExitStatus\n" + if $PgmExitStatus !~ /^\d+$/; + next arg; }; + /^-o1(.*)/ && do { $out_file = &grab_arg_arg('-o1',$1); + push(@PgmStdoutFile, $out_file); + next arg; }; + /^-o2(.*)/ && do { $out_file = &grab_arg_arg('-o2',$1); + push(@PgmStderrFile, $out_file); + next arg; }; + /^-prescript(.*)/ && do { $PreScript = &grab_arg_arg('-prescript',$1); + next arg; }; + /^-postscript(.*)/ && do { $PostScript = &grab_arg_arg('-postscript',$1); + next arg; }; + /^-script/ && do { print STDERR "$Pgm: -script argument is obsolete;\nUse -prescript and -postscript instead.\n"; + $Status++; + next arg; }; + /^-(ghc|hbc)-timing$/ && do { $SysSpecificTiming = $1; + next arg; }; + /^-cachegrind$/ && do { $SysSpecificTiming = 'ghc-instrs'; + $Cachegrind = 'yes'; + next arg }; + /^-t(.*)/ && do { $TimeCmd = &grab_arg_arg('-t', $1); next arg; }; + + # anything else is taken to be a pgm arg + push(@PgmArgs, $_); +} + +foreach $out_file ( @PgmStdoutFile ) { + if ( ! -f $out_file && !$SaveStdout ) { + print STDERR "$Pgm: warning: expected-stdout file missing: $out_file\n"; + pop(@PgmStdoutFile); + } +} + +foreach $out_file ( @PgmStderrFile ) { + if ( ! -f $out_file && !$SaveStderr ) { + print STDERR "$Pgm: warning: expected-stderr file missing: $out_file\n"; + pop(@PgmStderrFile); + } +} + +exit 1 if $Status; + +# add on defaults if none specified +@PgmStdoutFile = ( $DefaultStdoutFile ) if $#PgmStdoutFile < 0; +@PgmStderrFile = ( $DefaultStderrFile ) if $#PgmStderrFile < 0; + +# tidy up the pgm args: +# (1) look for the "first input file" +# and grep it for "interesting" comments (-- !!! ) +# (2) quote any args w/ whitespace in them. +$grep_done = 0; +foreach $a ( @PgmArgs ) { + if (! $grep_done && $a !~ /^-/ && -f $a) { + print `egrep "^--[ ]?!!!" $a`; + $grep_done = 1; + } + if ($a =~ /\s/ || $a =~ /'/) { + $a =~ s/'/\\'/g; # backslash the quotes; + $a = "\"$a\""; # quote the arg + } +} + +# deal with system-specific timing options +$TimingMagic = ''; +if ( $SysSpecificTiming =~ /^ghc/ ) { + $TimingMagic = "+RTS -S$StatsFile -RTS" +} elsif ( $SysSpecificTiming eq 'hbc' ) { + $TimingMagic = "-S$StatsFile"; +} + +if ($PreScript ne '') { + local($to_do); + $PreScriptLines = `cat $PreScript`; + $PreScriptLines =~ s/\r//g; +} else { + $PreScriptLines = ''; +} + +if ($PostScript ne '') { + local($to_do); + $PostScriptLines = `cat $PostScript`; + $PostScriptLines =~ s/\r//g; + $* = 1; + $PostScriptLines =~ s#\$o1#$TmpPrefix/runtest$$.1#g; + $PostScriptLines =~ s#\$o2#$TmpPrefix/runtest$$.2#g; +} else { + $PostScriptLines = ''; +} + +# OK, so we're gonna do the normal thing... + +if ($Cachegrind eq 'yes') { + $CachegrindPrefix = "valgrind --tool=cachegrind --log-fd=9 9>$CachegrindStats"; +} else { + $CachegrindPrefix = ''; +} + +$Script = <<EOSCRIPT; +#! /bin/sh +myexit=0 +diffsShown=0 +rm -f $DefaultStdoutFile $DefaultStderrFile +cat /dev/null > $DefaultStdoutFile +cat /dev/null > $DefaultStderrFile +$PreScriptLines +$SpixifyLine1 +echo $TimeCmd /bin/sh -c \'$CachegrindPrefix $ToRun $TimingMagic @PgmArgs < $PgmStdinFile 1> $TmpPrefix/runtest$$.1 2> $TmpPrefix/runtest$$.2 3> $TmpPrefix/runtest$$.3\' +$TimeCmd /bin/sh -c \'$CachegrindPrefix $ToRun $TimingMagic @PgmArgs < $PgmStdinFile 1> $TmpPrefix/runtest$$.1 2> $TmpPrefix/runtest$$.2 3> $TmpPrefix/runtest$$.3\' +progexit=\$? +if [ \$progexit -eq 0 ] && [ $PgmFail -ne 0 ]; then + echo $ToRun @PgmArgs \\< $PgmStdinFile + echo "****" expected a failure, but was successful + myexit=1 +fi +if [ \$progexit -ne $PgmExitStatus ] && [ $PgmFail -eq 0 ]; then + echo $ToRun @PgmArgs \\< $PgmStdinFile + echo "****" expected exit status $PgmExitStatus not seen \\; got \$progexit + myexit=1 +else + $PostScriptLines + hit='NO' + for out_file in @PgmStdoutFile ; do + if cmp -s \$out_file $TmpPrefix/runtest$$.1 ; then + hit='YES' + fi + done + if [ \$hit = 'NO' ] ; then + echo $ToRun @PgmArgs \\< $PgmStdinFile + echo expected stdout not matched by reality + orig_file="$PgmStdoutFile[0]"; + [ ! -f \$orig_file ] && orig_file="/dev/null" + ${CONTEXT_DIFF} \$orig_file $TmpPrefix/runtest$$.1 + myexit=\$? + diffsShown=1 + fi + if [ $SaveStdout = 1 ] && + [ $PgmStdoutFile[0] != $DefaultStdoutFile ] && [ -s $TmpPrefix/runtest$$.1 ]; then + echo Saving away stdout output in $PgmStdoutFile[0] ... + if [ -f $PgmStdoutFile[0] ]; then + rm -f $PgmStdoutFile[0].bak + cp $PgmStdoutFile[0] $PgmStdoutFile[0].bak + fi; + cp $TmpPrefix/runtest$$.1 $PgmStdoutFile[0] + fi +fi + +hit='NO' +for out_file in @PgmStderrFile ; do + if cmp -s \$out_file $TmpPrefix/runtest$$.2 ; then + hit='YES' + fi +done +if [ \$hit = 'NO' ] ; then + echo $ToRun @PgmArgs \\< $PgmStdinFile + echo expected stderr not matched by reality + orig_file="$PgmStderrFile[0]" + [ ! -f \$orig_file ] && orig_file="/dev/null" + ${CONTEXT_DIFF} \$orig_file $TmpPrefix/runtest$$.2 + myexit=\$? + diffsShown=1 +fi +if [ $SaveStderr = 1 ] && + [ $PgmStderrFile[0] != $DefaultStderrFile ] && [ -s $TmpPrefix/runtest$$.2 ]; then + echo Saving away stderr output in $PgmStderrFile[0] ... + if [ -f $PgmStderrFile[0] ]; then + rm -f $PgmStderrFile[0].bak + cp $PgmStderrFile[0] $PgmStderrFile[0].bak + fi; + cp $TmpPrefix/runtest$$.2 $PgmStderrFile[0] +fi + +${RM} core $ToRunOrig.spix $DefaultStdoutFile $DefaultStderrFile $TmpPrefix/runtest$$.1 $TmpPrefix/runtest$$.2 $TmpPrefix/runtest$$.3 +exit \$myexit +EOSCRIPT + +# bung script into a file +open(SCR, "> $ScriptFile") || die "Failed opening script file $ScriptFile!\n"; +print SCR $Script; +close(SCR) || die "Failed closing script file!\n"; +chmod 0755, $ScriptFile; + +print STDERR $Script if $Verbose; + +&run_something($ScriptFile); + +if ( $SysSpecificTiming eq '' ) { + unlink $StatsFile; + unlink $ScriptFile; + exit 0; +} + +&process_stats_file(); +&process_cachegrind_files() if $Cachegrind eq 'yes'; + +# print out what we found +print STDERR "<<$SysSpecificTiming: "; +if ( $Cachegrind ne 'yes') { + print STDERR "$BytesAlloc bytes, $GCs GCs, $AvgResidency/$MaxResidency avg/max bytes residency ($ResidencySamples samples), $GCWork bytes GC work, ${TotMem}M in use, $InitTime INIT ($InitElapsed elapsed), $MutTime MUT ($MutElapsed elapsed), $GcTime GC ($GcElapsed elapsed)"; +} else { + print STDERR "$BytesAlloc bytes, $GCs GCs, $AvgResidency/$MaxResidency avg/max bytes residency ($ResidencySamples samples), $GCWork bytes GC work, ${TotMem}M in use, $InitTime INIT ($InitElapsed elapsed), $MutTime MUT ($MutElapsed elapsed), $GcTime GC ($GcElapsed elapsed), $TotInstrs instructions, $TotReads memory reads, $TotWrites memory writes, $TotMisses L2 cache misses"; +}; +print STDERR " :$SysSpecificTiming>>\n"; + +# OK, party over +unlink $StatsFile; +unlink $ScriptFile; +exit 0; + +sub grab_arg_arg { + local($option, $rest_of_arg) = @_; + + if ($rest_of_arg ne "") { + return($rest_of_arg); + } elsif ($#ARGV >= 0) { + local($temp) = $ARGV[0]; shift(@ARGV); + return($temp); + } else { + print STDERR "$Pgm: no argument following $option option\n"; + $Status++; + } +} + +sub run_something { + local($str_to_do) = @_; + +# print STDERR "$str_to_do\n" if $Verbose; + + local($return_val) = 0; + system($str_to_do); + $return_val = $?; + + if ($return_val != 0) { +#ToDo: this return-value mangling is wrong +# local($die_msg) = "$Pgm: execution of the $tidy_name had trouble"; +# $die_msg .= " (program not found)" if $return_val == 255; +# $die_msg .= " ($!)" if $Verbose && $! != 0; +# $die_msg .= "\n"; + unlink $ScriptFile; + unlink $StatsFile; + + exit (($return_val == 0) ? 0 : 1); + } +} + +sub process_stats_file { + + # OK, process system-specific stats file + if ( $SysSpecificTiming =~ /^ghc/ ) { + + #NB: nearly the same as in GHC driver's -ghc-timing stuff + + open(STATS, $StatsFile) || die "Failed when opening $StatsFile\n"; + + local($max_live) = 0; + local($tot_live) = 0; # for calculating residency stuff + local($tot_samples) = 0; + + $GCWork = 0; + while (<STATS>) { + if (! /Gen:\s+0/ && /^\s*\d+\s+\d+\s+(\d+)\s+\d+\.\d+/ ) { + $max_live = $1 if $max_live < $1; + $tot_live += $1; + $tot_samples += 1; + } + + $BytesAlloc = $1 if /^\s*([0-9,]+) bytes allocated in the heap/; + $GCWork += $1 if /^\s*([0-9,]+) bytes copied during GC/; + +# if ( /^\s*([0-9,]+) bytes maximum residency .* (\d+) sample/ ) { +# $MaxResidency = $1; $ResidencySamples = $2; +# } + + $GCs = $1 if /^\s*([0-9,]+) collections? in generation 0/; + + if ( /^\s+([0-9]+)\s+Mb total memory/ ) { + $TotMem = $1; + } + + if ( /^\s*INIT\s+time\s*(-*\d+\.\d\d)s\s*\(\s*(-*\d+\.\d\d)s elapsed\)/ ) { + $InitTime = $1; $InitElapsed = $2; + } elsif ( /^\s*MUT\s+time\s*(-*\d+\.\d\d)s\s*\(\s*(-*\d+\.\d\d)s elapsed\)/ ) { + $MutTime = $1; $MutElapsed = $2; + } elsif ( /^\s*GC\s+time\s*(-*\d+\.\d\d)s\s*\(\s*(-*\d+\.\d\d)s elapsed\)/ ) { + $GcTime = $1; $GcElapsed = $2; + } + } + close(STATS) || die "Failed when closing $StatsFile\n"; + if ( $tot_samples > 0 ) { + $ResidencySamples = $tot_samples; + $MaxResidency = $max_live; + $AvgResidency = int ($tot_live / $tot_samples) ; + } + + } elsif ( $SysSpecificTiming eq 'hbc' ) { + + open(STATS, $StatsFile) || die "Failed when opening $StatsFile\n"; + while (<STATS>) { + $BytesAlloc = $1 if /^\s*([0-9]+) bytes allocated from the heap/; + + $GCs = $1 if /^\s*([0-9]+) GCs?,$/; + + if ( /^\s*(\d+\.\d\d) \((\d+\.\d)\) seconds total time,$/ ) { + $MutTime = $1; $MutElapsed = $2; # will fix up later + + $InitTime = 0; $InitElapsed = 0; # hbc doesn't report these + + } elsif ( /^\s*(\d+\.\d\d) \((\d+\.\d)\) seconds GC time/ ) { + $GcTime = $1; $GcElapsed = $2; + + # fix up mutator time now + $MutTime = sprintf("%.2f", ($MutTime - $GcTime)); + $MutElapsed = sprintf("%.1f", ($MutElapsed - $GcElapsed)); + } + } + close(STATS) || die "Failed when closing $StatsFile\n"; + } + + # warn about what we didn't find + print STDERR "Warning: BytesAlloc not found in stats file\n" unless defined($BytesAlloc); + print STDERR "Warning: GCs not found in stats file\n" unless defined($GCs); + print STDERR "Warning: InitTime not found in stats file\n" unless defined($InitTime); + print STDERR "Warning: InitElapsed not found in stats file\n" unless defined($InitElapsed); + print STDERR "Warning: MutTime not found in stats file\n" unless defined($MutTime); + print STDERR "Warning: MutElapsed not found in stats file\n" unless defined($MutElapsed); + print STDERR "Warning: GcTime inot found in stats file\n" unless defined($GcTime); + print STDERR "Warning: GcElapsed not found in stats file\n" unless defined($GcElapsed); + print STDERR "Warning: total memory not found in stats file\n" unless defined($TotMem); + print STDERR "Warning: GC work not found in stats file\n" unless defined($GCWork); + + # things we didn't necessarily expect to find + $MaxResidency = 0 unless defined($MaxResidency); + $AvgResidency = 0 unless defined($AvgResidency); + $ResidencySamples = 0 unless defined($ResidencySamples); + + # a bit of tidying + $BytesAlloc =~ s/,//g; + $GCWork =~ s/,//g; + $MaxResidency =~ s/,//g; + $GCs =~ s/,//g; + $InitTime =~ s/,//g; + $InitElapsed =~ s/,//g; + $MutTime =~ s/,//g; + $MutElapsed =~ s/,//g; + $GcTime =~ s/,//g; + $GcElapsed =~ s/,//g; +} + +sub process_cachegrind_files { + + open(STATS, "< $CachegrindStats") || die("Can't open $CachegrindStats\n"); + + while (<STATS>) { + /^==\d+==\s+I\s+refs:\s+([0-9,]*)/ && do { + $TotInstrs = $1; + $TotInstrs =~ s/,//g; + }; + + /^==\d+==\s+D\s+refs:\s+[0-9,]+\s+\(([0-9,]+)\s+rd\s+\+\s+([0-9,]+)\s+wr/ && do { + $TotReads = $1; + $TotWrites = $2; + $TotReads =~ s/,//g; + $TotWrites =~ s/,//g; + }; + + /^==\d+==\s+L2d\s+misses:\s+([0-9,]+)/ && do { + $TotMisses = $1; + $TotMisses =~ s/,//g; + }; + } + close(STATS); +} + diff --git a/utils/stat2resid/Makefile b/utils/stat2resid/Makefile new file mode 100644 index 0000000000..f474f5229d --- /dev/null +++ b/utils/stat2resid/Makefile @@ -0,0 +1,56 @@ +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/utils/stat2resid/parse-gcstats.prl b/utils/stat2resid/parse-gcstats.prl new file mode 100644 index 0000000000..d882ee6348 --- /dev/null +++ b/utils/stat2resid/parse-gcstats.prl @@ -0,0 +1,232 @@ +# +# 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/utils/stat2resid/prefix.txt b/utils/stat2resid/prefix.txt new file mode 100644 index 0000000000..0de9d61f25 --- /dev/null +++ b/utils/stat2resid/prefix.txt @@ -0,0 +1,10 @@ +# +# 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/utils/stat2resid/process-gcstats.prl b/utils/stat2resid/process-gcstats.prl new file mode 100644 index 0000000000..ff41cf6af9 --- /dev/null +++ b/utils/stat2resid/process-gcstats.prl @@ -0,0 +1,45 @@ +# +# 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/utils/stat2resid/stat2resid.prl b/utils/stat2resid/stat2resid.prl new file mode 100644 index 0000000000..bf0a262428 --- /dev/null +++ b/utils/stat2resid/stat2resid.prl @@ -0,0 +1,81 @@ +# +# (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/utils/touchy/Makefile b/utils/touchy/Makefile new file mode 100644 index 0000000000..d2430df162 --- /dev/null +++ b/utils/touchy/Makefile @@ -0,0 +1,20 @@ +# +# 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/utils/touchy/touchy.c b/utils/touchy/touchy.c new file mode 100644 index 0000000000..90fb31e93e --- /dev/null +++ b/utils/touchy/touchy.c @@ -0,0 +1,63 @@ +/* + * 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/utils/unlit/Makefile b/utils/unlit/Makefile new file mode 100644 index 0000000000..15e7fc4252 --- /dev/null +++ b/utils/unlit/Makefile @@ -0,0 +1,16 @@ +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/utils/unlit/README b/utils/unlit/README new file mode 100644 index 0000000000..4dd2ef5132 --- /dev/null +++ b/utils/unlit/README @@ -0,0 +1,8 @@ +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/utils/unlit/unlit.c b/utils/unlit/unlit.c new file mode 100644 index 0000000000..366302156a --- /dev/null +++ b/utils/unlit/unlit.c @@ -0,0 +1,401 @@ +/* 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); +} diff --git a/utils/verbatim/Makefile b/utils/verbatim/Makefile new file mode 100644 index 0000000000..4a4301dfe0 --- /dev/null +++ b/utils/verbatim/Makefile @@ -0,0 +1,17 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk + +C_SRCS = verbatim.c +C_PROG = verbatim +LIBS = $(FLEX_LIB) + +override SRC_FLEX_OPTS=-8 + +# +# For src distributions, include flex output. +# +SRC_DIST_FILES += verbatim.c + +CLEAN_FILES += verbatim.c + +include $(TOP)/mk/target.mk diff --git a/utils/verbatim/verbatim.lex b/utils/verbatim/verbatim.lex new file mode 100644 index 0000000000..bac87cc45f --- /dev/null +++ b/utils/verbatim/verbatim.lex @@ -0,0 +1,63 @@ + + /* This Lex script acts as a filter to pre-process Latex files. + + It surrounds groups of lines beginning with a ">" sign, and + preceded and followed by a blank line, with \begin{verbatim} + and \end{verbatim}. The ">" may be preceded by a digit or digit + range (eg 4>, 2-5>, 3->); in this case the digits are removed. + They are meant to be used for filtering out versions. + + It takes words surrounded with @ signs (thus @letrec@) and makes them + come out in typewriter font, regardless of the current mode. + */ + +%START NORM VERB MIRANDA VERBATIM VERBATIMSIM +sp [ \t]* +nl {sp}\n{sp} +miranda ([0-9]+(\-([0-9]+)?)?)?> +%{ +#define PUSH states[top++] = +#define POP BEGIN states[--top] +#define yywrap() 1 +%} +%% + int states[256]; + int top; + BEGIN NORM; + top = 0; +<NORM>@@ { printf ("@"); } +<NORM>@ { printf ("\\mbox{\\tt "); PUSH NORM; BEGIN VERB; } +<VERB>@ { printf ("}"); POP; } +<VERB>\n { printf ("}\\\\{}\n\\mbox{\\tt "); } +<VERB>" " { printf ("\\ "); } +<VERB>@@ { printf ("@"); } +<VERB>\# { printf ("{\\char'43}"); } +<VERB>\$ { printf ("{\\char'44}"); } +<VERB>\% { printf ("{\\char'45}"); } +<VERB>\& { printf ("{\\char'46}"); } +<VERB>\~ { printf ("{\\char'176}"); } +<VERB>\_ { printf ("{\\char'137}"); } +<VERB>\^ { printf ("{\\char'136}"); } +<VERB>\\ { printf ("{\\char'134}"); } +<VERB>\{ { printf ("{\\char'173}"); } +<VERB>\} { printf ("{\\char'175}"); } + +<NORM>^@{sp}\n { printf( "\\begin{verbatim}\n" ); + PUSH NORM; BEGIN VERBATIMSIM; } +<VERBATIMSIM>^@{sp}\n { printf( "\\end{verbatim}\n" ); POP; } + +<NORM>\\"begin{verbatim}" { printf( "\\begin{verbatim}" ); + PUSH NORM; BEGIN VERBATIM; } +<VERBATIM>\\"end{verbatim}" { printf( "\\end{verbatim}" ); POP; } + +<NORM>^\n{miranda} { printf ("\\begin{verbatim}\n>" ); + PUSH NORM; BEGIN MIRANDA; } +<MIRANDA>\n{miranda} { printf( "\n>" ); } +<MIRANDA>^\n { printf ("\\end{verbatim}\n"); POP; } +%% +int +main() +{ + yylex(); + return(0); +} |