{-# OPTIONS_GHC -Wno-missing-signatures #-}

module Wrench.Wrench (
    Options (..),
    Result (..),
    prettyLabels,
    runWrenchIO,
    wrench,
    Isa (..),
    AddrFormat (..),
    DumpSize (..),
) where

import Control.Exception (ErrorCall (..), try)
import Data.Default (Default (..), def)
import Data.Text qualified as T
import Prelude (Read (..))
import Relude
import Relude.Extra
import System.IO qualified as SIO
import System.Random qualified as Random
import Text.Pretty.Simple
import Wrench.Config
import Wrench.Isa (Isa (..), detectIsa, isaName)
import Wrench.Isa.Acc32 (Acc32St)
import Wrench.Isa.F32a (F32aSt)
import Wrench.Isa.M68k (M68kSt)
import Wrench.Isa.RiscIv (RiscIvSt)
import Wrench.Isa.VliwIv (VliwIvSt)
import Wrench.Isa.Wasm32.LocalNames (resolveLocalNames)
import Wrench.Isa.Wasm32.State (Wasm32St)
import Wrench.Machine
import Wrench.Machine.Memory
import Wrench.Machine.Types
import Wrench.Report
import Wrench.Report.View (CheckEnv (..))
import Wrench.Translator
import Wrench.Translator.Parser.Types
import Wrench.Translator.Types

data Options = Options
    { Options -> String
input :: FilePath
    , Options -> Maybe String
isa :: Maybe String
    -- ^ 'Nothing' leaves it to 'detectIsa'.
    , Options -> Maybe String
configFile :: Maybe FilePath
    , Options -> Bool
onlyTranslation :: Bool
    , Options -> Bool
stats :: Bool
    , Options -> Bool
verbose :: Bool
    , Options -> Int
maxInstructionLimit :: Int
    , Options -> Int
maxMemoryLimit :: Int
    , Options -> Int
maxStateLogLimit :: Int
    , Options -> AddrFormat
dumpAddrFormat :: AddrFormat
    , Options -> DumpSize
dumpSize :: DumpSize
    }
    deriving (Int -> Options -> ShowS
[Options] -> ShowS
Options -> String
(Int -> Options -> ShowS)
-> (Options -> String) -> ([Options] -> ShowS) -> Show Options
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Options -> ShowS
showsPrec :: Int -> Options -> ShowS
$cshow :: Options -> String
show :: Options -> String
$cshowList :: [Options] -> ShowS
showList :: [Options] -> ShowS
Show)

instance Default Options where
    def :: Options
def =
        Options
            { input :: String
input = String
""
            , isa :: Maybe String
isa = Maybe String
forall a. Maybe a
Nothing
            , configFile :: Maybe String
configFile = Maybe String
forall a. Maybe a
Nothing
            , onlyTranslation :: Bool
onlyTranslation = Bool
False
            , stats :: Bool
stats = Bool
False
            , verbose :: Bool
verbose = Bool
False
            , maxInstructionLimit :: Int
maxInstructionLimit = Int
8000000
            , maxMemoryLimit :: Int
maxMemoryLimit = Int
0xFFFF
            , maxStateLogLimit :: Int
maxStateLogLimit = Int
10000
            , dumpAddrFormat :: AddrFormat
dumpAddrFormat = AddrFormat
Hex
            , dumpSize :: DumpSize
dumpSize = DumpSize
SizeShown
            }

data AddrFormat = Hex | Dec
    deriving (Int -> AddrFormat -> ShowS
[AddrFormat] -> ShowS
AddrFormat -> String
(Int -> AddrFormat -> ShowS)
-> (AddrFormat -> String)
-> ([AddrFormat] -> ShowS)
-> Show AddrFormat
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AddrFormat -> ShowS
showsPrec :: Int -> AddrFormat -> ShowS
$cshow :: AddrFormat -> String
show :: AddrFormat -> String
$cshowList :: [AddrFormat] -> ShowS
showList :: [AddrFormat] -> ShowS
Show)

instance Read AddrFormat where
    readsPrec :: Int -> ReadS AddrFormat
readsPrec Int
_ String
"hex" = [(AddrFormat
Hex, String
"")]
    readsPrec Int
_ String
"dec" = [(AddrFormat
Dec, String
"")]
    readsPrec Int
_ String
_ = []

data DumpSize = SizeShown | SizeHidden
    deriving (Int -> DumpSize -> ShowS
[DumpSize] -> ShowS
DumpSize -> String
(Int -> DumpSize -> ShowS)
-> (DumpSize -> String) -> ([DumpSize] -> ShowS) -> Show DumpSize
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DumpSize -> ShowS
showsPrec :: Int -> DumpSize -> ShowS
$cshow :: DumpSize -> String
show :: DumpSize -> String
$cshowList :: [DumpSize] -> ShowS
showList :: [DumpSize] -> ShowS
Show)

instance Read DumpSize where
    readsPrec :: Int -> ReadS DumpSize
readsPrec Int
_ String
"show" = [(DumpSize
SizeShown, String
"")]
    readsPrec Int
_ String
"hide" = [(DumpSize
SizeHidden, String
"")]
    readsPrec Int
_ String
_ = []

data Result mem w = Result
    { forall mem w. Result mem w -> Text
rTrace :: Text
    , forall mem w. Result mem w -> [Text]
rWarnings :: [Text]
    , forall mem w. Result mem w -> HashMap Text w
rLabels :: HashMap Text w
    , forall mem w. Result mem w -> Bool
rSuccess :: Bool
    , forall mem w. Result mem w -> mem
rDump :: mem
    }
    deriving (Int -> Result mem w -> ShowS
[Result mem w] -> ShowS
Result mem w -> String
(Int -> Result mem w -> ShowS)
-> (Result mem w -> String)
-> ([Result mem w] -> ShowS)
-> Show (Result mem w)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall mem w. (Show w, Show mem) => Int -> Result mem w -> ShowS
forall mem w. (Show w, Show mem) => [Result mem w] -> ShowS
forall mem w. (Show w, Show mem) => Result mem w -> String
$cshowsPrec :: forall mem w. (Show w, Show mem) => Int -> Result mem w -> ShowS
showsPrec :: Int -> Result mem w -> ShowS
$cshow :: forall mem w. (Show w, Show mem) => Result mem w -> String
show :: Result mem w -> String
$cshowList :: forall mem w. (Show w, Show mem) => [Result mem w] -> ShowS
showList :: [Result mem w] -> ShowS
Show)

prettyLabels :: (IsWord w) => (Int -> Text) -> HashMap Text w -> Text
prettyLabels :: forall w. IsWord w => (Int -> Text) -> HashMap Text w -> Text
prettyLabels Int -> Text
showAddr HashMap Text w
rLabels =
    Text -> [Text] -> Text
T.intercalate Text
"\n"
        ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ((Text, w) -> Text) -> [(Text, w)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
l, w
w) -> Int -> Text
showAddr (w -> Int
forall a. Enum a => a -> Int
fromEnum w
w) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":\t" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l)
        ([(Text, w)] -> [Text]) -> [(Text, w)] -> [Text]
forall a b. (a -> b) -> a -> b
$ ((Text, w) -> w) -> [(Text, w)] -> [(Text, w)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Text, w) -> w
forall a b. (a, b) -> b
snd (HashMap Text w -> [(Text, w)]
forall t a b. (IsList t, Item t ~ (a, b)) => t -> [(a, b)]
toPairs HashMap Text w
rLabels)

runWrenchIO :: Options -> IO ()
runWrenchIO :: Options -> IO ()
runWrenchIO opts :: Options
opts@Options{String
input :: Options -> String
input :: String
input, Maybe String
configFile :: Options -> Maybe String
configFile :: Maybe String
configFile, Maybe String
isa :: Options -> Maybe String
isa :: Maybe String
isa, Bool
stats :: Options -> Bool
stats :: Bool
stats, Bool
verbose :: Options -> Bool
verbose :: Bool
verbose, Int
maxInstructionLimit :: Options -> Int
maxInstructionLimit :: Int
maxInstructionLimit, Int
maxMemoryLimit :: Options -> Int
maxMemoryLimit :: Int
maxMemoryLimit} = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Options -> IO ()
forall (m :: * -> *) a. (MonadIO m, Show a) => a -> m ()
pPrint Options
opts
    rawConf <- case Maybe String
configFile of
        Just String
fn ->
            (String -> Config)
-> (Config -> Config) -> Either String Config -> Config
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
                (Text -> Config
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Config) -> (String -> Text) -> String -> Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. ToText a => a -> Text
toText)
                (if Bool
stats then Config -> Config
withExecutionStats else Config -> Config
forall a. a -> a
id)
                (Either String Config -> Config)
-> IO (Either String Config) -> IO Config
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Either String Config)
readConfig String
fn
        Maybe String
Nothing -> Config -> IO Config
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Config
forall a. Default a => a
def
    conf@Config{cLimit, cMemorySize} <- ensureSeed rawConf

    when verbose $ do
        pPrint conf
        putStrLn "---"
    when (cLimit > maxInstructionLimit) $ error "limit too high"
    when (cMemorySize > maxMemoryLimit) $ error "memory size too high"

    src <- (<> "\n") . decodeUtf8 <$> readFileBS input
    resolved <- case isa of
        Just String
name -> IO Isa -> (Isa -> IO Isa) -> Maybe Isa -> IO Isa
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> IO Isa
forall a. Text -> IO a
isaFailure (Text -> IO Isa) -> Text -> IO Isa
forall a b. (a -> b) -> a -> b
$ Text
"unknown isa: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. ToText a => a -> Text
toText String
name) Isa -> IO Isa
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Isa -> IO Isa) -> Maybe Isa -> IO Isa
forall a b. (a -> b) -> a -> b
$ String -> Maybe Isa
forall a. Read a => String -> Maybe a
readMaybe String
name
        Maybe String
Nothing -> case Text -> Either Text Isa
detectIsa (String -> Text
forall a. ToText a => a -> Text
toText String
src) of
            Right Isa
detected -> do
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"detected isa: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Isa -> Text
isaName Isa
detected
                Isa -> IO Isa
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Isa
detected
            Left Text
reason -> Text -> IO Isa
forall a. Text -> IO a
isaFailure (Text -> IO Isa) -> Text -> IO Isa
forall a b. (a -> b) -> a -> b
$ Text
"cannot detect isa (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
reason Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"), pass --isa"
    let opts' = Options
opts{isa = Just $ toString $ isaName resolved}
    case resolved of
        Isa
RiscIv -> forall st (isa_ :: * -> * -> *) w isa1 isa2.
(ByteSize isa1, ByteSize isa2, DerefMnemonic (isa_ w) w,
 InitState st, Inspectable st, IsWord w, IsaOf st ~ isa2,
 Machine st isa2 w, MemOf st ~ IoMem isa2 w,
 Memory (MemOf st) isa2 w, MnemonicParser isa1, Show (isa_ w w),
 WordOf st ~ w, isa1 ~ isa_ w (Ref w), isa2 ~ isa_ w w) =>
[Preprocessor] -> Options -> Config -> String -> IO ()
wrenchIO @(RiscIvSt Int32) [] Options
opts' Config
conf String
src
        Isa
VliwIv -> forall st (isa_ :: * -> * -> *) w isa1 isa2.
(ByteSize isa1, ByteSize isa2, DerefMnemonic (isa_ w) w,
 InitState st, Inspectable st, IsWord w, IsaOf st ~ isa2,
 Machine st isa2 w, MemOf st ~ IoMem isa2 w,
 Memory (MemOf st) isa2 w, MnemonicParser isa1, Show (isa_ w w),
 WordOf st ~ w, isa1 ~ isa_ w (Ref w), isa2 ~ isa_ w w) =>
[Preprocessor] -> Options -> Config -> String -> IO ()
wrenchIO @(VliwIvSt Int32) [] Options
opts' Config
conf String
src
        Isa
F32a -> forall st (isa_ :: * -> * -> *) w isa1 isa2.
(ByteSize isa1, ByteSize isa2, DerefMnemonic (isa_ w) w,
 InitState st, Inspectable st, IsWord w, IsaOf st ~ isa2,
 Machine st isa2 w, MemOf st ~ IoMem isa2 w,
 Memory (MemOf st) isa2 w, MnemonicParser isa1, Show (isa_ w w),
 WordOf st ~ w, isa1 ~ isa_ w (Ref w), isa2 ~ isa_ w w) =>
[Preprocessor] -> Options -> Config -> String -> IO ()
wrenchIO @(F32aSt Int32) [] Options
opts' Config
conf String
src
        Isa
Acc32 -> forall st (isa_ :: * -> * -> *) w isa1 isa2.
(ByteSize isa1, ByteSize isa2, DerefMnemonic (isa_ w) w,
 InitState st, Inspectable st, IsWord w, IsaOf st ~ isa2,
 Machine st isa2 w, MemOf st ~ IoMem isa2 w,
 Memory (MemOf st) isa2 w, MnemonicParser isa1, Show (isa_ w w),
 WordOf st ~ w, isa1 ~ isa_ w (Ref w), isa2 ~ isa_ w w) =>
[Preprocessor] -> Options -> Config -> String -> IO ()
wrenchIO @(Acc32St Int32) [] Options
opts' Config
conf String
src
        Isa
M68k -> forall st (isa_ :: * -> * -> *) w isa1 isa2.
(ByteSize isa1, ByteSize isa2, DerefMnemonic (isa_ w) w,
 InitState st, Inspectable st, IsWord w, IsaOf st ~ isa2,
 Machine st isa2 w, MemOf st ~ IoMem isa2 w,
 Memory (MemOf st) isa2 w, MnemonicParser isa1, Show (isa_ w w),
 WordOf st ~ w, isa1 ~ isa_ w (Ref w), isa2 ~ isa_ w w) =>
[Preprocessor] -> Options -> Config -> String -> IO ()
wrenchIO @(M68kSt Int32) [] Options
opts' Config
conf String
src
        Isa
Wasm32 -> forall st (isa_ :: * -> * -> *) w isa1 isa2.
(ByteSize isa1, ByteSize isa2, DerefMnemonic (isa_ w) w,
 InitState st, Inspectable st, IsWord w, IsaOf st ~ isa2,
 Machine st isa2 w, MemOf st ~ IoMem isa2 w,
 Memory (MemOf st) isa2 w, MnemonicParser isa1, Show (isa_ w w),
 WordOf st ~ w, isa1 ~ isa_ w (Ref w), isa2 ~ isa_ w w) =>
[Preprocessor] -> Options -> Config -> String -> IO ()
wrenchIO @(Wasm32St Int32) [Preprocessor
resolveLocalNames] Options
opts' Config
conf String
src
    where
        isaFailure :: Text -> IO a
        isaFailure :: forall a. Text -> IO a
isaFailure Text
msg = do
            Handle -> String -> IO ()
SIO.hPutStrLn Handle
SIO.stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"error: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. ToString a => a -> String
toString Text
msg
            IO a
forall (m :: * -> *) a. MonadIO m => m a
exitFailure

wrenchIO ::
    forall st isa_ w isa1 isa2.
    ( ByteSize isa1
    , ByteSize isa2
    , DerefMnemonic (isa_ w) w
    , InitState st
    , Inspectable st
    , IsWord w
    , IsaOf st ~ isa2
    , Machine st isa2 w
    , MemOf st ~ IoMem isa2 w
    , Memory (MemOf st) isa2 w
    , MnemonicParser isa1
    , Show (isa_ w w)
    , WordOf st ~ w
    , isa1 ~ isa_ w (Ref w)
    , isa2 ~ isa_ w w
    ) =>
    [Preprocessor]
    -> Options
    -> Config
    -> [Char]
    -> IO ()
wrenchIO :: forall st (isa_ :: * -> * -> *) w isa1 isa2.
(ByteSize isa1, ByteSize isa2, DerefMnemonic (isa_ w) w,
 InitState st, Inspectable st, IsWord w, IsaOf st ~ isa2,
 Machine st isa2 w, MemOf st ~ IoMem isa2 w,
 Memory (MemOf st) isa2 w, MnemonicParser isa1, Show (isa_ w w),
 WordOf st ~ w, isa1 ~ isa_ w (Ref w), isa2 ~ isa_ w w) =>
[Preprocessor] -> Options -> Config -> String -> IO ()
wrenchIO [Preprocessor]
preprocessors opts :: Options
opts@Options{Maybe String
isa :: Options -> Maybe String
isa :: Maybe String
isa, Bool
onlyTranslation :: Options -> Bool
onlyTranslation :: Bool
onlyTranslation, AddrFormat
dumpAddrFormat :: Options -> AddrFormat
dumpAddrFormat :: AddrFormat
dumpAddrFormat, DumpSize
dumpSize :: Options -> DumpSize
dumpSize :: DumpSize
dumpSize} conf :: Config
conf@Config{Int
cMemorySize :: Config -> Int
cMemorySize :: Int
cMemorySize} String
src = do
    -- Translation raises 'error' from pure code (see 'resolveRef'), so catch it here
    -- and report it. 'ExitCode' is not an 'ErrorCall' and still propagates.
    outcome <- forall e a. Exception e => IO a -> IO (Either e a)
try @ErrorCall (IO () -> IO (Either ErrorCall ()))
-> IO () -> IO (Either ErrorCall ())
forall a b. (a -> b) -> a -> b
$ case forall st (isa_ :: * -> * -> *) w isa1 isa2.
(ByteSize isa1, ByteSize isa2, DerefMnemonic (isa_ w) w,
 InitState st, Inspectable st, IsWord w, IsaOf st ~ isa2,
 Machine st isa2 w, MemOf st ~ IoMem isa2 w,
 Memory (MemOf st) isa2 w, MnemonicParser isa1, Show (isa_ w w),
 WordOf st ~ w, isa1 ~ isa_ w (Ref w), isa2 ~ isa_ w w) =>
[Preprocessor]
-> Options
-> Config
-> String
-> Either Text (Result (IntMap (Cell isa2 w)) w)
wrench @st [Preprocessor]
preprocessors Options
opts Config
conf String
src of
        Right Result{HashMap Text w
rLabels :: forall mem w. Result mem w -> HashMap Text w
rLabels :: HashMap Text w
rLabels, Text
rTrace :: forall mem w. Result mem w -> Text
rTrace :: Text
rTrace, [Text]
rWarnings :: forall mem w. Result mem w -> [Text]
rWarnings :: [Text]
rWarnings, Bool
rSuccess :: forall mem w. Result mem w -> Bool
rSuccess :: Bool
rSuccess, IntMap (Cell (isa_ w w) w)
rDump :: forall mem w. Result mem w -> mem
rDump :: IntMap (Cell (isa_ w w) w)
rDump} -> do
            [Text] -> (Text -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
rWarnings ((Text -> IO ()) -> IO ()) -> (Text -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Text
w -> Handle -> String -> IO ()
SIO.hPutStrLn Handle
SIO.stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"warning (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"?" Maybe String
isa String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"): " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. ToString a => a -> String
toString Text
w
            if Bool
onlyTranslation
                then HashMap Text w -> IntMap (Cell (isa_ w w) w) -> IO ()
translationResult HashMap Text w
rLabels IntMap (Cell (isa_ w w) w)
rDump
                else do
                    Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putText Text
rTrace
                    if Bool
rSuccess then IO ()
forall (m :: * -> *) a. MonadIO m => m a
exitSuccess else IO ()
forall (m :: * -> *) a. MonadIO m => m a
exitFailure
        Left Text
e -> Text -> IO ()
wrenchError Text
e
    case outcome of
        Right () -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass
        Left (ErrorCallWithLocation String
msg String
_location) -> Text -> IO ()
wrenchError (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. ToText a => a -> Text
toText String
msg
    where
        addrShow :: Int -> Text
addrShow = case AddrFormat
dumpAddrFormat of
            AddrFormat
Hex -> Int -> Int -> Text
hexAddr (Int -> Int
hexAddrWidth Int
cMemorySize)
            AddrFormat
Dec -> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show
        showSize :: Bool
showSize = case DumpSize
dumpSize of
            DumpSize
SizeShown -> Bool
True
            DumpSize
SizeHidden -> Bool
False
        translationResult :: HashMap Text w -> IntMap (Cell (isa_ w w) w) -> IO ()
translationResult HashMap Text w
rLabels IntMap (Cell (isa_ w w) w)
rDump = do
            Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Text) -> HashMap Text w -> Text
forall w. IsWord w => (Int -> Text) -> HashMap Text w -> Text
prettyLabels Int -> Text
addrShow HashMap Text w
rLabels
            String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
putStrLn String
"---"
            Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putText (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool
-> (Int -> Text)
-> HashMap Text w
-> IntMap (Cell (isa_ w w) w)
-> Text
forall w isa.
(ByteSize isa, IsWord w, Show isa) =>
Bool
-> (Int -> Text) -> HashMap Text w -> IntMap (Cell isa w) -> Text
prettyDump Bool
showSize Int -> Text
addrShow HashMap Text w
rLabels IntMap (Cell (isa_ w w) w)
rDump
        wrenchError :: Text -> IO ()
wrenchError Text
e = do
            Handle -> String -> IO ()
SIO.hPutStrLn Handle
SIO.stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"error (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"?" Maybe String
isa String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"): " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. ToString a => a -> String
toString Text
e
            IO ()
forall (m :: * -> *) a. MonadIO m => m a
exitFailure

wrench ::
    forall st isa_ w isa1 isa2.
    ( ByteSize isa1
    , ByteSize isa2
    , DerefMnemonic (isa_ w) w
    , InitState st
    , Inspectable st
    , IsWord w
    , IsaOf st ~ isa2
    , Machine st isa2 w
    , MemOf st ~ IoMem isa2 w
    , Memory (MemOf st) isa2 w
    , MnemonicParser isa1
    , Show (isa_ w w)
    , WordOf st ~ w
    , isa1 ~ isa_ w (Ref w)
    , isa2 ~ isa_ w w
    ) =>
    [Preprocessor]
    -> Options
    -> Config
    -> String
    -> Either Text (Result (IntMap (Cell isa2 w)) w)
wrench :: forall st (isa_ :: * -> * -> *) w isa1 isa2.
(ByteSize isa1, ByteSize isa2, DerefMnemonic (isa_ w) w,
 InitState st, Inspectable st, IsWord w, IsaOf st ~ isa2,
 Machine st isa2 w, MemOf st ~ IoMem isa2 w,
 Memory (MemOf st) isa2 w, MnemonicParser isa1, Show (isa_ w w),
 WordOf st ~ w, isa1 ~ isa_ w (Ref w), isa2 ~ isa_ w w) =>
[Preprocessor]
-> Options
-> Config
-> String
-> Either Text (Result (IntMap (Cell isa2 w)) w)
wrench [Preprocessor]
preprocessors Options{input :: Options -> String
input = String
fn, Bool
verbose :: Options -> Bool
verbose :: Bool
verbose, Int
maxStateLogLimit :: Options -> Int
maxStateLogLimit :: Int
maxStateLogLimit} Config{Int
cMemorySize :: Config -> Int
cMemorySize :: Int
cMemorySize, Int
cLimit :: Config -> Int
cLimit :: Int
cLimit, Maybe (IntMap ([Int], [Int]))
cMemoryMappedIoFlat :: Maybe (IntMap ([Int], [Int]))
cMemoryMappedIoFlat :: Config -> Maybe (IntMap ([Int], [Int]))
cMemoryMappedIoFlat, Maybe [ReportConf]
cReports :: Maybe [ReportConf]
cReports :: Config -> Maybe [ReportConf]
cReports, Maybe Int
cSeed :: Maybe Int
cSeed :: Config -> Maybe Int
cSeed, Maybe Bool
cZeroMemoryInit :: Maybe Bool
cZeroMemoryInit :: Config -> Maybe Bool
cZeroMemoryInit} String
src = do
    let (StdGen
memoryGen, StdGen
isaGen) = StdGen -> (StdGen, StdGen)
forall g. RandomGen g => g -> (g, g)
Random.split (Int -> StdGen
Random.mkStdGen (Int -> StdGen) -> Int -> StdGen
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
cSeed)
        memoryFillBytes :: [Word8]
memoryFillBytes =
            if Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
cZeroMemoryInit
                then Word8 -> [Word8]
forall a. a -> [a]
repeat Word8
0
                else (Int -> Word8) -> [Int] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Int, Int) -> StdGen -> [Int]
randomInts (Int
0, Int
255) StdGen
memoryGen)
    (warnings, reports) <-
        forall st.
ReportViews st =>
CheckEnv -> [ReportConf] -> Either Text ([Text], [Report st])
compileReports @st
            CheckEnv{ceMemorySize :: Int
ceMemorySize = Int
cMemorySize, ceIoPorts :: [Int]
ceIoPorts = [Int]
-> (IntMap ([Int], [Int]) -> [Int])
-> Maybe (IntMap ([Int], [Int]))
-> [Int]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] IntMap ([Int], [Int]) -> [Int]
forall t a b. (IsList t, Item t ~ (a, b)) => t -> [a]
keys Maybe (IntMap ([Int], [Int]))
cMemoryMappedIoFlat}
            ([ReportConf] -> Maybe [ReportConf] -> [ReportConf]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [ReportConf]
cReports)
    trResult@TranslatorResult{dump, labels} <- translate preprocessors cMemorySize memoryFillBytes fn src

    pc <- maybeToRight "_start label should be defined." (labels !? "_start")
    let mIoStreams = ([Int] -> [w]) -> ([Int] -> [w]) -> ([Int], [Int]) -> ([w], [w])
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ((Int -> w) -> [Int] -> [w]
forall a b. (a -> b) -> [a] -> [b]
map Int -> w
int2mword) ((Int -> w) -> [Int] -> [w]
forall a b. (a -> b) -> [a] -> [b]
map Int -> w
int2mword) (([Int], [Int]) -> ([w], [w]))
-> IntMap ([Int], [Int]) -> IntMap ([w], [w])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IntMap ([Int], [Int])
-> Maybe (IntMap ([Int], [Int])) -> IntMap ([Int], [Int])
forall a. a -> Maybe a -> a
fromMaybe IntMap ([Int], [Int])
forall a. Monoid a => a
mempty Maybe (IntMap ([Int], [Int]))
cMemoryMappedIoFlat
        ioDump = IntMap ([w], [w]) -> Mem (isa_ w w) w -> IoMem (isa_ w w) w
forall w isa.
(ByteSize isa, ByteSizeT w) =>
IntMap ([w], [w]) -> Mem isa w -> IoMem isa w
mkIoMem IntMap ([w], [w])
mIoStreams Mem (isa_ w w) w
dump
        st :: st = initState (fromEnum pc) ioDump isaGen

    (traceLog, finalState) <- powerOn cLimit maxStateLogLimit labels st

    let results = (Report st -> (Bool, Text)) -> [Report st] -> [(Bool, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (TranslatorResult (Mem (isa_ w w) w) (WordOf st)
-> Bool -> st -> [Trace st (IsaOf st)] -> Report st -> (Bool, Text)
forall st mem.
ReportViews st =>
TranslatorResult mem (WordOf st)
-> Bool -> st -> [Trace st (IsaOf st)] -> Report st -> (Bool, Text)
prepareReport TranslatorResult (Mem (isa_ w w) w) w
TranslatorResult (Mem (isa_ w w) w) (WordOf st)
trResult Bool
verbose st
finalState [Trace st (isa_ w w)]
[Trace st (IsaOf st)]
traceLog) [Report st]
reports
        isSuccess = ((Bool, Text) -> Bool) -> [(Bool, Text)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool, Text) -> Bool
forall a b. (a, b) -> a
fst [(Bool, Text)]
results
        reportTexts = ((Bool, Text) -> Text) -> [(Bool, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, Text) -> Text
forall a b. (a, b) -> b
snd [(Bool, Text)]
results

    return $
        Result
            { rTrace = unlines $ map (T.strip . ("---\n" <>)) reportTexts
            , rWarnings = warnings
            , rLabels = labels
            , rSuccess = isSuccess
            , rDump = dumpCells dump
            }
    where
        int2mword :: Int -> w
int2mword Int
x
            | w -> Int
forall a. Enum a => a -> Int
fromEnum (w
forall a. Bounded a => a
minBound :: w) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
x Bool -> Bool -> Bool
&& Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= w -> Int
forall a. Enum a => a -> Int
fromEnum (w
forall a. Bounded a => a
maxBound :: w) =
                Int -> w
forall a. Enum a => Int -> a
toEnum Int
x
            | Unsign w -> Int
forall a. Enum a => a -> Int
fromEnum (Unsign w
forall a. Bounded a => a
minBound :: Unsign w) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
x Bool -> Bool -> Bool
&& Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Unsign w -> Int
forall a. Enum a => a -> Int
fromEnum (Unsign w
forall a. Bounded a => a
maxBound :: Unsign w) =
                Unsign w -> w
forall w. FromSign w => Unsign w -> w
toSign (Unsign w -> w) -> Unsign w -> w
forall a b. (a -> b) -> a -> b
$ Int -> Unsign w
forall a. Enum a => Int -> a
toEnum Int
x
            | Bool
otherwise =
                Text -> w
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> w) -> Text -> w
forall a b. (a -> b) -> a -> b
$ Text
"integer value out of machine word range: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
x

        randomInts :: (Int, Int) -> Random.StdGen -> [Int]
        randomInts :: (Int, Int) -> StdGen -> [Int]
randomInts (Int, Int)
range StdGen
gen =
            let (Int
val, StdGen
gen') = (Int, Int) -> StdGen -> (Int, StdGen)
forall g a. (RandomGen g, UniformRange a) => (a, a) -> g -> (a, g)
Random.uniformR (Int, Int)
range StdGen
gen
             in Int
val Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: (Int, Int) -> StdGen -> [Int]
randomInts (Int, Int)
range StdGen
gen'