Diff_Gcc_Nat.hs

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