+++ /dev/null
-
-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
projects / ghc-hetmet.git / blobdiff