Commit dfedfb02 authored by sewardj's avatar sewardj
Browse files

[project @ 2000-07-05 14:28:49 by sewardj]

Rename the marker used by Diff_Gcc_Nat.hs to ___ncg_debug_marker, to make
it clear it has nothing to do with the usual object-splitting machinery.

Improve Diff_Gcc_Nat:
* Emit a warning, and stop, if there are no debug markers in the NCG code.
* Handle .uahalf and .uaword, which appear in sparc assembly, but not x86.
parent 558c0ec0
......@@ -97,11 +97,10 @@ nativeCodeGen absC us
# if NCG_DEBUG
my_trace m x = trace m x
my_vcat sds = vcat (intersperse
(char ' '
$$ ptext SLIT("# __debug_NCG_split_marker")
$$ char ' ')
sds)
my_vcat sds = vcat (intersperse (char ' '
$$ ptext SLIT("# ___ncg_debug_marker")
$$ char ' ')
sds)
# else
my_vcat sds = vcat sds
my_trace m x = x
......
......@@ -5,6 +5,8 @@ import System
import Char
import Array
--import IOExts(trace)
type Label = String
type Code = [String]
......@@ -14,6 +16,8 @@ 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" ++
......@@ -33,6 +37,9 @@ main
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
......@@ -77,7 +84,14 @@ main
++ ["#endif"
]
putStr (unlines final)
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])
......@@ -133,7 +147,23 @@ find_corresponding :: Label -- root
-> Maybe ([String],[String]) -- (found text, gcc leftovers)
find_corresponding root kinds gcc_lines
= case kinds of
= -- 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)
......@@ -144,7 +174,8 @@ find_corresponding root kinds gcc_lines
[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"])
lst_i = search_fwds arr (lbl_i+1)
(not . pfxMatch [".long",".uaword",".uahalf"])
in
splice arr fst_i (lst_i-1)
......@@ -188,15 +219,17 @@ find_corresponding root kinds gcc_lines
[Srt]
-> let lbl_i = find_label arr (reconstruct_label root Srt)
fst_i = search_back arr lbl_i (pfxMatch [".text"])
lst_i = search_fwds arr (lbl_i+1) (not . pfxMatch [".long"])
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"])
lst_i = search_fwds arr (lbl_i+1)
(not . pfxMatch [".long",".uaword",".uahalf"])
in
splice arr fst_i (lst_i-1)
......@@ -209,11 +242,6 @@ find_corresponding root kinds gcc_lines
other
-> error ("find_corresponding: " ++ show kinds)
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
search_back :: Array Int String -> Int -> (String -> Bool) -> Int
search_back code start_ix pred
......@@ -232,10 +260,11 @@ search_fwds code start_ix pred
find_label :: Array Int String -> Label -> Int
find_label code lbl
= case [idx | (idx, lbl2) <- assocs code, lbl == lbl2] of
= --trace (unlines (map show (assocs code))) (
case [idx | (idx, lbl2) <- assocs code, lbl == lbl2] of
[idx] -> idx
other -> error ("find_label: " ++ lbl)
other -> error ("find_label `" ++ lbl ++ "'\n")
--)
reconstruct_label :: Label -> LabelKind -> Label
reconstruct_label root Init
......@@ -330,7 +359,7 @@ reconstruct number nat_code gcc_code
comment str x = str ++ x
-----------------------------------------------------
split_marker = "___stg_split_marker"
split_marker = "___ncg_debug_marker"
is_split_line s
= let m = split_marker
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment