DbgDumpSRIDTable

module DbgDumpSRIDTable(dbgDumpSRIDTable) where

import Char
import IO
import System
import PackedString(PackedString, unpackPS, packString)
import IntState
import Extra(strStr, dropJust, trace)
import Flags
import Syntax(ImpDecl(..), ImpSpec(..), Entity(..), InfixClass(..))
import TokenId(TokenId(..))
import DbgTrans(SRIDTable)





dbgDumpSRIDTable :: Handle -> IntState -> Flags -> SRIDTable -> IO ()

dbgDumpSRIDTable handle state flags Nothing = return ()
dbgDumpSRIDTable handle state flags (Just ((_, srs), idt, impdecls, modid)) = 
    output (showString "DL(" . showString modpre . showString ")\n" . 
            chopString filename .
	    showString "  AL\n  EX L(NM_" . showString srcid . 
            showString ")\n DL(NM_" . showString srcid . showString ")\n") >>
    mapM_ (dumpId state (sProfile flags) modinfo output trust) idtlabs >>
    output (showString "  DW 0\n") >>
    mapM_ (dumpNs state (sProfile flags) modpre output trust) idtlabs >>
    output (showString "  AL\nDL(D_srstart)\n") >>
    mapM_ (dumpSR state (sProfile flags) modinfo output) (reverse srs) >>
    output (showString " DL(N_IMPORTS)\n") >>
--  mapM_ (dumpImport output) impdecls >>
    output (showString "  DW 0\n  EX L(" . showString modinfo .
            showString ")\n DL(" . showString modinfo .
	    showString ")\n  DW L(" . showString modpre .
            showString "), L(NM_" . showString srcid .
            showString "), L(N_IMPORTS), L(NMODN)\n" .
            showString " DW 0\n" .
            showString (if trust then " DW 1\n" else " DW 0\n") .
	    showString " DL(NMODN)\n" . chopString modid . 
	    showString "  AL\n") >>
    if modid == "Main" then
        output (showString "  EX L(MODULE_Main)\n DL(MODULE_Main)\n DW L(" .
	        showString modinfo . showString ")\n")
    else
        return ()
    where modpre = "D_" ++ srcid
          modinfo = "NMOD_" ++ srcid
          trust = sDbgTrusted flags
	  idtlabs = zip [(p, i, (tidI . dropJust . lookupIS state) i) 
	                | (p, i) <- idt
			] 
			[0..]
          output sf = catch (hPutStr handle (sf "")) outputerr
	  outputerr ioerror = hPutStr stderr ("Failed appending debug tables to"
	                                      ++sObjectFile flags++":" ++ 
					      show ioerror ++ "\n") 
			      >> exitWith (ExitFailure (-1))
          filename = let ms = sSourceFile flags
		     in reverse (takeWhile ('/' /=) (reverse ms))
          srcid = let ms = sSourceFile flags
	              ms' = case break ('.'==) (reverse ms) of
			      ("sh", rf) -> reverse (tail rf)
			      ("shl", rf) -> reverse (tail rf)
			      _ -> ms
		  in reverse (takeWhile ('/' /=) (reverse ms'))
dumpId state profile modinfo output trust ((pos, i, tid), lab) =
    output (showString "  EX L(D_" . showString idnhc . 
            showString ")\nDL(D_" . showString idnhc . 
	    -- The 6 below is the constructor number of NTId
	    -- 22 (16+6) is used if the function is trusted
	    -- See getconstr.h in the runtime system.
	    (if trust && isVar then
	        showString ")\n  DW CONSTR(22,5,5)\n  DW " 
	     else
	        showString ")\n  DW CONSTR(6,5,5)\n  DW ") . 
	    (if profile then showString "L(prof_NTId), 0, 0, 0, " else id) .
	    showString "L(" . showString modinfo .
            showString "), " . shows pos . 
	    showString ", L(L_" . shows lab . showString "), " .
	    shows (priority pri) . showString"\n" .
            showString "  DW 0\n")
    where idnhc = fixStr (show tid) ""
          (isVar, pri) = 
	      case lookupIS state i of
	          Just (i@(InfoConstr _ _ _ _ _ _)) -> (False, fixityI i)
	          Just (i@(InfoIMethod _ _ _ _ m)) -> 
		      case lookupIS state m of 
		          Just im -> (True, fixityI im)
		  Just i -> (True, fixityI i)
		  _ -> (True, (InfixL, 9))
	  fixStr [] = id
	  fixStr (c:cs) =
	      if isAlphaNum c then
	          showChar c . fixStr cs
	      else 
	          showChar '_' . shows (fromEnum c) . fixStr cs
	  priority :: (InfixClass TokenId, Int) -> Int
	  priority (InfixDef, _)   = 3
          priority (InfixL, n)     = 2 + shiftPri n
          priority (InfixR, n)     = 1 + shiftPri n
          priority (Infix, n)      = 0 + shiftPri n
          priority (InfixPre _, n) = 0 + shiftPri n
	  shiftPri :: Int -> Int
	  shiftPri n = n * 4

dumpNs state profile modpre output trust ((pos, _, tid), lab) =
    output (showString "DL(L_" . shows lab . showString ")\n" .
            chopString (untoken tid))

dumpSR state profile modinfo output sr =
    -- (2, 2, 2) -> (Tag 2 (SR3), size 2, 2 non-pointers)
    output (showString "  DW CONSTR(2,2,2)\n  DW "
           . (if profile then showString "L(prof_SR3), 0, 0, 0, " else id)
           . shows sr . showString ", L(" . showString modinfo
           . showString ")\n  DW 0\n")

dumpImport output impdecl = 

output (showString "  DW L(NMOD_" .  showString modname . showString ")\n")
    where modname = untoken (imptokid impdecl)
          imptokid (Import (_,i) _) = i
          imptokid (ImportQ (_,i) _) = i
	  imptokid (ImportQas (_,i) _ _) = i
	  imptokid (Importas (_,i) _ _) = i


untoken (TupleId 0) = ""
untoken (TupleId n) = take (n-1) (repeat ',')
untoken (Visible ps) = reverse (unpackPS ps)
untoken (Qualified _ ps) = reverse (unpackPS ps)
untoken (Qualified2 _ tid) = untoken tid
untoken (Qualified3 _ _ tid) = untoken tid

chopString "" = showString "  DB 0\n"
chopString x  = 
    case splitAt (40::Int) x of
        (x,xs) -> showString "  DS " . showString (strStr x) . 
	          showString "\n" . chopString xs