<commit_before>{-# LANGUAGE ViewPatterns #-}
-- | This module implements SSA value numbering over the low-level Dalvik IR
--
-- The algorithm used is from Braun et al
-- (http://www.cdl.uni-saarland.de/papers/bbhlmz13cc.pdf).  The
-- labelling maps each operand of a low-level Dalvik instruction to
-- the SSA number of that operand.
--
-- Note that SSA numbers are only required for *instructions*.
-- Constants are, well, constant, and can be handled directly during
-- translation.
--
-- Translation to the SSA IR requires knot tying.  Many instructions
-- can be ignored.  Instructions with a destination register get assigned
-- the number placed on their destination (in fact, they create a new value
-- by virtue of having that destination).
--
-- > newinstance r2 Double
--
-- is basically equivalent to
--
-- > r2 <- newinstance Double
--
-- So r2 is a new SSA value here.
--
-- > loop:
-- >   binop Add r1 r1 r2
-- >   br (r1 < 100) loop
--
-- Should translate into something like
-- > loop:
-- >   r4 <- phi(r3, r1)
-- >   r3 <- binop add r4 r2
-- >   br (r4 < 100) loop
module Dalvik.SSA.Labelling where

import Control.Monad ( forM_ )
import Control.Monad.Trans.RWS.Strict
import Data.Int ( Int64 )
import Data.IntSet ( IntSet )
import qualified Data.IntSet as IS
import Data.Map ( Map )
import qualified Data.Map as M
import Data.Maybe ( fromMaybe, mapMaybe )
import qualified Data.List as L
import Data.Set ( Set )
import qualified Data.Set as S
import Data.Vector ( Vector )
import qualified Data.Vector as V
import Data.Word ( Word8, Word16 )
import Text.PrettyPrint as PP
import Text.Printf

import Dalvik.Instruction

data Label = SimpleLabel Int64
           | PhiLabel BlockNumber Int64
           deriving (Eq, Ord, Show)

freshLabel :: SSALabeller Label
freshLabel = do
  s <- get
  put s { labelCounter = labelCounter s + 1 }
  return $ SimpleLabel (labelCounter s)

freshPhi :: BlockNumber -> SSALabeller Label
freshPhi bn = do
  s <- get
  let lid = labelCounter s
      l = PhiLabel bn lid
  put s { labelCounter = lid + 1
        , phiOperands = M.insert l S.empty (phiOperands s)
        }
  return l

-- | A labelling assigns an SSA number/Label to a register at *each*
-- 'Instruction'.
data Labelling = Labelling { labellingReadRegs :: Map Instruction (Map Word16 Label)
                           , labellingWriteRegs :: Map Instruction Label
                           , labellingPhis :: Map Label (Set Label)
                           , labellingBasicBlocks :: Vector (BlockNumber, Vector Instruction)
                           }
                 deriving (Eq, Ord, Show)

prettyLabelling :: Labelling -> String
prettyLabelling l =
  render $ PP.vcat $ map prettyBlock $ V.toList (labellingBasicBlocks l)
  where
    prettyBlock (bid, insts) =
      let header = PP.text ";; " <> PP.int bid
          body = PP.nest 2 $ PP.vcat $ map prettyInst $ V.toList insts
      in header $+$ body
    prettyInst i =
      case i of
        Nop -> PP.text "nop"
        Move t r1 r2 -> PP.text $ printf ";; move %s %s %s" (show t) (show r1) (show r2)
        Move1 t r -> PP.text $ printf ";; move1 %s %s" (show t) (show r)
        ReturnVoid -> PP.text "ret"
        Return _ r -> PP.text $ printf "ret v$%s ;\t (ret %s)" (rLabelId r) (show r)
        LoadConst r arg -> PP.text $ printf "%s = loadc %s ;\t (loadc %s %s)" (wLabelId r) (show arg) (show r) (show arg)
        MonitorEnter r -> PP.text $ printf "menter %s ;\t (menter %s)" (rLabelId r) (show r)
        MonitorExit r -> PP.text $ printf "mexit %s ;\t (mexit %s)" (rLabelId r) (show r)
        CheckCast r t -> PP.text $ printf "checkcast %s %s ;\t (checkcast %s %s)" (rLabelId r) (show t) (show r) (show t)
        InstanceOf d s t -> PP.text $ printf "%s = instanceof %s %s ;\t (instanceof %s %s %s)" (wLabelId d) (rLabelId s) (show t) (show d) (show s) (show t)
        ArrayLength d s -> PP.text $ printf "%s = arraylength %s ;\t (arraylength %s %s)" (wLabelId d) (rLabelId s) (show d) (show s)
        NewInstance d t -> PP.text $ printf "%s = newinstance %s ;\t (newinstance %s %s)" (wLabelId d) (show t) (show d) (show t)
        NewArray d s t -> PP.text $ printf "%s = newarray %s %s ;\t (newarray %s %s %s)" (wLabelId d) (rLabelId s) (show t) (show d) (show s) (show t)
        IBinop op _ d s1 s2 -> PP.text $ printf "%s = %s %s %s ;\t (%s %s %s %s)" (wLabelId d) (show op) (rLabelId s1) (rLabelId s2) (show d) (show op) (show s1) (show s2)
      where
        rLabelId reg = fromMaybe "??" $ do
          regMap <- M.lookup i (labellingReadRegs l)
          lab <- M.lookup (fromRegister reg) regMap
          case lab of
            SimpleLabel lnum -> return (show lnum)
            PhiLabel _ lnum -> return (show lnum)<commit_msg>pretty print a few more cases<commit_after>{-# LANGUAGE ViewPatterns #-}
-- | This module implements SSA value numbering over the low-level Dalvik IR
--
-- The algorithm used is from Braun et al
-- (http://www.cdl.uni-saarland.de/papers/bbhlmz13cc.pdf).  The
-- labelling maps each operand of a low-level Dalvik instruction to
-- the SSA number of that operand.
--
-- Note that SSA numbers are only required for *instructions*.
-- Constants are, well, constant, and can be handled directly during
-- translation.
--
-- Translation to the SSA IR requires knot tying.  Many instructions
-- can be ignored.  Instructions with a destination register get assigned
-- the number placed on their destination (in fact, they create a new value
-- by virtue of having that destination).
--
-- > newinstance r2 Double
--
-- is basically equivalent to
--
-- > r2 <- newinstance Double
--
-- So r2 is a new SSA value here.
--
-- > loop:
-- >   binop Add r1 r1 r2
-- >   br (r1 < 100) loop
--
-- Should translate into something like
-- > loop:
-- >   r4 <- phi(r3, r1)
-- >   r3 <- binop add r4 r2
-- >   br (r4 < 100) loop
module Dalvik.SSA.Labelling where

import Control.Monad ( forM_ )
import Control.Monad.Trans.RWS.Strict
import Data.Int ( Int64 )
import Data.IntSet ( IntSet )
import qualified Data.IntSet as IS
import Data.Map ( Map )
import qualified Data.Map as M
import Data.Maybe ( fromMaybe, mapMaybe )
import qualified Data.List as L
import Data.Set ( Set )
import qualified Data.Set as S
import Data.Vector ( Vector )
import qualified Data.Vector as V
import Data.Word ( Word8, Word16 )
import Text.PrettyPrint as PP
import Text.Printf

import Dalvik.Instruction

data Label = SimpleLabel Int64
           | PhiLabel BlockNumber Int64
           deriving (Eq, Ord, Show)

freshLabel :: SSALabeller Label
freshLabel = do
  s <- get
  put s { labelCounter = labelCounter s + 1 }
  return $ SimpleLabel (labelCounter s)

freshPhi :: BlockNumber -> SSALabeller Label
freshPhi bn = do
  s <- get
  let lid = labelCounter s
      l = PhiLabel bn lid
  put s { labelCounter = lid + 1
        , phiOperands = M.insert l S.empty (phiOperands s)
        }
  return l

-- | A labelling assigns an SSA number/Label to a register at *each*
-- 'Instruction'.
data Labelling = Labelling { labellingReadRegs :: Map Instruction (Map Word16 Label)
                           , labellingWriteRegs :: Map Instruction Label
                           , labellingPhis :: Map Label (Set Label)
                           , labellingBasicBlocks :: Vector (BlockNumber, Vector Instruction)
                           }
                 deriving (Eq, Ord, Show)

prettyLabelling :: Labelling -> String
prettyLabelling l =
  render $ PP.vcat $ map prettyBlock $ V.toList (labellingBasicBlocks l)
  where
    prettyBlock (bid, insts) =
      let header = PP.text ";; " <> PP.int bid
          body = PP.nest 2 $ PP.vcat $ map prettyInst $ V.toList insts
      in header $+$ body
    prettyInst i =
      case i of
        Nop -> PP.text "nop"
        Move t r1 r2 -> PP.text $ printf ";; move %s %s %s" (show t) (show r1) (show r2)
        Move1 t r -> PP.text $ printf "%s = move1 %s ;\t (move1 %s %s)" (wLabelId r) (show t) (show t) (show r)
        ReturnVoid -> PP.text "ret"
        Return _ r -> PP.text $ printf "ret $%s ;\t (ret %s)" (rLabelId r) (show r)
        LoadConst r arg -> PP.text $ printf "$%s = loadc %s ;\t (loadc %s %s)" (wLabelId r) (show arg) (show r) (show arg)
        MonitorEnter r -> PP.text $ printf "menter $%s ;\t (menter %s)" (rLabelId r) (show r)
        MonitorExit r -> PP.text $ printf "mexit $%s ;\t (mexit %s)" (rLabelId r) (show r)
        CheckCast r t -> PP.text $ printf "checkcast $%s %s ;\t (checkcast %s %s)" (rLabelId r) (show t) (show r) (show t)
        InstanceOf d s t -> PP.text $ printf "$%s = instanceof $%s %s ;\t (instanceof %s %s %s)" (wLabelId d) (rLabelId s) (show t) (show d) (show s) (show t)
        ArrayLength d s -> PP.text $ printf "$%s = arraylength $%s ;\t (arraylength %s %s)" (wLabelId d) (rLabelId s) (show d) (show s)
        NewInstance d t -> PP.text $ printf "$%s = newinstance $%s ;\t (newinstance %s %s)" (wLabelId d) (show t) (show d) (show t)
        NewArray d s t -> PP.text $ printf "$%s = newarray $%s $%s ;\t (newarray %s %s %s)" (wLabelId d) (rLabelId s) (show t) (show d) (show s) (show t)
        FilledNewArray t srcs -> PP.text $ printf "fillednewarray %s %s ;\t (fillednewarray %s %s)" (show t) (concatMap rLabelId srcs) (show t) (show srcs)
        FilledNewArrayRange t srcs -> PP.text $ printf "fillednewarrayrange %s %s ;\t (fillednewarrayrange %s %s)" (show t) (concatMap rLabelId srcs) (show t) (show srcs)
        Throw r -> PP.text $ printf "throw $%s ;\t (throw %s)" (rLabelId r) (show r)
        IBinop op _ d s1 s2 -> PP.text $ printf "$%s = $%s $%s $%s ;\t (%s %s %s %s)" (wLabelId d) (show op) (rLabelId s1) (rLabelId s2) (show op) (show d) (show s1) (show s2)
      where
        rLabelId reg = fromMaybe "??" $ do
          regMap <- M.lookup i (labellingReadRegs l)
          lab <- M.lookup (fromRegister reg) regMap
          case lab of
            SimpleLabel lnum -> return (show lnum)
            PhiLabel _ lnum -> return (show lnum)
{'fraction_non_alphanumeric': 0.12506278252134606, 'fraction_numerical': 0.009743847312908087, 'mean_word_length': 2.4994727592267134, 'pattern_counts': {'":': 0, '<': 23, '<?xml version=': 0, '>': 62, 'https://': 0, 'lorem ipsum': 0, 'www.': 2, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '734688', 'n_tokens_mistral': 3386, 'n_tokens_neox': 3278, 'n_words': 1287}