diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +# Version [0.1.3.0](https://github.com/DistRap/hocd/compare/0.1.2.0...0.1.3.0) (2024-01-18) + +* Add `registers`, `readReg`, `writeReg` commands +* Add `raw` command (escape hatch) + # Version [0.1.2.0](https://github.com/DistRap/hocd/compare/0.1.1.1...0.1.2.0) (2024-01-03) * Add execution control commands diff --git a/README.lhs b/README.lhs --- a/README.lhs +++ b/README.lhs @@ -17,6 +17,7 @@ ## Example ```haskell +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} import Data.Word (Word32) @@ -28,10 +29,18 @@ -- | For STM32G474 example :: MonadOCD m - => m ([Word32], Word32) + => m ([Word32], Word32, Word32) example = do + -- Note that halting a target is not required + -- for writing or reading memory, only for reading + -- CPU registers halt' + -- Read pc CPU register + pc <- readReg $ regName "pc" + -- Write back same value + writeReg @Word32 (regName "pc") pc + -- Read RCC.CR register rccCr <- readMemCount @Word32 0x40021000 2 @@ -43,7 +52,7 @@ resume - pure (rccCr, r) + pure (rccCr, r, pc) ``` This example is runnable from git repository using: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -17,6 +17,7 @@ ## Example ```haskell +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} import Data.Word (Word32) @@ -28,10 +29,18 @@ -- | For STM32G474 example :: MonadOCD m - => m ([Word32], Word32) + => m ([Word32], Word32, Word32) example = do + -- Note that halting a target is not required + -- for writing or reading memory, only for reading + -- CPU registers halt' + -- Read pc CPU register + pc <- readReg $ regName "pc" + -- Write back same value + writeReg @Word32 (regName "pc") pc + -- Read RCC.CR register rccCr <- readMemCount @Word32 0x40021000 2 @@ -43,7 +52,7 @@ resume - pure (rccCr, r) + pure (rccCr, r, pc) ``` This example is runnable from git repository using: diff --git a/hocd.cabal b/hocd.cabal --- a/hocd.cabal +++ b/hocd.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: hocd -version: 0.1.2.0 +version: 0.1.3.0 synopsis: OpenOCD Haskell interface description: Support for OpenOCDs TCL interface homepage: https://github.com/DistRap/hocd @@ -32,15 +32,17 @@ , HOCD.Command , HOCD.Error , HOCD.Monad + , HOCD.Parse , HOCD.Types build-depends: base >= 4.7 && < 5 + , attoparsec , bytestring + , containers , data-default-class , exceptions , mtl , network , transformers - , text default-language: Haskell2010 executable hocd-read-mem @@ -73,7 +75,11 @@ hspec-discover:hspec-discover build-depends: base >= 4.7 && < 5 , hocd + , attoparsec + , bytestring + , containers , hspec + , raw-strings-qq default-language: Haskell2010 source-repository head diff --git a/src/HOCD/Command.hs b/src/HOCD/Command.hs --- a/src/HOCD/Command.hs +++ b/src/HOCD/Command.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -15,24 +16,27 @@ , Capture(..) , ReadMemory(..) , WriteMemory(..) + , Registers(..) + , ReadRegister(..) + , WriteRegister(..) , Version(..) + , Raw(..) , subChar - , parseMem ) where import Data.Bits (FiniteBits(..)) -import Data.Kind (Type) import Data.ByteString (ByteString) +import Data.Kind (Type) +import Data.Map (Map) import HOCD.Error (OCDError(..)) -import HOCD.Types (MemAddress(..)) +import HOCD.Types (MemAddress(..), RegisterInfo, RegisterName(..)) import Text.Printf (PrintfArg) import qualified Control.Monad +import qualified Data.Attoparsec.ByteString.Char8 import qualified Data.ByteString.Char8 -import qualified Data.Either import qualified Data.List -import qualified Data.Text -import qualified Data.Text.Read +import qualified HOCD.Parse import qualified Text.Printf class Command req where @@ -149,30 +153,14 @@ , Integral a ) => Command (ReadMemory a) where type Reply (ReadMemory a) = [a] - reply _ r = ocdReply r >>= parseMem - -parseMem - :: ( FiniteBits a - , Integral a - ) - => ByteString - -> Either OCDError [a] -parseMem = - (\case - xs | any Data.Either.isLeft xs -> - Left (OCDError_ParseMemory $ Data.Either.lefts xs) - xs | otherwise -> - pure (Data.Either.rights xs) - ) - . map - ( either - (Left . OCDError_CantReadHex) - (pure . fst) - . Data.Text.Read.hexadecimal - . Data.Text.pack - ) - . words - . Data.ByteString.Char8.unpack + reply _ r = + ocdReply r + >>= (\case + Left e -> Left $ OCDError_ParseMemory e + Right rs -> pure rs + ) + . Data.Attoparsec.ByteString.Char8.parseOnly + HOCD.Parse.parseMem data WriteMemory a = WriteMemory { writeMemoryAddr :: MemAddress @@ -207,6 +195,78 @@ type Reply (WriteMemory a) = () reply _ = ocdReply >>= pure . Control.Monad.void +data Registers = Registers + +instance Show Registers where + show = pure "reg" + +instance Command Registers where + type Reply Registers = Map RegisterName RegisterInfo + reply _ r = + ocdReply r + >>= (\case + Left e -> Left $ OCDError_ParseRegisters e + Right rs -> pure rs + ) + . Data.Attoparsec.ByteString.Char8.parseOnly + HOCD.Parse.parseRegisters + +data ReadRegister a = ReadRegister RegisterName + +instance ( FiniteBits a + , Num a + ) => Show (ReadRegister a) where + show (ReadRegister (RegisterName rn)) = + unwords + [ "get_reg" + , Data.ByteString.Char8.unpack rn + ] + +instance ( FiniteBits a + , Integral a + ) => Command (ReadRegister a) where + type Reply (ReadRegister a) = a + reply (ReadRegister rn) r = + ocdReply r + >>= (\case + Left e -> Left $ OCDError_ParseRegisters e + Right rs -> pure rs + ) + . Data.Attoparsec.ByteString.Char8.parseOnly + (HOCD.Parse.parseGetReg rn) + +data WriteRegister a = WriteRegister + { writeRegisterName :: RegisterName + , writeRegisterValue :: a + } + +instance ( FiniteBits a + , Num a + , PrintfArg a + ) => Show (WriteRegister a) where + show WriteRegister{..} = + unwords + [ "set_reg" + , "{" + <> Data.ByteString.Char8.unpack (unRegisterName writeRegisterName) + <> " " + <> Text.Printf.printf "0x%x" writeRegisterValue + <> "}" + ] + +instance ( FiniteBits a + , Integral a + , PrintfArg a + ) => Command (WriteRegister a) where + type Reply (WriteRegister a) = () + reply WriteRegister{..} r = + ocdReply r + >>= (\case + msg | "failed to set" `Data.ByteString.Char8.isPrefixOf` msg + -> Left $ OCDError_FailedToSetRegister writeRegisterName + _ -> pure () + ) + data Version = Version instance Show Version where @@ -214,6 +274,16 @@ instance Command Version where type Reply Version = ByteString + reply _ = ocdReply + +data Raw = Raw ByteString + +instance Show Raw where + show (Raw cmd) = + Data.ByteString.Char8.unpack cmd + +instance Command Raw where + type Reply Raw = ByteString reply _ = ocdReply ocdReply :: ByteString -> Either OCDError ByteString diff --git a/src/HOCD/Error.hs b/src/HOCD/Error.hs --- a/src/HOCD/Error.hs +++ b/src/HOCD/Error.hs @@ -3,11 +3,13 @@ ) where import Data.ByteString (ByteString) +import HOCD.Types (RegisterName) data OCDError = OCDError_ReplyMissingSubOnEnd ByteString - | OCDError_CantReadHex String + | OCDError_FailedToSetRegister RegisterName | OCDError_GetAddrInfoFailed - | OCDError_ParseMemory [OCDError] + | OCDError_ParseMemory String + | OCDError_ParseRegisters String | OCDError_ExpectedOneButGotMore deriving (Eq, Show) diff --git a/src/HOCD/Monad.hs b/src/HOCD/Monad.hs --- a/src/HOCD/Monad.hs +++ b/src/HOCD/Monad.hs @@ -25,7 +25,11 @@ , readMemCount , writeMem , writeMem32 + , registers + , readReg + , writeReg , version + , raw ) where import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) @@ -38,6 +42,7 @@ import Control.Monad.Trans.State (StateT) import Data.Bits (FiniteBits(..)) import Data.ByteString (ByteString) +import Data.Map (Map) import Data.Word (Word32) import HOCD.Command ( Command(..) @@ -49,11 +54,15 @@ , Step(..) , ReadMemory(..) , WriteMemory(..) + , Registers(..) + , ReadRegister(..) + , WriteRegister(..) , Version(..) + , Raw(..) , subChar ) import HOCD.Error (OCDError(..)) -import HOCD.Types (MemAddress) +import HOCD.Types (MemAddress, RegisterInfo, RegisterName) import Network.Socket (Socket) import Text.Printf (PrintfArg) @@ -268,8 +277,51 @@ -> m () writeMem32 = writeMem @Word32 +registers + :: MonadOCD m + => m (Map RegisterName RegisterInfo) +registers = rpc Registers + +-- | Read a CPU register +readReg + :: forall a m + . ( MonadOCD m + , FiniteBits a + , Integral a + ) + => RegisterName -- ^ Name of the register to query + -> m a +readReg = rpc . ReadRegister + +-- | Write a CPU register +writeReg + :: forall a m + . ( MonadOCD m + , FiniteBits a + , Integral a + , PrintfArg a + ) + => RegisterName -- ^ Name of the register to write to + -> a -- ^ Value to write + -> m () +writeReg rn x = + rpc + $ WriteRegister + { writeRegisterName = rn + , writeRegisterValue = x + } + -- | Query OpenOCD version version :: MonadOCD m => m ByteString version = rpc Version + +-- | Send raw OpenOCD command +-- Escape hatch for commands that are not +-- part defined as part of hocd api +raw + :: MonadOCD m + => ByteString + -> m ByteString +raw = rpc . Raw diff --git a/src/HOCD/Parse.hs b/src/HOCD/Parse.hs new file mode 100644 --- /dev/null +++ b/src/HOCD/Parse.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module HOCD.Parse + ( parseMem + , parseRegisters + , parseGetReg + ) where + +import HOCD.Types (RegisterInfo(..), RegisterName(..)) +import Control.Applicative (optional) +import Data.Attoparsec.ByteString.Char8 +import Data.Bits (FiniteBits(..)) +import Data.ByteString (ByteString) +import Data.Map (Map) + +import qualified Data.Map.Strict + +parseMem + :: ( FiniteBits a + , Integral a + ) + => Parser [a] +parseMem = ("0x" *> hexadecimal) `sepBy1` space + +parseRegisters :: Parser (Map RegisterName RegisterInfo) +parseRegisters = + Data.Map.Strict.fromList + . concat + <$> many1 parseRegisterGroups + +parseRegisterGroups :: Parser [(RegisterName, RegisterInfo)] +parseRegisterGroups = do + group <- parseRegisterGroup "Register group" + endOfLine + rgs <- parseRegister group `sepBy1` endOfLine + endOfLine + pure rgs + +parseRegisterGroup :: Parser ByteString +parseRegisterGroup = + ("=====" "Prefix") + *> space + *> takeWhile1 (not . inClass "\n\r") + +parseRegister + :: ByteString + -> Parser (RegisterName, RegisterInfo) +parseRegister group = do + _regId <- "(" *> (decimal :: Parser Int) <* ")" + _ <- space + regName <- RegisterName <$> takeTill isSpace + _ <- space + registerInfoSize <- "(/" *> decimal <* ")" + registerInfoValue <- optional (": 0x" *> hexadecimal) + dirty <- optional " (dirty)" + let + registerInfoDirty = + case dirty of + Nothing -> False + Just _ -> True + registerInfoGroup = group + pure (regName, RegisterInfo{..}) + + <* skipWhile (not . inClass "\n\r") + +parseGetReg + :: ( FiniteBits a + , Integral a + ) + => RegisterName + -> Parser a +parseGetReg (RegisterName rName) = + string rName + *> space + *> "0x" + *> hexadecimal diff --git a/src/HOCD/Types.hs b/src/HOCD/Types.hs --- a/src/HOCD/Types.hs +++ b/src/HOCD/Types.hs @@ -3,10 +3,14 @@ ( MemAddress(..) , memAddr , OCDConfig(..) + , RegisterName(..) + , regName + , RegisterInfo(..) ) where +import Data.ByteString (ByteString) import Data.Default.Class (Default(def)) -import Data.Word (Word32) +import Data.Word (Word8, Word32, Word64) newtype MemAddress = MemAddress { unMemAddress :: Word32 } @@ -28,4 +32,16 @@ , ocdPort = 6666 } +newtype RegisterName = RegisterName + { unRegisterName :: ByteString } + deriving (Eq, Ord, Show) +regName :: ByteString -> RegisterName +regName = RegisterName + +data RegisterInfo = RegisterInfo + { registerInfoSize :: Word8 + , registerInfoValue :: Maybe Word64 + , registerInfoDirty :: Bool + , registerInfoGroup :: ByteString + } deriving (Eq, Ord, Show) diff --git a/test/ParseSpec.hs b/test/ParseSpec.hs --- a/test/ParseSpec.hs +++ b/test/ParseSpec.hs @@ -1,15 +1,83 @@ +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module ParseSpec where +import Data.ByteString (ByteString) import Data.Word (Word32) -import HOCD.Command (parseMem) +import HOCD.Parse (parseGetReg, parseMem, parseRegisters) +import HOCD.Types (RegisterInfo(..), RegisterName(..)) import Test.Hspec (Spec, it, shouldBe) +import Text.RawString.QQ +import qualified Data.Attoparsec.ByteString.Char8 +import qualified Data.Map.Strict + spec :: Spec spec = do it "parses read-memory sample" $ do - parseMem "ABCDFF 001122" + Data.Attoparsec.ByteString.Char8.parseOnly + parseMem + "0xABCDFF 0x001122" `shouldBe` (Right [0xABCDFF, 0x1122 :: Word32]) + it "parses registers sample" $ do + Data.Attoparsec.ByteString.Char8.parseOnly + parseRegisters + regsSample + `shouldBe` + ( Right + $ Data.Map.Strict.fromList + [ ( RegisterName "primask" + , RegisterInfo + { registerInfoSize = 1 + , registerInfoValue = Nothing + , registerInfoDirty = False + , registerInfoGroup = "arm v7m registers" + } + ) + , ( RegisterName "test" + , RegisterInfo + { registerInfoSize = 32 + , registerInfoValue = Nothing + , registerInfoDirty = False + , registerInfoGroup = "Cortex-M DWT registers" + } + ) + , ( RegisterName "r0" + , RegisterInfo + { registerInfoSize = 32 + , registerInfoValue = pure 0x0000D3C2 + , registerInfoDirty = True + , registerInfoGroup = "arm v7m registers" + } + ) + , ( RegisterName "r1" + , RegisterInfo + { registerInfoSize = 32 + , registerInfoValue = pure 0xFD61F31C + , registerInfoDirty = False + , registerInfoGroup = "arm v7m registers" + } + ) + ] + ) + + it "parses get_reg response" $ do + Data.Attoparsec.ByteString.Char8.parseOnly + (parseGetReg (RegisterName "pc")) + "pc 0x1234" + `shouldBe` + Right (0x1234 :: Word32) + + +regsSample :: ByteString +regsSample = [r|===== arm v7m registers +(0) r0 (/32): 0x0000D3C2 (dirty) +(1) r1 (/32): 0xFD61F31C +(20) primask (/1) +===== Cortex-M DWT registers +(123) test (/32) +|]