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