More work towards dynamic programs on Windows
[ghc.git] / utils / debugNCG / Diff_Gcc_Nat.hs
1
2 module Main where
3 import List
4 import System
5 import Char
6 import Array
7
8 --import IOExts(trace)
9
10 type Label = String
11 type Code = [String]
12
13 pzipWith f [] [] = []
14 pzipWith f (a:as) (b:bs) = (f a b) : pzipWith f as bs
15 pzipWith f _ _ = error "pzipWith: unbalanced list"
16
17 main
18 = getArgs >>= \args ->
19 --return ["/home/v-julsew/SOLARIS/NCG/fpt/ghc/tests/codeGen/should_run/cg001.s"]
20 -- >>= \args ->
21 if length args /= 1
22 then putStr ("\ndiff_gcc_nat:\n" ++
23 " usage: create File.s-gcc and File.s-nat\n" ++
24 " then do: diff_gcc_nat File.s > synth.S\n" ++
25 " and compile synth.S into your program.\n" ++
26 "diff_gcc_nat is to help debug GHC's native code generator;\n" ++
27 "it is quite useless for any other purpose. For details, see\n" ++
28 " fptools/ghc/utils/debugNCG/README.\n"++
29 "\n"
30 )
31 else
32 do
33 let [f_root] = args
34 f_gcc <- readFile (f_root ++ "-gcc")
35 f_nat <- readFile (f_root ++ "-nat")
36
37 let split_nat0 = breakOn is_split_line (lines f_nat)
38 split_nat = filter (not.null.getLabels) split_nat0
39
40 split_markers_present
41 = any is_split_line (lines f_nat)
42
43 labels_nat = map getLabels split_nat
44 labels_cls = map (map breakLabel) labels_nat
45
46 labels_merged :: [(Label, [LabelKind])]
47 labels_merged = map mergeBroken labels_cls
48
49 classified :: [(Label, [LabelKind], [String])]
50 classified
51 = pzipWith (\ merged text -> (fst merged, snd merged, text))
52 labels_merged split_nat
53
54 lines_gcc = lines f_gcc
55
56 (syncd, gcc_unused)
57 = find_correspondings classified lines_gcc
58 (ok_syncs, nat_unused)
59 = check_syncs syncd
60
61 num_ok = length ok_syncs
62
63 preamble
64 = map (\i -> "#define NATIVE_" ++ show i ++ " 0") [1 .. num_ok]
65 ++ ["",
66 "#define UNMATCHED_NAT 0",
67 "#define UNMATCHED_GCC 1",
68 ""]
69
70 final
71 = preamble
72 ++ concat (pzipWith pp_ok_sync ok_syncs [1 .. num_ok])
73 ++ ["",
74 "//============== unmatched NAT =================",
75 "#if UNMATCHED_NAT",
76 ""]
77 ++ nat_unused
78 ++ ["",
79 "#endif",
80 "",
81 "//============== unmatched GCC =================",
82 "#if UNMATCHED_GCC"]
83 ++ gcc_unused
84 ++ ["#endif"
85 ]
86
87 if split_markers_present
88 then putStr (unlines final)
89 else putStr ("\ndiff_gcc_nat:\n"
90 ++ " fatal error: NCG output doesn't contain any\n"
91 ++ " ___ncg_debug_marker marks. Can't continue!\n"
92 ++ " To fix: enable these markers in\n"
93 ++ " fptools/ghc/compiler/nativeGen/AsmCodeGen.lhs,\n"
94 ++ " recompile the compiler, and regenerate the assembly.\n\n")
95
96
97 pp_ok_sync :: (Label, [LabelKind], [String], [String])
98 -> Int
99 -> [String]
100 pp_ok_sync (lbl, kinds, nat_code, gcc_code) number
101 = reconstruct number nat_code gcc_code
102
103
104 check_syncs :: [(Label, [LabelKind], [String], Maybe [String])] -- raw syncd
105 -> ( [(Label, [LabelKind], [String], [String])], -- ok syncs
106 [String] ) -- nat unsyncd
107
108 check_syncs [] = ([],[])
109 check_syncs (sync:syncs)
110 = let (syncs_ok, syncs_uu) = check_syncs syncs
111 in case sync of
112 (lbl, kinds, nat, Nothing)
113 -> (syncs_ok, nat ++ syncs_uu)
114 (lbl, kinds, nat, Just gcc_code)
115 -> ((lbl,kinds,nat,gcc_code):syncs_ok, syncs_uu)
116
117
118 find_correspondings :: [(Label, [LabelKind], [String])] -- native info
119 -> [String] -- gcc initial
120 -> ( [(Label, [LabelKind], [String], Maybe [String])],
121 [String] )
122 -- ( native info + found gcc stuff,
123 -- unused gcc stuff )
124
125 find_correspondings native gcc_init
126 = f native gcc_init
127 where
128 wurble x (xs, gcc_final) = (x:xs, gcc_final)
129
130 f [] gcc_uu = ( [], gcc_uu )
131 f (nat:nats) gcc_uu
132 = case nat of { (lbl, kinds, nat_code) ->
133 case find_corresponding lbl kinds gcc_uu of
134 Just (gcc_code, gcc_uu2)
135 | gcc_code == gcc_code
136 -> --gcc_code `seq` gcc_uu2 `seq`
137 wurble (lbl, kinds, nat_code, Just gcc_code) (f nats gcc_uu2)
138 Nothing
139 -> gcc_uu `seq`
140 wurble (lbl, kinds, nat_code, Nothing) (f nats gcc_uu)
141 }
142
143
144 find_corresponding :: Label -- root
145 -> [LabelKind] -- kinds
146 -> [String] -- gcc text
147 -> Maybe ([String],[String]) -- (found text, gcc leftovers)
148
149 find_corresponding root kinds gcc_lines
150 = -- Enable the following trace in order to debug pattern matching problems.
151 --trace (
152 -- case result of
153 -- Nothing -> show (root,kinds) ++ "\nNothing\n\n"
154 -- Just (found,uu)
155 -- -> show (root, kinds) ++ "\n" ++ unlines found ++ "\n\n"
156 --)
157 result
158 where
159
160 arr = listArray (1, length gcc_lines) gcc_lines
161 pfxMatch ss t
162 = let clean_t = filter (not.isSpace) t
163 in any (`isPrefixOf` clean_t) ss
164
165 result
166 = case kinds of
167
168 [Vtbl]
169 -> let lbl_i = find_label arr (reconstruct_label root Vtbl)
170 fst_i = search_back arr lbl_i (pfxMatch [".text"])
171 in
172 splice arr fst_i lbl_i
173
174 [Closure]
175 -> let lbl_i = find_label arr (reconstruct_label root Closure)
176 fst_i = search_back arr lbl_i (pfxMatch [".data"])
177 lst_i = search_fwds arr (lbl_i+1)
178 (not . pfxMatch [".long",".uaword",".uahalf"])
179 in
180 splice arr fst_i (lst_i-1)
181
182 [Alt]
183 -> let lbl_i = find_label arr (reconstruct_label root Alt)
184 fst_i = search_back arr lbl_i (pfxMatch ["."])
185 lst_i = search_fwds arr lbl_i (pfxMatch [".d", ".t", ".r", ".g"])
186 in
187 splice arr fst_i (lst_i-1)
188
189 [Dflt]
190 -> let lbl_i = find_label arr (reconstruct_label root Dflt)
191 fst_i = search_back arr lbl_i (pfxMatch ["."])
192 lst_i = search_fwds arr lbl_i (pfxMatch [".d", ".t", ".r", ".g"])
193 in
194 splice arr fst_i (lst_i-1)
195
196 [Info,Entry]
197 -> let info_i = find_label arr (reconstruct_label root Info)
198 fst_i = search_back arr info_i (pfxMatch [".text"])
199 entry_i = find_label arr (reconstruct_label root Entry)
200 lst_i = search_fwds arr entry_i (pfxMatch [".d", ".t", ".r", ".g"])
201 in
202 splice arr fst_i (lst_i-1)
203
204 [Info,Entry,Fast k]
205 -> let info_i = find_label arr (reconstruct_label root Info)
206 fst_i = search_back arr info_i (pfxMatch [".text"])
207 fast_i = find_label arr (reconstruct_label root (Fast k))
208 lst_i = search_fwds arr fast_i (pfxMatch [".d", ".t", ".r", ".g"])
209 in
210 splice arr fst_i (lst_i-1)
211
212 [Info,Ret]
213 -> let info_i = find_label arr (reconstruct_label root Info)
214 fst_i = search_back arr info_i (pfxMatch [".text"])
215 ret_i = find_label arr (reconstruct_label root Ret)
216 lst_i = search_fwds arr ret_i (pfxMatch [".d", ".t", ".r", ".g"])
217 in
218 splice arr fst_i (lst_i-1)
219
220 [Srt]
221 -> let lbl_i = find_label arr (reconstruct_label root Srt)
222 fst_i = search_back arr lbl_i (pfxMatch [".text",".data"])
223 lst_i = search_fwds arr (lbl_i+1)
224 (not . pfxMatch [".long",".uaword",".uahalf"])
225 in
226 splice arr fst_i (lst_i-1)
227
228 [CTbl]
229 -> let lbl_i = find_label arr (reconstruct_label root CTbl)
230 fst_i = search_back arr lbl_i (pfxMatch [".text"])
231 lst_i = search_fwds arr (lbl_i+1)
232 (not . pfxMatch [".long",".uaword",".uahalf"])
233 in
234 splice arr fst_i (lst_i-1)
235
236 [Init]
237 -> let lbl_i = find_label arr (reconstruct_label root Init)
238 fst_i = search_back arr lbl_i (pfxMatch [".data"])
239 lst_i = search_fwds arr lbl_i (pfxMatch [".d", ".t", ".r", ".g"])
240 in
241 splice arr fst_i (lst_i-1)
242 other
243 -> error ("find_corresponding: " ++ show kinds)
244
245
246 search_back :: Array Int String -> Int -> (String -> Bool) -> Int
247 search_back code start_ix pred
248 = let test_ixs = [start_ix, start_ix-1 .. fst (bounds code)]
249 in case dropWhile (not . pred . (code !)) test_ixs of
250 (ok:_) -> ok
251 [] -> fst (bounds code) - 1
252
253 search_fwds :: Array Int String -> Int -> (String -> Bool) -> Int
254 search_fwds code start_ix pred
255 = let test_ixs = [start_ix .. snd (bounds code)]
256 in case dropWhile (not . pred . (code !)) test_ixs of
257 (ok:_) -> ok
258 [] -> snd (bounds code) + 1
259
260
261 find_label :: Array Int String -> Label -> Int
262 find_label code lbl
263 = --trace (unlines (map show (assocs code))) (
264 case [idx | (idx, lbl2) <- assocs code, lbl == lbl2] of
265 [idx] -> idx
266 other -> error ("find_label `" ++ lbl ++ "'\n")
267 --)
268
269 reconstruct_label :: Label -> LabelKind -> Label
270 reconstruct_label root Init
271 = "__stginit_" ++ root ++ ":"
272 reconstruct_label root kind
273 = root ++ "_" ++ pp kind ++ ":"
274 where
275 pp Info = "info"
276 pp Entry = "entry"
277 pp Closure = "closure"
278 pp Alt = "alt"
279 pp Vtbl = "vtbl"
280 pp Default = "dflt"
281 pp (Fast i) = "fast" ++ show i
282 pp Dflt = "dflt"
283 pp Srt = "srt"
284 pp Ret = "ret"
285 pp CTbl = "tbl"
286
287 splice :: Array Int String -> Int -> Int -> Maybe ([String],[String])
288 splice gcc_code lo hi
289 | lo <= hi && clo <= lo && hi <= chi
290 = Just (map (gcc_code !) ix_used,
291 map (gcc_code !) (low_ix_uu ++ high_ix_uu))
292 | otherwise
293 = error "splice"
294 where
295 (clo,chi) = bounds gcc_code
296 low_ix_uu = [clo .. lo-1]
297 high_ix_uu = [hi+1 .. chi]
298 ix_used = [lo .. hi]
299
300 ------------------------------------
301
302 getLabels :: [Label] -> [Label]
303 getLabels = sort . nub . filter is_interesting_label
304
305 data LabelKind
306 = Info | Entry | Fast Int | Closure | Alt | Vtbl | Default
307 | Dflt | Srt | Ret | CTbl | Init
308 deriving (Eq, Ord, Show)
309
310 breakLabel :: Label -> (Label,LabelKind)
311 breakLabel s
312 = let sr = reverse s
313 kr = takeWhile (/= '_') sr
314 mr = drop (1 + length kr) sr
315 m = reverse mr
316 k = reverse kr
317 kind
318 | take 4 k == "fast"
319 = Fast (read (takeWhile isDigit (drop 4 k)))
320 | otherwise
321 = case k of
322 "info:" -> Info
323 "entry:" -> Entry
324 "closure:" -> Closure
325 "alt:" -> Alt
326 "vtbl:" -> Vtbl
327 "dflt:" -> Dflt
328 "srt:" -> Srt
329 "ret:" -> Ret
330 "tbl:" -> CTbl
331 _ -> error ("breakLabel: " ++ show (s,k,m))
332 in
333 if head m == '_' && dropWhile (== '_') m == "stginit"
334 then (init k, Init)
335 else (m, kind)
336
337 mergeBroken :: [(Label,LabelKind)] -> (Label, [LabelKind])
338 mergeBroken pairs
339 = let (roots, kinds) = unzip pairs
340 ok = all (== (head roots)) (tail roots)
341 && length kinds == length (nub kinds)
342 in
343 if ok
344 then (head roots, sort kinds)
345 else error ("mergeBroken: " ++ show pairs)
346
347
348 reconstruct :: Int -> Code -> Code -> Code
349 reconstruct number nat_code gcc_code
350 = ["",
351 "//------------------------------------------"]
352 ++ map (comment ("//-- ")) (getLabels gcc_code)
353 ++ ["", "#if NATIVE_" ++ show number, "//nat version", ""]
354 ++ nat_code
355 ++ ["", "#else", "//gcc version", ""]
356 ++ gcc_code
357 ++ ["", "#endif"]
358
359 comment str x = str ++ x
360
361 -----------------------------------------------------
362 split_marker = "___ncg_debug_marker"
363
364 is_split_line s
365 = let m = split_marker
366 in take 19 s == m || take 19 (drop 2 s) == m
367
368 is_interesting_label s
369 = not (null s)
370 && not (any isSpace s)
371 && last s == ':'
372 && '_' `elem` s
373
374 breakOn :: (a -> Bool) -> [a] -> [[a]]
375 breakOn p [] = []
376 breakOn p xs
377 = let ys = takeWhile (not . p) xs
378 rest = drop (1 + length ys) xs
379 in
380 if null ys then breakOn p rest else ys : breakOn p rest