<commit_before>{-# LANGUAGE OverloadedStrings, FlexibleContexts,
  FlexibleInstances, GADTs, Rank2Types, DeriveGeneric #-}

module Blockchain.Analyze.IR
  ( HplBody
  , HplOp
  , WordLabelMapM
  , unWordLabelMapM
  , evmOps2HplBody
  ) where

import Blockchain.ExtWord as BE
import Blockchain.VM.Opcodes as BVO
import Compiler.Hoopl as CH
import Control.Monad as CM
import Data.Bimap as DB

data HplOp e x where
        CoOp :: Label -> HplOp C O
        OoOp :: (Word256, Operation) -> HplOp O O
        OcOp :: (Word256, Operation) -> [Label] -> HplOp O C
        TailOp :: [(Word256, Operation)] -> HplOp O C

instance Show (HplOp e x)

instance Eq (HplOp C O) where
  (==) (CoOp a) (CoOp b) = a == b

instance Eq (HplOp O O) where
  (==) (OoOp a) (OoOp b) = a == b

instance Eq (HplOp O C) where
  (==) (TailOp a) (TailOp b) = a == b
  (==) (OcOp a _) (OcOp b _) = a == b
  (==) _ _ = False

instance NonLocal HplOp where
  entryLabel (CoOp l) = l
  successors (OcOp _ ll) = ll
  successors (TailOp _) = []

type HplBody = Body HplOp

-- evmOp2HplOp :: (Word256, Operation) -> WordLabelMapM (Either (HplOp O O) (HplOp O C))
-- evmOp2HplOp op@(loc, STOP) = return $ Right $ OcOp op []
-- evmOp2HplOp op = error ("Unimplemented(evmOp2HplOp):" ++ show op)
evmOps2HplBody :: [(Word256, Operation)] -> WordLabelMapM HplBody
evmOps2HplBody [] = return emptyBody
evmOps2HplBody el@((loc, h):t) = do
  l <- labelFor loc
  doEvmOps2HplBody emptyBody (blockJoinHead (CoOp l) emptyBlock) el
  where
    doEvmOps2HplBody :: HplBody
                     -> (Block HplOp C O)
                     -> [(Word256, Operation)]
                     -> WordLabelMapM HplBody
    doEvmOps2HplBody body hd [] = return body -- sliently discarding bad hds
    doEvmOps2HplBody body hd (h':[]) =
      if isTerminator (snd h')
        then return $ addBlock (blockJoinTail hd (OcOp h' [])) body
        else return body
    doEvmOps2HplBody body hd (h':(t'@((loc', _):_))) =
      if isTerminator (snd h')
        then do
          l' <- labelFor loc'
          doEvmOps2HplBody
            (addBlock (blockJoinTail hd (OcOp h' [])) body)
            (blockJoinHead (CoOp l') emptyBlock)
            t'
        else doEvmOps2HplBody body (blockSnoc hd (OoOp h')) t'

isTerminator :: Operation -> Bool
isTerminator STOP = True
isTerminator JUMP = True
isTerminator JUMPI = True
isTerminator CALL = True
isTerminator CALLCODE = True
isTerminator RETURN = True
isTerminator DELEGATECALL = True
isTerminator SUICIDE = True
isTerminator _ = False

--------------------------------------------------------------------------------
-- The WordLabelMapM monad
--------------------------------------------------------------------------------
type WordLabelMap = Bimap Word256 Label

data WordLabelMapM a =
  WordLabelMapM (WordLabelMap -> SimpleUniqueMonad (WordLabelMap, a))

labelFor :: Word256 -> WordLabelMapM Label
labelFor word = WordLabelMapM f
  where
    f m =
      case DB.lookup word m of
        Just l' -> return (m, l')
        Nothing -> do
          l' <- freshLabel
          let m' = DB.insert word l' m
          return (m', l')

labelsFor :: [Word256] -> WordLabelMapM [Label]
labelsFor = mapM labelFor

instance Monad WordLabelMapM where
  return = pure
  WordLabelMapM f1 >>= k =
    WordLabelMapM $
    \m -> do
      (m', x) <- f1 m
      let (WordLabelMapM f2) = k x<commit_msg>Implement and use canPassThrough<commit_after>{-# LANGUAGE OverloadedStrings, FlexibleContexts,
  FlexibleInstances, GADTs, Rank2Types, DeriveGeneric #-}

module Blockchain.Analyze.IR
  ( HplBody
  , HplOp
  , WordLabelMapM
  , unWordLabelMapM
  , evmOps2HplBody
  ) where

import Blockchain.ExtWord as BE
import Blockchain.VM.Opcodes as BVO
import Compiler.Hoopl as CH
import Control.Monad as CM
import Data.Bimap as DB

data HplOp e x where
        CoOp :: Label -> HplOp C O
        OoOp :: (Word256, Operation) -> HplOp O O
        OcOp :: (Word256, Operation) -> [Label] -> HplOp O C

instance Show (HplOp e x)

instance Eq (HplOp C O) where
  (==) (CoOp a) (CoOp b) = a == b

instance Eq (HplOp O O) where
  (==) (OoOp a) (OoOp b) = a == b

instance Eq (HplOp O C) where
  (==) (OcOp a _) (OcOp b _) = a == b

instance NonLocal HplOp where
  entryLabel (CoOp l) = l
  successors (OcOp _ ll) = ll

type HplBody = Body HplOp

-- evmOp2HplOp :: (Word256, Operation) -> WordLabelMapM (Either (HplOp O O) (HplOp O C))
-- evmOp2HplOp op@(loc, STOP) = return $ Right $ OcOp op []
-- evmOp2HplOp op = error ("Unimplemented(evmOp2HplOp):" ++ show op)
evmOps2HplBody :: [(Word256, Operation)] -> WordLabelMapM HplBody
evmOps2HplBody [] = return emptyBody
evmOps2HplBody el@((loc, _):_) = do
  l <- labelFor loc
  doEvmOps2HplBody emptyBody (blockJoinHead (CoOp l) emptyBlock) el
  where
    doEvmOps2HplBody :: HplBody
                     -> (Block HplOp C O)
                     -> [(Word256, Operation)]
                     -> WordLabelMapM HplBody
    doEvmOps2HplBody body hd [] = return body -- sliently discarding bad hds
    doEvmOps2HplBody body hd (h':[]) =
      if isTerminator (snd h')
        then return $ addBlock (blockJoinTail hd (OcOp h' [])) body
        else return body
    doEvmOps2HplBody body hd (h':(t'@((loc', _):_))) =
      if isTerminator (snd h')
        then do
          l' <- labelFor loc'
          doEvmOps2HplBody
            (addBlock (blockJoinTail hd (OcOp h' (
                                            if canPassThrough (snd h') then [l'] else []))) body)
            (blockJoinHead (CoOp l') emptyBlock)
            t'
        else doEvmOps2HplBody body (blockSnoc hd (OoOp h')) t'

isTerminator :: Operation -> Bool
isTerminator STOP = True
isTerminator JUMP = True
isTerminator JUMPI = True
isTerminator CALL = True
isTerminator CALLCODE = True
isTerminator RETURN = True
isTerminator DELEGATECALL = True
isTerminator SUICIDE = True
isTerminator _ = False

canPassThrough :: Operation -> Bool
canPassThrough STOP = False
canPassThrough JUMP = False
canPassThrough RETURN = False
canPassThrough SUICIDE = False
canPassThrough _ = True

--------------------------------------------------------------------------------
-- The WordLabelMapM monad
--------------------------------------------------------------------------------
type WordLabelMap = Bimap Word256 Label

data WordLabelMapM a =
  WordLabelMapM (WordLabelMap -> SimpleUniqueMonad (WordLabelMap, a))

labelFor :: Word256 -> WordLabelMapM Label
labelFor word = WordLabelMapM f
  where
    f m =
      case DB.lookup word m of
        Just l' -> return (m, l')
        Nothing -> do
          l' <- freshLabel
          let m' = DB.insert word l' m
          return (m', l')

labelsFor :: [Word256] -> WordLabelMapM [Label]
labelsFor = mapM labelFor

instance Monad WordLabelMapM where
  return = pure
  WordLabelMapM f1 >>= k =
    WordLabelMapM $
    \m -> do
      (m', x) <- f1 m
      let (WordLabelMapM f2) = k x
{'fraction_non_alphanumeric': 0.14698200812536275, 'fraction_numerical': 0.012913522925130587, 'mean_word_length': 2.331561140647656, 'pattern_counts': {'":': 0, '<': 11, '<?xml version=': 0, '>': 41, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 2, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4412938', 'n_tokens_mistral': 2438, 'n_tokens_neox': 2349, 'n_words': 722}