----------------------------------------------------------------------------
--
-- Pretty-printing of old-style Cmm as (a superset of) C--
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------

--
-- This is where we walk over Cmm emitting an external representation,
-- suitable for parsing, in a syntax strongly reminiscent of C--. This
-- is the "External Core" for the Cmm layer.
--
-- As such, this should be a well-defined syntax: we want it to look nice.
-- Thus, we try wherever possible to use syntax defined in [1],
-- "The C-- Reference Manual", http://www.cminusminus.org/. We differ
-- slightly, in some cases. For one, we use I8 .. I64 for types, rather
-- than C--'s bits8 .. bits64.
--
-- We try to ensure that all information available in the abstract
-- syntax is reproduced, or reproducible, in the concrete syntax.
-- Data that is not in printed out can be reconstructed according to
-- conventions used in the pretty printer. There are at least two such
-- cases:
--      1) if a value has wordRep type, the type is not appended in the
--      output.
--      2) MachOps that operate over wordRep type are printed in a
--      C-style, rather than as their internal MachRep name.
--
-- These conventions produce much more readable Cmm output.
--
-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
--

module OldPprCmm
    ( pprStmt
    , module PprCmmDecl
    , module PprCmmExpr
    )
where

import BlockId
import CLabel
import CmmUtils
import OldCmm
import PprCmmDecl
import PprCmmExpr


import BasicTypes
import ForeignCall
import Outputable
import Platform
import FastString

import Data.List

-----------------------------------------------------------------------------

instance PlatformOutputable instr => PlatformOutputable (ListGraph instr) where
    pprPlatform platform (ListGraph blocks) = vcat (map (pprPlatform platform) blocks)

instance PlatformOutputable instr => PlatformOutputable (GenBasicBlock instr) where
    pprPlatform platform b = pprBBlock platform b

instance Outputable CmmStmt where
    ppr s = pprStmt s
instance PlatformOutputable CmmStmt where
    pprPlatform _ = ppr

instance Outputable CmmInfo where
    ppr e = pprInfo e


-- --------------------------------------------------------------------------
instance Outputable CmmSafety where
  ppr CmmUnsafe = ptext (sLit "_unsafe_call_")
  ppr CmmInterruptible = ptext (sLit "_interruptible_call_")
  ppr (CmmSafe srt) = ppr srt

-- --------------------------------------------------------------------------
-- Info tables. The current pretty printer needs refinement
-- but will work for now.
--
-- For ideas on how to refine it, they used to be printed in the
-- style of C--'s 'stackdata' declaration, just inside the proc body,
-- and were labelled with the procedure name ++ "_info".
pprInfo :: CmmInfo -> SDoc
pprInfo (CmmInfo _gc_target update_frame CmmNonInfoTable) =
    vcat [{-ptext (sLit "gc_target: ") <>
                maybe (ptext (sLit "<none>")) ppr gc_target,-}
          ptext (sLit "update_frame: ") <>
                maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame]
pprInfo (CmmInfo _gc_target update_frame info_table@(CmmInfoTable _ _ _ _ _)) =
    vcat [{-ptext (sLit "gc_target: ") <>
                maybe (ptext (sLit "<none>")) ppr gc_target,-}
          ptext (sLit "update_frame: ") <>
                maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame,
          ppr info_table]


-- --------------------------------------------------------------------------
-- Basic blocks look like assembly blocks.
--      lbl: stmt ; stmt ; ..
pprBBlock :: PlatformOutputable stmt => Platform -> GenBasicBlock stmt -> SDoc
pprBBlock platform (BasicBlock ident stmts) =
    hang (ppr ident <> colon) 4 (vcat (map (pprPlatform platform) stmts))

-- --------------------------------------------------------------------------
-- Statements. C-- usually, exceptions to this should be obvious.
--
pprStmt :: CmmStmt -> SDoc
pprStmt stmt = case stmt of

    -- ;
    CmmNop -> semi

    --  // text
    CmmComment s -> text "//" <+> ftext s

    -- reg = expr;
    CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi

    -- rep[lv] = expr;
    CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
        where
          rep = ppr ( cmmExprType expr )

    -- call "ccall" foo(x, y)[r1, r2];
    -- ToDo ppr volatile
    CmmCall (CmmCallee fn cconv) results args safety ret ->
        sep  [ pp_lhs <+> pp_conv
             , nest 2 (pprExpr9 fn <>
                       parens (commafy (map ppr_ar args)))
               <> brackets (ppr safety)
             , case ret of CmmMayReturn -> empty
                           CmmNeverReturns -> ptext $ sLit (" never returns")
             ] <> semi
        where
          pp_lhs | null results = empty
                 | otherwise    = commafy (map ppr_ar results) <+> equals
                -- Don't print the hints on a native C-- call
          ppr_ar (CmmHinted ar k) = case cconv of
                            CmmCallConv -> ppr ar
                            _           -> ppr (ar,k)
          pp_conv = case cconv of
                      CmmCallConv -> empty
                      _           -> ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv)

    -- Call a CallishMachOp, like sin or cos that might be implemented as a library call.
    CmmCall (CmmPrim op) results args safety ret ->
        pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
                        results args safety ret)
        where
          -- HACK: A CallishMachOp doesn't really correspond to a ForeignLabel, but we
          --       use one to get the label printed.
          lbl = CmmLabel (mkForeignLabel
                                (mkFastString (show op))
                                Nothing ForeignLabelInThisPackage IsFunction)

    CmmBranch ident          -> genBranch ident
    CmmCondBranch expr ident -> genCondBranch expr ident
    CmmJump expr params      -> genJump expr params
    CmmReturn params         -> genReturn params
    CmmSwitch arg ids        -> genSwitch arg ids

-- Just look like a tuple, since it was a tuple before
-- ... is that a good idea? --Isaac Dupree
instance (Outputable a) => Outputable (CmmHinted a) where
  ppr (CmmHinted a k) = ppr (a, k)

pprUpdateFrame :: UpdateFrame -> SDoc
pprUpdateFrame (UpdateFrame expr args) =
    hcat [ ptext (sLit "jump")
         , space
         , if isTrivialCmmExpr expr
                then pprExpr expr
                else case expr of
                    CmmLoad (CmmReg _) _ -> pprExpr expr
                    _ -> parens (pprExpr expr)
         , space
         , parens  ( commafy $ map ppr args ) ]


-- --------------------------------------------------------------------------
-- goto local label. [1], section 6.6
--
--     goto lbl;
--
genBranch :: BlockId -> SDoc
genBranch ident =
    ptext (sLit "goto") <+> ppr ident <> semi

-- --------------------------------------------------------------------------
-- Conditional. [1], section 6.4
--
--     if (expr) { goto lbl; }
--
genCondBranch :: CmmExpr -> BlockId -> SDoc
genCondBranch expr ident =
    hsep [ ptext (sLit "if")
         , parens(ppr expr)
         , ptext (sLit "goto")
         , ppr ident <> semi ]

-- --------------------------------------------------------------------------
-- A tail call. [1], Section 6.9
--
--     jump foo(a, b, c);
--
genJump :: CmmExpr -> [CmmHinted CmmExpr] -> SDoc
genJump expr args =
    hcat [ ptext (sLit "jump")
         , space
         , if isTrivialCmmExpr expr
                then pprExpr expr
                else case expr of
                    CmmLoad (CmmReg _) _ -> pprExpr expr
                    _ -> parens (pprExpr expr)
         , space
         , parens  ( commafy $ map ppr args )
         , semi ]


-- --------------------------------------------------------------------------
-- Return from a function. [1], Section 6.8.2 of version 1.128
--
--     return (a, b, c);
--
genReturn :: [CmmHinted CmmExpr] -> SDoc
genReturn args =
    hcat [ ptext (sLit "return")
         , space
         , parens  ( commafy $ map ppr args )
         , semi ]

-- --------------------------------------------------------------------------
-- Tabled jump to local label
--
-- The syntax is from [1], section 6.5
--
--      switch [0 .. n] (expr) { case ... ; }
--
genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
genSwitch expr maybe_ids

    = let pairs = groupBy snds (zip [0 .. ] maybe_ids )

      in hang (hcat [ ptext (sLit "switch [0 .. ")
                    , int (length maybe_ids - 1)
                    , ptext (sLit "] ")
                    , if isTrivialCmmExpr expr
                        then pprExpr expr
                        else parens (pprExpr expr)
                    , ptext (sLit " {")
                    ])
            4 (vcat ( map caseify pairs )) $$ rbrace

    where
      snds a b = (snd a) == (snd b)

      caseify :: [(Int,Maybe BlockId)] -> SDoc
      caseify ixs@((_,Nothing):_)
        = ptext (sLit "/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
                <> ptext (sLit " */")
      caseify as
        = let (is,ids) = unzip as
          in hsep [ ptext (sLit "case")
                  , hcat (punctuate comma (map int is))
                  , ptext (sLit ": goto")
                  , ppr (head [ id | Just id <- ids]) <> semi ]

-----------------------------------------------------------------------------

commafy :: [SDoc] -> SDoc
commafy xs = fsep $ punctuate comma xs