├── .gitignore ├── .gitlab-ci.yml ├── LICENSE ├── Makefile ├── README.md ├── app └── Main.hs ├── assets ├── 01_repl.png ├── 02_repl.png └── 03_repl.png ├── src └── Language │ ├── X86.hs │ └── X86 │ ├── Assembly.hs │ ├── Interpreter.hs │ ├── Lexer.hs │ ├── PP.hs │ ├── Parser.hs │ └── Run.hs ├── stack.yaml ├── stack.yaml.lock ├── test ├── Main.hs ├── Parser.hs ├── Simple.hs └── Testing.hs └── x86-debug.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | /dist/ 2 | /.cabal-sandbox/ 3 | /cabal.sandbox.config 4 | /dist-newstyle/ 5 | /.stack-work/ 6 | output 7 | 8 | Created by https://www.gitignore.io/api/vim,emacs,osx,haskell 9 | 10 | ### Vim ### 11 | # swap 12 | [._]*.s[a-w][a-z] 13 | [._]s[a-w][a-z] 14 | # session 15 | Session.vim 16 | # temporary 17 | .netrwhist 18 | *~ 19 | # auto-generated tag files 20 | tags 21 | 22 | 23 | ### Emacs ### 24 | # -*- mode: gitignore; -*- 25 | *~ 26 | \#*\# 27 | /.emacs.desktop 28 | /.emacs.desktop.lock 29 | *.elc 30 | auto-save-list 31 | tramp 32 | .\#* 33 | 34 | # Org-mode 35 | .org-id-locations 36 | *_archive 37 | 38 | # flymake-mode 39 | *_flymake.* 40 | 41 | # eshell files 42 | /eshell/history 43 | /eshell/lastdir 44 | 45 | # elpa packages 46 | /elpa/ 47 | 48 | # reftex files 49 | *.rel 50 | 51 | # AUCTeX auto folder 52 | /auto/ 53 | 54 | # cask packages 55 | .cask/ 56 | dist/ 57 | 58 | # Flycheck 59 | flycheck_*.el 60 | 61 | # server auth directory 62 | /server/ 63 | 64 | # projectiles files 65 | .projectile 66 | 67 | ### OSX ### 68 | *.DS_Store 69 | .AppleDouble 70 | .LSOverride 71 | 72 | # Icon must end with two \r 73 | Icon 74 | 75 | 76 | # Thumbnails 77 | ._* 78 | 79 | # Files that might appear in the root of a volume 80 | .DocumentRevisions-V100 81 | .fseventsd 82 | .Spotlight-V100 83 | .TemporaryItems 84 | .Trashes 85 | .VolumeIcon.icns 86 | .com.apple.timemachine.donotpresent 87 | 88 | # Directories potentially created on remote AFP share 89 | .AppleDB 90 | .AppleDesktop 91 | Network Trash Folder 92 | Temporary Items 93 | .apdisk 94 | 95 | 96 | ### Haskell ### 97 | dist 98 | dist-* 99 | cabal-dev 100 | *.o 101 | *.hi 102 | *.chi 103 | *.chs.h 104 | *.dyn_o 105 | *.dyn_hi 106 | .hpc 107 | .hsenv 108 | .cabal-sandbox/ 109 | cabal.sandbox.config 110 | *.prof 111 | *.aux 112 | *.hp 113 | *.eventlog 114 | .stack-work/ 115 | cabal.project.local 116 | 117 | -------------------------------------------------------------------------------- /.gitlab-ci.yml: -------------------------------------------------------------------------------- 1 | # Using https://vadosware.io/post/zero-to-continuous-integrated-testing-a-haskell-project-with-gitlab/ 2 | 3 | 4 | variables: 5 | STACK_ROOT: "${CI_PROJECT_DIR}/.stack" 6 | 7 | cache: 8 | paths: 9 | - .stack 10 | - .stack-work 11 | - target 12 | 13 | before_script: 14 | - apt-get update 15 | - apt-get install make xz-utils 16 | - wget -qO- https://get.haskellstack.org/ | sh 17 | 18 | stages: 19 | - build 20 | - test 21 | 22 | build: 23 | stage: build 24 | script: 25 | - stack build --no-terminal 26 | 27 | unit-test: 28 | stage: test 29 | script: 30 | - stack test --no-terminal 31 | 32 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Gil Mizrahi (c) 2019 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: setup 2 | 3 | setup: 4 | stack setup 5 | 6 | .PHONY: build 7 | 8 | build: 9 | stack build 10 | 11 | .PHONY: dev 12 | 13 | dev: 14 | stack test --fast --test-arguments "-j8 --hide-successes" --file-watch 15 | 16 | .PHONY: test 17 | 18 | test: 19 | stack test --fast --test-arguments "-j8" 20 | 21 | .PHONY: run 22 | 23 | run: 24 | stack exec x86-debug 25 | 26 | 27 | .PHONY: clean 28 | 29 | clean: 30 | stack clean 31 | 32 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # x86-debug 2 | 3 | An emulator/debugger/REPL for a really [small subset](src/Language/X86/Assembly.hs) of x86 assembly. 4 | 5 | Though this subset is enough to be a target for [a simple compiler](https://github.com/soupi/nyanpasu). 6 | 7 | You can read code from a file/stdin, set break points, step forward and backward, etc. 8 | 9 | ### Installation: 10 | 11 | - You'll need [Stack](https://haskellstack.org) 12 | - Clone the repo 13 | - `make build` 14 | - Wait... 15 | - `make run` to launch the repl 16 | 17 | I also suggest using `rlwrap` to get a better REPL experience. 18 | 19 | ![Status](assets/03_repl.png) 20 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Language.X86.Run 4 | 5 | main :: IO () 6 | main = run 7 | -------------------------------------------------------------------------------- /assets/01_repl.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/soupi/x86-debug/248d1a59f92176367b84358d4f8f869cb7096254/assets/01_repl.png -------------------------------------------------------------------------------- /assets/02_repl.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/soupi/x86-debug/248d1a59f92176367b84358d4f8f869cb7096254/assets/02_repl.png -------------------------------------------------------------------------------- /assets/03_repl.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/soupi/x86-debug/248d1a59f92176367b84358d4f8f869cb7096254/assets/03_repl.png -------------------------------------------------------------------------------- /src/Language/X86.hs: -------------------------------------------------------------------------------- 1 | module Language.X86 2 | ( module X86 ) 3 | where 4 | 5 | import Language.X86.Assembly as X86 6 | import Language.X86.Interpreter as X86 7 | import Language.X86.Parser as X86 8 | import Language.X86.PP as X86 9 | 10 | -------------------------------------------------------------------------------- /src/Language/X86/Assembly.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE DeriveGeneric, DeriveAnyClass, DeriveDataTypeable, BangPatterns #-} 3 | 4 | module Language.X86.Assembly where 5 | 6 | import Data.Foldable (foldl') 7 | import Data.Data 8 | import GHC.Generics 9 | import Control.DeepSeq 10 | 11 | import Data.Int (Int32) 12 | import Data.Maybe (mapMaybe) 13 | import qualified Data.Sequence as S 14 | import qualified Data.Map as M 15 | import qualified Data.Set as Set 16 | 17 | data Code = Code 18 | { cCode :: S.Seq Line 19 | , cLabelMap :: M.Map Label Int32 20 | , cLabelMapOrig :: M.Map Label Int32 21 | , cBreakpoints :: Set.Set Int32 22 | } 23 | deriving (Show, Read, Eq, Ord, Data, Typeable, Generic, NFData) 24 | 25 | 26 | data Line = Line 27 | { lineAnn :: !Int32 28 | , lineInst :: !Instruction 29 | } 30 | deriving (Show, Read, Eq, Ord, Data, Typeable, Generic, NFData) 31 | 32 | -- | The Instruction type 33 | -- represents an x86 assembly instruction 34 | data Instruction 35 | = IMov !Arg !Arg 36 | | IAdd !Arg !Arg 37 | | ISub !Arg !Arg 38 | | ICmp !Arg !Arg 39 | | IXor !Arg !Arg 40 | | IAnd !Arg !Arg 41 | | IOr !Arg !Arg 42 | | IShl !Arg !Arg 43 | | IShr !Arg !Arg 44 | | ISar !Arg !Arg 45 | | ISal !Arg !Arg 46 | | ITest !Arg !Arg 47 | | IMul !Arg 48 | | Label !Label 49 | | IJmp !Address 50 | | IJe !Address 51 | | IJne !Address 52 | | IJnz !Address 53 | | IJz !Address 54 | | IJge !Address 55 | | ICall !Address 56 | | IPush !Arg 57 | | IPop !Arg 58 | | IRet 59 | | IHalt 60 | deriving (Show, Read, Eq, Ord, Data, Typeable, Generic, NFData) 61 | 62 | type Label = String 63 | 64 | data AddressVar 65 | = AL Label 66 | | AR Reg 67 | deriving (Show, Read, Eq, Ord, Data, Typeable, Generic, NFData) 68 | 69 | type Address = ArithExpr AddressVar 70 | 71 | -- | The Arg type 72 | -- represents an x86 assembly argument to an instruction 73 | data Arg 74 | = Ref !Arg 75 | | AE !(ArithExpr Reg) 76 | | AEL !Address 77 | deriving (Show, Read, Eq, Ord, Data, Typeable, Generic, NFData) 78 | 79 | data ArithExpr var 80 | = Lit !Int32 81 | | Var !var 82 | | Add !(ArithExpr var) !(ArithExpr var) 83 | | Mul !(ArithExpr var) !(ArithExpr var) 84 | | Sub !(ArithExpr var) !(ArithExpr var) 85 | deriving (Show, Read, Eq, Ord, Data, Typeable, Generic, NFData) 86 | 87 | -- | The Reg type 88 | -- represents an x86 assembly register 89 | data Reg 90 | = EAX 91 | | EBX 92 | | ECX 93 | | EDX 94 | | ESP 95 | | EBP 96 | | ESI 97 | | EIP 98 | deriving (Show, Read, Eq, Ord, Generic, NFData, Data, Typeable, Bounded, Enum) 99 | 100 | 101 | -- | x86 flags 102 | -- Description taken from: http://unixwiz.net/techtips/x86-jumps.html 103 | data Flag 104 | = CF -- ^ carry flag: Set on high-order bit carry or borrow; cleared otherwise 105 | | ZF -- ^ zero flags: Set if result is zero; cleared otherwise 106 | | SF -- ^ sign flag: Set equal to high-order bit of result (0 if positive 1 if negative) 107 | | OF -- ^ overflow flag: Set if result is too large a positive number or too small a negative number (excluding sign bit) to fit in destination operand; cleared otherwise 108 | -- | PF -- ^ parity flag: Set if low-order eight bits of result contain an even number of "1" bits; cleared otherwise 109 | deriving (Show, Read, Eq, Ord, Generic, NFData, Data, Typeable) 110 | 111 | 112 | 113 | data Loc 114 | = LocReg Reg 115 | | LocMem Int32 116 | deriving (Show, Read, Eq, Ord, Generic, NFData, Data, Typeable) 117 | 118 | 119 | toCode :: [Label] -> [Instruction] -> Code 120 | toCode breaks insts = Code 121 | { cCode = 122 | S.fromList 123 | . reverse 124 | . (Line lastNum IHalt:) 125 | $ rInstructions 126 | , cLabelMap = labelmap 127 | , cLabelMapOrig = labelmap 128 | , cBreakpoints = Set.fromList $ 129 | mapMaybe (`M.lookup` labelmap) breaks 130 | } 131 | where 132 | (labelmap, rInstructions, lastNum) = foldl' go (M.empty, [], 0) insts 133 | go (labels, rLines, num) = \case 134 | Label l -> 135 | (M.insert l num labels, rLines, num) 136 | inst -> 137 | (labels, Line num inst : rLines, num + 1) 138 | -------------------------------------------------------------------------------- /src/Language/X86/Interpreter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, DeriveAnyClass, DeriveDataTypeable, BangPatterns #-} 2 | {-# LANGUAGE LambdaCase, MultiWayIf, NamedFieldPuns #-} 3 | 4 | module Language.X86.Interpreter where 5 | 6 | import qualified Data.Sequence as S 7 | import qualified Data.Vector as V 8 | import qualified Data.Map as M 9 | import qualified Data.Set as Set 10 | 11 | import Data.Int (Int32) 12 | import Data.Bits 13 | import Data.Maybe 14 | import Data.Data 15 | import GHC.Generics 16 | import Control.DeepSeq 17 | import Control.Monad 18 | 19 | import Language.X86.Assembly 20 | 21 | -- import Debug.Trace 22 | 23 | 24 | ----------- 25 | -- Types -- 26 | ----------- 27 | 28 | type State = [Machine] 29 | 30 | data Machine = Machine 31 | { mMem :: V.Vector Int32 32 | , mRegs :: M.Map Reg Int32 33 | , mFlags :: M.Map Flag Bool 34 | , mCode :: Code 35 | } 36 | deriving (Show, Read, Eq, Ord, Data, Typeable, Generic, NFData) 37 | 38 | evalArith :: (ref -> Either Error Int32) -> ArithExpr ref -> Either Error Int32 39 | evalArith lookupVar = \case 40 | Lit i -> pure i 41 | Var var -> lookupVar var 42 | Add e1 e2 -> (+) <$> evalArith lookupVar e1 <*> evalArith lookupVar e2 43 | Sub e1 e2 -> (-) <$> evalArith lookupVar e1 <*> evalArith lookupVar e2 44 | Mul e1 e2 -> (*) <$> evalArith lookupVar e1 <*> evalArith lookupVar e2 45 | 46 | data Error 47 | = Error Machine String (Maybe Line) ErrorType 48 | deriving (Show, Read, Eq, Ord, Data, Typeable, Generic, NFData) 49 | 50 | data ErrorType 51 | = StackOverflow 52 | | StackUnderflow 53 | | DivByZero 54 | | LabelNotFound Label 55 | | InvalidMem Int32 56 | | InvalidDest (ArithExpr Reg) 57 | | InstructionNotFound Int32 58 | | UnexpectedNoMachine 59 | | UnexpectedInstruction 60 | | Unexpected String 61 | deriving (Show, Read, Eq, Ord, Data, Typeable, Generic, NFData) 62 | 63 | throwError :: String -> Machine -> ErrorType -> Either Error a 64 | throwError f m = Left . Error m f mline 65 | where 66 | mline = either (const Nothing) Just $ getInstLine m 67 | 68 | ---------------- 69 | -- Evaluators -- 70 | ---------------- 71 | 72 | isBreakpoint :: Machine -> Either Error Bool 73 | isBreakpoint m = do 74 | lineNum <- lineAnn <$> getInstLine m 75 | pure $ 76 | let 77 | lineNum' = (fromIntegral (length $ mMem m) * 4 + 4 * lineNum) 78 | in 79 | lineNum' `elem` cBreakpoints (mCode m) 80 | 81 | isHalt :: Machine -> Either Error Bool 82 | isHalt m = (==IHalt) <$> getInstruction m 83 | 84 | evalArg :: Machine -> Arg -> Either Error Int32 85 | evalArg m = \case 86 | AE e -> evalArith (pure . flip getReg m) e 87 | Ref arg -> do 88 | i <- evalArg m arg 89 | getMem i m 90 | AEL e -> evalArith (flip getAddr m) e 91 | 92 | evalLoc :: Machine -> Arg -> Either Error Loc 93 | evalLoc m = \case 94 | AE (Var r) -> pure $ LocReg r 95 | AE e -> throwError "evalLoc" m $ InvalidDest e 96 | arg' -> LocMem <$> evalDest arg' 97 | where 98 | evalDest :: Arg -> Either Error Int32 99 | evalDest = \case 100 | AE e -> evalArith (pure . flip getReg m) e 101 | Ref arg -> do 102 | evalDest arg 103 | AEL e -> evalArith (flip getAddr m) e 104 | 105 | 106 | stepForward :: Machine -> Either Error Machine 107 | stepForward machine@Machine{} = 108 | getInstruction machine >>= {- pure . traceShowId >>= -} \case 109 | Label{} -> throwError "stepForward" machine UnexpectedInstruction 110 | IHalt -> pure machine 111 | IMov dest src -> 112 | next =<< applyDestSrc Nothing (flip const) dest src machine 113 | IAdd dest src -> 114 | next =<< applyDestSrc (Just $ \x y -> x + y > fromIntegral (maxBound :: Int32) || (x + y < fromIntegral (minBound :: Int32))) (+) dest src machine 115 | ISub dest src -> 116 | next =<< applyDestSrc (Just $ \x y -> x - y > fromIntegral (maxBound :: Int32) || (x - y < fromIntegral (minBound :: Int32))) (-) dest src machine 117 | IAnd dest src -> 118 | next =<< applyDestSrc Nothing (.&.) dest src machine 119 | IOr dest src -> 120 | next =<< applyDestSrc Nothing (.|.) dest src machine 121 | IXor dest src -> 122 | next =<< applyDestSrc Nothing xor dest src machine 123 | ISal dest src -> 124 | next =<< applyDestSrc Nothing (\x y -> shiftL x (fromIntegral y)) dest src machine 125 | ISar dest src -> 126 | next =<< applyDestSrc Nothing (\x y -> shiftR x (fromIntegral y)) dest src machine 127 | IShl dest src -> 128 | next =<< applyDestSrc Nothing (\x y -> shiftL (clearBit x 31) (fromIntegral y)) dest src machine 129 | IShr dest src -> 130 | next =<< applyDestSrc Nothing (\x y -> shiftR (clearBit x 31) (fromIntegral y)) dest src machine 131 | IMul src -> do 132 | v <- evalArg machine src 133 | next $ overReg EAX (*v) machine 134 | ICmp dest src -> do 135 | evalDestSrc dest src machine >>= \case 136 | (LocReg r, v) -> do 137 | let rv = getReg r machine 138 | let (rv', v') = (fromIntegral rv, fromIntegral v :: Integer) 139 | next 140 | . setFlag CF (rv < v) 141 | . setFlag SF (0 > rv - v) 142 | . setFlag OF (rv' - v' > fromIntegral (maxBound :: Int32) || (rv' - v' < fromIntegral (minBound :: Int32))) 143 | . setFlag ZF (rv == v) 144 | $ machine 145 | (LocMem i, v) -> do 146 | mv <- getMem i machine 147 | next $ setFlag ZF (mv == v) machine 148 | ITest dest src -> do 149 | evalDestSrc dest src machine >>= \case 150 | (LocReg r, v) -> do 151 | let rv = getReg r machine 152 | next $ setFlag ZF (rv .&. v == 0) machine 153 | (LocMem i, v) -> do 154 | mv <- getMem i machine 155 | next $ setFlag ZF (mv .&. v == 0) machine 156 | IJmp address -> 157 | setAddress address machine 158 | IJz address -> do 159 | if getFlag ZF machine 160 | then 161 | setAddress address machine 162 | else 163 | next machine 164 | IJnz address -> do 165 | if not (getFlag ZF machine) 166 | then 167 | setAddress address machine 168 | else 169 | next machine 170 | IJe address -> do 171 | if getFlag ZF machine 172 | then 173 | setAddress address machine 174 | else 175 | next machine 176 | IJne address -> do 177 | if not (getFlag ZF machine) 178 | then 179 | setAddress address machine 180 | else 181 | next machine 182 | IJge address -> do 183 | if getFlag SF machine == getFlag OF machine 184 | then 185 | setAddress address machine 186 | else 187 | next machine 188 | 189 | IPop dest -> 190 | next 191 | <=< checkStack 192 | . overReg ESP (\v -> v + 4) 193 | <=< applyDestSrc Nothing (flip const) dest (Ref $ AE $ Var ESP) 194 | $ machine 195 | 196 | IPush src -> do 197 | next 198 | <=< applyDestSrc Nothing (flip const) (Ref $ AE $ Var ESP) src 199 | <=< checkStack 200 | . overReg ESP (\v -> v - 4) 201 | $ machine 202 | 203 | ICall addr -> do 204 | setAddress addr 205 | <=< applyDestSrc Nothing (flip const) (Ref $ AE $ Var ESP) (AE $ Add (Var EIP) (Lit 4)) 206 | <=< checkStack 207 | . overReg ESP (\v -> v - 4) 208 | $ machine 209 | 210 | IRet -> do 211 | checkStack 212 | . (overReg ESP (\v -> v + 4)) 213 | <=< (applyDestSrc Nothing (flip const) (AE $ Var EIP) (Ref $ AE $ Var ESP)) 214 | $ machine 215 | 216 | data Status 217 | = Halted 218 | | Cont 219 | deriving Show 220 | 221 | interpretStep :: State -> Either Error (Status, State) 222 | interpretStep !state = do 223 | !machine <- getMachine state 224 | getInstruction machine >>= \case 225 | IHalt -> pure (Halted, state) 226 | _ -> do 227 | m' <- stepForward machine 228 | pure (Cont, (m' : state)) 229 | 230 | interpret :: State -> (Maybe Error, State) 231 | interpret !state = 232 | case interpretStep state of 233 | Left err -> (pure err, state) 234 | Right (Halted, s') -> (Nothing, s') 235 | Right (Cont, s') -> interpret s' 236 | 237 | interpretBreak :: State -> (Maybe Error, State) 238 | interpretBreak !state = do 239 | case interpretStep state >>= \s' -> (,s') <$> getMachine (snd s') of 240 | Left err -> (pure err, state) 241 | Right (_, (Halted, s')) -> (Nothing, s') 242 | Right (m', (Cont, s')) -> 243 | if getReg EIP m' `elem` cBreakpoints (mCode m') 244 | then 245 | (Nothing, s') 246 | else 247 | interpretBreak (m' : state) 248 | 249 | getLabelLineNum :: Label -> Machine -> Maybe Int32 250 | getLabelLineNum lbl Machine{mCode} = 251 | M.lookup lbl (cLabelMapOrig mCode) 252 | 253 | addBreakpoint :: Label -> Machine -> Either String Machine 254 | addBreakpoint lbl machine@Machine{mCode} = 255 | case M.lookup lbl (cLabelMap mCode) of 256 | Just i 257 | | i `notElem` cBreakpoints mCode -> 258 | pure $ machine 259 | { mCode = 260 | mCode 261 | { cBreakpoints = i `Set.insert` cBreakpoints mCode 262 | } 263 | } 264 | _ -> 265 | Left "Could not find label." 266 | 267 | addBreakpointLine :: Int32 -> Machine -> Either String Machine 268 | addBreakpointLine lineNum machine@Machine{mCode, mMem} 269 | | lineNum > 0 && fromIntegral lineNum < length (cCode mCode) = 270 | let 271 | lineNum' = (fromIntegral (length mMem) * 4 + 4 * lineNum) 272 | in if 273 | | lineNum' `notElem` cBreakpoints mCode -> 274 | pure machine 275 | { mCode = 276 | mCode 277 | { cBreakpoints = 278 | Set.insert 279 | lineNum' 280 | (cBreakpoints mCode) 281 | } 282 | } 283 | | otherwise -> 284 | Left "Breakpoint already set." 285 | | otherwise = Left "Invalid line number." 286 | 287 | 288 | removeBreakpoint :: Label -> Machine -> Machine 289 | removeBreakpoint lbl machine@Machine{mCode} = 290 | case M.lookup lbl (cLabelMap mCode) of 291 | Just i -> 292 | machine 293 | { mCode = 294 | mCode 295 | { cBreakpoints = i `Set.delete` cBreakpoints mCode 296 | } 297 | } 298 | _ -> 299 | machine 300 | 301 | 302 | removeBreakpointLine :: Int32 -> Machine -> Either String Machine 303 | removeBreakpointLine lineNum machine@Machine{mCode, mMem} 304 | | lineNum > 0 && fromIntegral lineNum < length (cCode mCode) = 305 | let 306 | lineNum' = (fromIntegral (length mMem) * 4 + 4 * lineNum) 307 | in if 308 | | lineNum' `elem` cBreakpoints mCode -> 309 | pure machine 310 | { mCode = 311 | mCode 312 | { cBreakpoints = 313 | Set.delete 314 | lineNum' 315 | (cBreakpoints mCode) 316 | } 317 | } 318 | | otherwise -> 319 | Left "Breakpoint does not exist." 320 | | otherwise = Left "Invalid line number." 321 | 322 | ----------- 323 | -- Utils -- 324 | ----------- 325 | 326 | initMachine :: Code -> Machine 327 | initMachine code = Machine 328 | { mRegs = M.fromList 329 | [ (EIP, memSize * 4) 330 | , (ESP, memSize * 4 - 4*4) 331 | ] 332 | , mMem = V.replicate memSize 0 333 | , mFlags = M.empty 334 | , mCode = code 335 | { cLabelMap = 336 | fmap ((memSize * 4 +) . (4*)) $ cLabelMap code 337 | , cBreakpoints = 338 | Set.map ((memSize * 4 +) . (4*)) $ cBreakpoints code 339 | } 340 | } 341 | where 342 | memSize :: forall a. Integral a => a 343 | memSize = 400 344 | 345 | --------------- 346 | -- Accessors -- 347 | --------------- 348 | 349 | getMachine :: State -> Either Error Machine 350 | getMachine = \case 351 | m:_ -> pure m 352 | _ -> throwError "getMachine" undefined UnexpectedNoMachine 353 | 354 | getInstruction :: Machine -> Either Error Instruction 355 | getInstruction machine = lineInst <$> getInstLine machine 356 | 357 | getInstLine :: Machine -> Either Error Line 358 | getInstLine machine = do 359 | let eip = getReg EIP machine 360 | ip <- evalCodeIndex eip machine 361 | maybe 362 | (throwError "getInstruction" machine $ InvalidMem eip) 363 | pure 364 | (S.lookup (fromIntegral ip) (cCode $ mCode machine)) 365 | 366 | getAddr :: AddressVar -> Machine -> Either Error Int32 367 | getAddr = \case 368 | AR reg -> pure . fromMaybe 0 . M.lookup reg . mRegs 369 | AL lbl -> \m -> 370 | maybe 371 | (throwError "getAddr" m $ Unexpected $ "Unknown label: " ++ show lbl) 372 | pure 373 | . M.lookup lbl . cLabelMap . mCode 374 | $ m 375 | 376 | 377 | getReg :: Reg -> Machine -> Int32 378 | getReg reg = fromMaybe 0 . M.lookup reg . mRegs 379 | 380 | setReg :: Reg -> Int32 -> Machine -> Machine 381 | setReg reg val machine = 382 | machine { mRegs = M.alter (const $ Just val) reg (mRegs machine) } 383 | 384 | overReg :: Reg -> (Int32 -> Int32) -> Machine -> Machine 385 | overReg reg f machine = 386 | machine { mRegs = M.alter (Just . f . fromMaybe 0) reg (mRegs machine) } 387 | 388 | getFlag :: Flag -> Machine -> Bool 389 | getFlag flag = fromMaybe False . M.lookup flag . mFlags 390 | 391 | setFlag :: Flag -> Bool -> Machine -> Machine 392 | setFlag flag val machine = 393 | machine { mFlags = M.alter (const $ Just val) flag (mFlags machine) } 394 | 395 | overFlag :: Flag -> (Bool -> Bool) -> Machine -> Machine 396 | overFlag flag f machine = 397 | machine { mFlags = M.alter (Just . f . fromMaybe False) flag (mFlags machine) } 398 | 399 | getMem :: Int32 -> Machine -> Either Error Int32 400 | getMem i m = do 401 | index <- evalMemIndex i m 402 | pure $ mMem m V.! index 403 | 404 | setMem :: Int32 -> Int32 -> Machine -> Either Error Machine 405 | setMem i val machine = do 406 | index <- evalMemIndex i machine 407 | pure $ machine { mMem = mMem machine V.// [(fromIntegral index, val)] } 408 | 409 | overMem :: Int32 -> (Int32 -> Int32) -> Machine -> Either Error Machine 410 | overMem i f machine = do 411 | index <- evalMemIndex i machine 412 | pure $ machine 413 | { mMem = 414 | mMem machine 415 | V.// [(fromIntegral index, f $ mMem machine V.! fromIntegral index)] 416 | } 417 | 418 | --- 419 | 420 | next :: Machine -> Either Error Machine 421 | next = pure . overReg EIP (+4) 422 | 423 | evalDestSrc :: Arg -> Arg -> Machine -> Either Error (Loc, Int32) 424 | evalDestSrc dest src state = 425 | (,) <$> evalLoc state dest <*> evalArg state src 426 | 427 | applyDestSrc 428 | :: Maybe (Int32 -> Int32 -> Bool) 429 | -> (Int32 -> Int32 -> Int32) -> Arg -> Arg -> Machine -> Either Error Machine 430 | applyDestSrc setOFIf f dest src machine = 431 | let 432 | setFlags v1 v2 = maybe 433 | id 434 | (\test -> setFlag OF (test v1 v2)) 435 | setOFIf 436 | in evalDestSrc dest src machine >>= \case 437 | (LocReg r, v) -> do 438 | let vr = getReg r machine 439 | pure 440 | . setFlags vr v 441 | $ overReg r (`f` v) machine 442 | (LocMem i, v) -> do 443 | vm <- getMem i machine 444 | pure . setFlags vm v =<< overMem i (`f` v) machine 445 | 446 | getStack :: Machine -> Either Error (V.Vector Int32) 447 | getStack m = do 448 | si <- evalMemIndex (getReg ESP m) m 449 | pure $ V.slice si (length (mMem m) - si) (mMem m) 450 | 451 | evalIndex :: Integral a => (Machine -> Int32) -> Int32 -> Machine -> Either Error a 452 | evalIndex len i m = do 453 | index <- 454 | if 455 | | i == 0 -> 456 | pure 0 457 | | i `mod` 4 == 0 -> 458 | pure $ i `div` 4 459 | | otherwise -> 460 | throwError "evalIndex" m $ InvalidMem i 461 | 462 | if 463 | | index < 0 -> 464 | throwError "evalIndex2" m $ InvalidMem index 465 | | index >= len m -> 466 | throwError "evalIndex3" m $ InvalidMem index 467 | | otherwise -> 468 | pure $ fromIntegral index 469 | 470 | 471 | evalMemIndex :: Integral a => Int32 -> Machine -> Either Error a 472 | evalMemIndex = evalIndex (fromIntegral . length . mMem) 473 | 474 | evalCodeIndex :: Integral a => Int32 -> Machine -> Either Error a 475 | evalCodeIndex i m = 476 | evalIndex 477 | (fromIntegral . length . cCode . mCode) 478 | (i - fromIntegral (4 * (length $ mMem m))) 479 | m 480 | 481 | setAddress :: Address -> Machine -> Either Error Machine 482 | setAddress address machine = 483 | flip (setReg EIP) machine 484 | <$> evalArith (flip lookupAddrVar machine) address 485 | where 486 | lookupAddrVar var m = case var of 487 | AR r -> pure $ getReg r m 488 | AL l -> case M.lookup l . cLabelMap . mCode $ m of 489 | Nothing -> 490 | throwError "lookupAddrVar" m $ LabelNotFound l 491 | Just addr -> 492 | pure addr 493 | 494 | 495 | 496 | checkStack :: Machine -> Either Error Machine 497 | checkStack m 498 | | getReg ESP m >= 4 * fromIntegral (length $ mMem m) = 499 | throwError "checkStack:UF" m $ StackUnderflow 500 | | getReg ESP m < 0 = 501 | throwError "checkStack:OF" m $ StackOverflow 502 | | otherwise = 503 | pure m 504 | 505 | secondF :: Functor f => (b -> f c) -> (a, b) -> f (a, c) 506 | secondF f (a, b) = (a,) <$> f b 507 | 508 | mToE :: (Maybe a, b) -> Either a b 509 | mToE (a, b) = case a of 510 | Nothing -> Right b 511 | Just e -> Left e 512 | -------------------------------------------------------------------------------- /src/Language/X86/Lexer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | 3 | module Language.X86.Lexer where 4 | 5 | import Data.Void 6 | import Control.Arrow ((&&&), first) 7 | import Data.Data (showConstr, toConstr, dataTypeConstrs, dataTypeOf) 8 | import Data.Char (toUpper, toLower) 9 | import Data.Functor 10 | import Control.Applicative ((<|>)) 11 | 12 | import Language.X86.Assembly 13 | 14 | import qualified Text.Megaparsec as Prs 15 | import qualified Text.Megaparsec.Char.Lexer as Lex 16 | import qualified Text.Megaparsec.Char as Prs 17 | 18 | type Parser = Prs.Parsec Void String 19 | 20 | -- | Defining what is considered a space to consume 21 | spaceConsumer :: Parser () 22 | spaceConsumer = Lex.space (Prs.skipSome (void Prs.tab <|> void (Prs.char ' '))) lineCmnt blockCmnt 23 | where 24 | lineCmnt = Lex.skipLineComment ";" 25 | blockCmnt = Lex.skipBlockCommentNested "/*" "*/" 26 | 27 | lexeme :: Parser a -> Parser a 28 | lexeme = Lex.lexeme spaceConsumer 29 | 30 | many1 :: Parser a -> Parser [a] 31 | many1 p = (:) <$> p <*> Prs.many p 32 | 33 | symbol :: String -> Parser String 34 | symbol = lexeme . Lex.symbol spaceConsumer 35 | 36 | -- | 'integer' parses an integer 37 | integer :: Parser Integer 38 | integer = lexeme $ 39 | (((Prs.char '-') $> negate) <|> pure id) 40 | <*> ((Prs.try (Prs.char '0' *> Prs.char 'x') *> Lex.hexadecimal) 41 | <|> Lex.decimal 42 | ) 43 | 44 | -- | strings 45 | string :: Parser String 46 | string = lexeme $ Prs.char '"' >> Prs.manyTill Lex.charLiteral (Prs.char '"') 47 | 48 | -- | char 49 | char :: Parser Char 50 | char = lexeme $ Prs.char '\'' *> Lex.charLiteral <* Prs.char '\'' 51 | 52 | rword :: String -> Parser () 53 | rword w = Prs.string w *> Prs.notFollowedBy Prs.alphaNumChar *> spaceConsumer 54 | 55 | -- | list of reserved words 56 | reservedWords :: [String] 57 | reservedWords = 58 | map (map toLower) instructions 59 | ++ map (map toUpper) instructions 60 | 61 | instructions :: [String] 62 | instructions = 63 | map tail 64 | . filter (\(c:_) -> c == 'I') 65 | . map showConstr 66 | . dataTypeConstrs 67 | . dataTypeOf @Instruction 68 | $ undefined 69 | 70 | registers :: [(String, Reg)] 71 | registers = 72 | regs ++ map (first (map toLower)) regs 73 | where 74 | regs = 75 | map 76 | (showConstr . toConstr &&& id @Reg) 77 | [minBound..maxBound] 78 | 79 | -- | identifiers 80 | identifier :: Parser String 81 | identifier = lexeme (many1 chara >>= check) 82 | where 83 | check x = if x `elem` reservedWords 84 | then fail $ "instruction " ++ show x ++ " cannot be an identifier" 85 | else pure x 86 | chara = Prs.alphaNumChar <|> Prs.oneOf ("/_-" :: String) 87 | 88 | 89 | 90 | -- | 'parens' parses something between parenthesis 91 | parens :: Parser a -> Parser a 92 | parens = Prs.between (symbol "(") (symbol ")") 93 | 94 | braces, angles, brackets :: Parser a -> Parser a 95 | braces = Prs.between (symbol "{") (symbol "}") 96 | angles = Prs.between (symbol "<") (symbol ">") 97 | brackets = Prs.between (symbol "[") (symbol "]") 98 | 99 | semicolon, comma, colon, dot, equals, arrow, lambda, tilda :: Parser String 100 | semicolon = symbol ";" 101 | comma = symbol "," 102 | colon = symbol ":" 103 | dot = symbol "." 104 | equals = symbol "=" 105 | arrow = symbol "->" 106 | lambda = symbol "\\" 107 | tilda = symbol "~" 108 | -------------------------------------------------------------------------------- /src/Language/X86/PP.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE DeriveGeneric, DeriveAnyClass, DeriveDataTypeable #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | 5 | module Language.X86.PP where 6 | 7 | import Data.Char (toLower) 8 | import Data.Data 9 | import Data.Foldable as F 10 | import GHC.Generics 11 | import Control.DeepSeq 12 | import Data.List 13 | import qualified Data.Map as M 14 | import qualified Data.Sequence as Seq 15 | 16 | import Language.X86.Assembly 17 | 18 | 19 | 20 | 21 | -- | Output 22 | newtype Assembly = Assembly String 23 | deriving (Eq, Ord, Generic, NFData, Data, Typeable) 24 | 25 | instance Show Assembly where 26 | show (Assembly asmStr) = asmStr 27 | 28 | ----------------- 29 | -- PP Assembly -- 30 | ----------------- 31 | 32 | -- | Pretty print Code to an assembly string of instructions 33 | ppCode :: Code -> String 34 | ppCode code = 35 | unlines 36 | . map ppInstruction 37 | . F.toList 38 | . F.foldl' 39 | (\acc (lbl, line) -> 40 | Seq.insertAt (fromIntegral line) (Label lbl) acc 41 | ) 42 | (fmap lineInst $ cCode code) 43 | . reverse 44 | . sortOn snd 45 | $ M.toList (cLabelMapOrig code) 46 | 47 | -- | Pretty print a list of instructions to an assembly string 48 | ppAsm :: [Instruction] -> String 49 | ppAsm = unlines . map ppInstruction 50 | 51 | -- | Pretty print an instruction to an assembly string 52 | ppInstruction :: Instruction -> String 53 | ppInstruction = \case 54 | IMov dest src -> 55 | ppOp "mov" dest src 56 | IAdd dest src -> 57 | ppOp "add" dest src 58 | ISub dest src -> 59 | ppOp "sub" dest src 60 | IMul dest -> 61 | "mul " <> ppArg dest 62 | IXor dest src -> 63 | ppOp "xor" dest src 64 | IAnd dest src -> 65 | ppOp "and" dest src 66 | IOr dest src -> 67 | ppOp "or" dest src 68 | ICmp dest src -> 69 | ppOp "cmp" dest src 70 | ITest dest src -> 71 | ppOp "test" dest src 72 | IShr dest src -> 73 | ppOp "shr" dest src 74 | ISar dest src -> 75 | ppOp "sar" dest src 76 | IShl dest src -> 77 | ppOp "shl" dest src 78 | ISal dest src -> 79 | ppOp "sal" dest src 80 | IJmp lbl -> 81 | "jmp " <> ppAddress lbl 82 | IJe lbl -> 83 | "je " <> ppAddress lbl 84 | IJne lbl -> 85 | "jne " <> ppAddress lbl 86 | IJnz lbl -> 87 | "jnz " <> ppAddress lbl 88 | IJz lbl -> 89 | "jz " <> ppAddress lbl 90 | IJge lbl -> 91 | "jge " <> ppAddress lbl 92 | Label lbl -> 93 | lbl <> ":" 94 | IRet -> 95 | "ret" 96 | ICall lbl -> 97 | "call " <> ppAddress lbl 98 | IPush arg -> 99 | "push " <> ppArg arg 100 | IPop arg -> 101 | "pop " <> ppArg arg 102 | IHalt -> 103 | "" 104 | 105 | -- | Pretty print a label 106 | ppAddress :: Address -> String 107 | ppAddress = ppAE $ \case 108 | AL l -> l 109 | AR r -> show r 110 | 111 | -- | Pretty print an operation with two arguments 112 | ppOp :: String -> Arg -> Arg -> String 113 | ppOp cmd dest src = 114 | unwords 115 | [ cmd 116 | , ppArg dest <> "," 117 | , ppArg src 118 | ] 119 | 120 | -- | Pretty print an argument 121 | ppArg :: Arg -> String 122 | ppArg = \case 123 | Ref a -> "[" ++ ppArg a ++ "]" 124 | AE a -> ppAE show a 125 | AEL a -> ppAE show a 126 | 127 | -- | Pretty print an argument 128 | ppAE :: (var -> String) -> ArithExpr var -> String 129 | ppAE ppVar e = go (normalizeAE e) 130 | where 131 | go = \case 132 | Neg v -> "-" <> pp v 133 | Pos v -> pp v 134 | pp = \case 135 | Lit i -> show i 136 | Var v -> ppVar v 137 | Add e1 e2 -> pp e1 <> " + " <> pp e2 138 | Sub e1 e2 -> pp e1 <> " - " <> pp e2 139 | Mul e1 e2 -> pp e1 <> "*" <> pp e2 140 | 141 | normalizeAE :: ArithExpr var -> Sign (ArithExpr var) 142 | normalizeAE = \case 143 | Lit i 144 | | i < 0 && i > minBound -> Neg $ Lit $ 0 - i 145 | | otherwise -> Pos $ Lit i 146 | Var v -> Pos $ Var v 147 | Add e1 e2 -> 148 | case (normalizeAE e1, normalizeAE e2) of 149 | (Neg v1, Pos v2) -> Pos $ Sub v2 v1 150 | (Pos v1, Neg v2) -> Pos $ Sub v1 v2 151 | (Pos v1, Pos v2) -> Pos $ Add v1 v2 152 | (Neg v1, Neg v2) -> Neg $ Sub v1 v2 153 | Sub e1 e2 -> 154 | case (normalizeAE e1, normalizeAE e2) of 155 | (Neg v1, Pos v2) -> Neg $ Sub v1 v2 156 | (Pos v1, Neg v2) -> Pos $ Add v1 v2 157 | (Pos v1, Pos v2) -> Pos $ Sub v1 v2 158 | (Neg v1, Neg v2) -> Pos $ Sub v2 v1 159 | Mul e1 e2 -> 160 | case (normalizeAE e1, normalizeAE e2) of 161 | (Neg v1, Pos v2) -> Neg $ Mul v1 v2 162 | (Pos v1, Neg v2) -> Neg $ Mul v2 v1 163 | (Pos v1, Pos v2) -> Pos $ Mul v1 v2 164 | (Neg v1, Neg v2) -> Pos $ Mul v1 v2 165 | 166 | data Sign v 167 | = Neg v 168 | | Pos v 169 | deriving Functor 170 | 171 | -- | Pretty print a register 172 | ppReg :: Reg -> String 173 | ppReg = map toLower . show 174 | -------------------------------------------------------------------------------- /src/Language/X86/Parser.hs: -------------------------------------------------------------------------------- 1 | 2 | module Language.X86.Parser 3 | ( parsePrint 4 | , parseCode 5 | , parseCodeLine 6 | , parseErrorPretty 7 | ) 8 | where 9 | 10 | import Control.Monad 11 | import Control.Applicative 12 | import Data.Void 13 | import Text.Groom 14 | 15 | import qualified Text.Megaparsec as Prs 16 | import qualified Text.Megaparsec.Char as Prs 17 | import qualified Control.Monad.Combinators.Expr as Prs 18 | 19 | import Language.X86.Assembly 20 | import Language.X86.Lexer 21 | 22 | parseErrorPretty :: Prs.ParseErrorBundle String Void -> String 23 | parseErrorPretty = Prs.errorBundlePretty 24 | 25 | parseCode :: String -> String -> Either (Prs.ParseErrorBundle String Void) [Instruction] 26 | parseCode src content = 27 | Prs.parse (concat <$> many1 (parseInstWithLabel <* lexeme Prs.eol)) src (content ++ "\n") 28 | 29 | parseCodeLine :: String -> String -> Either (Prs.ParseErrorBundle String Void) [Instruction] 30 | parseCodeLine src content = Prs.parse parseLine src (content ++ "\n") 31 | 32 | parseLine :: Parser [Instruction] 33 | parseLine = parseInstWithLabel <* lexeme Prs.eol 34 | 35 | parse :: Parser a -> String -> String -> Either (Prs.ParseErrorBundle String Void) a 36 | parse parser srcName content = 37 | Prs.parse (parser <* Prs.eof) srcName content 38 | 39 | parsePrint :: Show a => Parser a -> String -> IO () 40 | parsePrint p = putStrLn . either parseErrorPretty groom . parse p "test" 41 | 42 | parseLabel :: Parser Instruction 43 | parseLabel = 44 | fmap Label identifier <* colon 45 | 46 | parseArg :: Parser Arg 47 | parseArg = 48 | (Ref <$> brackets parseArg) 49 | <|> (AE <$> parseArithExpr parseReg) 50 | 51 | parseArithExpr :: Parser var -> Parser (ArithExpr var) 52 | parseArithExpr pvar = expr pvar 53 | 54 | parseReg :: Parser Reg 55 | parseReg = 56 | msum (map (\(s,c) -> symbol s *> pure c) registers) 57 | 58 | parseAddress :: Parser Address 59 | parseAddress = parseArithExpr parseAddressVar 60 | 61 | parseAddressVar :: Parser AddressVar 62 | parseAddressVar = 63 | (AR <$> Prs.try parseReg) 64 | <|> fmap AL identifier 65 | 66 | parseBinInstruction :: Parser (Arg -> Arg -> Instruction) 67 | parseBinInstruction = 68 | (IMov <$ (rword "mov" <|> rword "MOV" )) 69 | <|> (IAdd <$ (rword "add" <|> rword "ADD" )) 70 | <|> (ISub <$ (rword "sub" <|> rword "SUB" )) 71 | <|> (ICmp <$ (rword "cmp" <|> rword "CMP" )) 72 | <|> (IXor <$ (rword "xor" <|> rword "XOR" )) 73 | <|> (IAnd <$ (rword "and" <|> rword "AND" )) 74 | <|> (IOr <$ (rword "or" <|> rword "OR" )) 75 | <|> (IShl <$ (rword "shl" <|> rword "SHL" )) 76 | <|> (IShr <$ (rword "shr" <|> rword "SHR" )) 77 | <|> (ISar <$ (rword "sar" <|> rword "SAR" )) 78 | <|> (ISal <$ (rword "sal" <|> rword "SAL" )) 79 | <|> (ITest <$ (rword "test" <|> rword "TEST")) 80 | 81 | parseJmps :: Parser (Address -> Instruction) 82 | parseJmps = 83 | (IJmp <$ (rword "jmp" <|> rword "JMP" )) 84 | <|> (IJe <$ (rword "je" <|> rword "JE" )) 85 | <|> (IJne <$ (rword "jne" <|> rword "JNE" )) 86 | <|> (IJnz <$ (rword "jnz" <|> rword "JNZ" )) 87 | <|> (IJz <$ (rword "jz" <|> rword "JZ" )) 88 | <|> (IJge <$ (rword "jge" <|> rword "JGE" )) 89 | <|> (ICall <$ (rword "call" <|> rword "CALL" )) 90 | 91 | parseInstruction :: Parser Instruction 92 | parseInstruction = 93 | (parseBinInstruction <*> (parseArg <* comma) <*> parseArg) 94 | <|> (parseJmps <*> parseAddress) 95 | <|> (IMul <$ (rword "mul" <|> rword "MUL" ) <*> parseArg) 96 | <|> (IPush <$ (rword "push" <|> rword "PUSH" ) <*> parseArg) 97 | <|> (IPop <$ (rword "pop" <|> rword "POP" ) <*> parseArg) 98 | <|> (IRet <$ (rword "ret" <|> rword "RET" )) 99 | 100 | parseInstWithLabel :: Parser [Instruction] 101 | parseInstWithLabel = do 102 | Prs.try ((:) <$> parseLabel <*> (parseInstWithLabel <|> fmap pure parseInstruction <|> fmap pure (parseLabel <* lexeme Prs.eol))) 103 | <|> (fmap pure parseInstruction <|> fmap pure parseLabel) 104 | 105 | expr :: Parser var -> Parser (ArithExpr var) 106 | expr pvar = Prs.makeExprParser (term pvar) table 107 | 108 | term :: Parser var -> Parser (ArithExpr var) 109 | term pvar = 110 | parens (expr pvar) 111 | <|> fmap (Lit . fromIntegral) integer 112 | <|> fmap Var pvar 113 | 114 | table :: [[Prs.Operator Parser (ArithExpr a)]] 115 | table = 116 | [ [ binary "*" Mul ] 117 | , [ binary "+" Add 118 | , binary "-" Sub 119 | ] 120 | ] 121 | 122 | binary :: String 123 | -> ((ArithExpr a) -> (ArithExpr a) -> (ArithExpr a)) 124 | -> Prs.Operator Parser (ArithExpr a) 125 | binary name f = Prs.InfixL (f <$ symbol name) 126 | -------------------------------------------------------------------------------- /src/Language/X86/Run.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | 3 | module Language.X86.Run where 4 | 5 | import Language.X86 6 | 7 | import Prelude hiding (break) 8 | import Data.Int (Int32) 9 | import Data.Char 10 | import Data.Maybe 11 | import Data.Functor 12 | import Data.Foldable 13 | import Data.Bifunctor 14 | import Data.Traversable 15 | import Control.Applicative 16 | import Control.Exception (catch, SomeException(..)) 17 | import System.Exit 18 | import System.IO 19 | import Text.Groom 20 | 21 | run :: IO () 22 | run = do 23 | putStrLn hello 24 | hSetBuffering stdout NoBuffering 25 | repl NoState 26 | putStrLn "Bye!" 27 | 28 | 29 | hello :: String 30 | hello = unlines $ 31 | [ "x86-debug - a (subset of) x86 debugger" 32 | , "Type ? for help" 33 | ] 34 | 35 | help :: String 36 | help = unlines $ 37 | "Available commands are:\n" 38 | : map (("* " ++) . fst) commands' 39 | 40 | data ReplState 41 | = NoState 42 | | ReplMachineState State 43 | | Done 44 | deriving Show 45 | 46 | repl :: ReplState -> IO () 47 | repl s = do 48 | putStr "> " 49 | words <$> getLine >>= \case 50 | [] -> repl s 51 | cmd:args -> case lookup cmd commands of 52 | Nothing -> do 53 | hPutStrLn stderr $ "Command not understood: '" ++ cmd ++ "'." 54 | repl s 55 | Just command -> do 56 | rs <- command args s 57 | case rs of 58 | Done -> pure () 59 | _ -> repl rs 60 | 61 | commands :: [(String, [String] -> ReplState -> IO ReplState)] 62 | commands = 63 | commands' 64 | ++ map (first (':':)) commands' 65 | ++ map (first $ (:[]) . head) commands' 66 | ++ map (first $ (\x -> [':',x]) . head) commands' 67 | 68 | commands' :: [(String, [String] -> ReplState -> IO ReplState)] 69 | commands' = 70 | [ ( "quit" 71 | , const $ const $ pure Done 72 | ) 73 | 74 | , ( "help" 75 | , \_ s -> do 76 | putStrLn help 77 | pure s 78 | ) 79 | 80 | , ( "?" 81 | , \_ s -> do 82 | putStrLn help 83 | pure s 84 | ) 85 | 86 | , ( "init" 87 | , const $ initReplMachineState 88 | ) 89 | 90 | , ( "code" 91 | , \_ s -> s <$ printCode s 92 | ) 93 | 94 | , ( "line" 95 | , \_ s -> s <$ printLine s 96 | ) 97 | 98 | , ( "regs" 99 | , \args s -> s <$ readReg args s 100 | ) 101 | 102 | , ( "reg" 103 | , \args s -> s <$ readReg args s 104 | ) 105 | 106 | , ( "next" 107 | , const $ 108 | let 109 | doStep s = case interpretStep s of 110 | Right (_, s') -> (Nothing, s') 111 | Left err -> (pure err, s) 112 | in runNext doStep 113 | ) 114 | 115 | , ( "step" 116 | , const $ runNext interpretBreak 117 | ) 118 | 119 | , ( "run" 120 | , const $ runNext interpret 121 | ) 122 | 123 | , ( "prev" 124 | , const $ runPrev 125 | ) 126 | 127 | , ( "previous" 128 | , const $ runPrev 129 | ) 130 | 131 | , ( "break" 132 | , handleBreak addBreakpointLine "added" "adding" 133 | ) 134 | 135 | , ( "unbreak" 136 | , handleBreak removeBreakpointLine "delete" "deleting" 137 | ) 138 | 139 | 140 | , ( "begin" 141 | , \_ s -> case s of 142 | ReplMachineState ms@(_:_) -> 143 | pure $ ReplMachineState [last ms] 144 | _ -> do 145 | hPutStrLn stderr "You need to init the machine first." 146 | pure s 147 | ) 148 | 149 | , ( "mem" 150 | , \_ s -> do 151 | case s of 152 | ReplMachineState (m':_) -> do 153 | print $ mMem m' 154 | _ -> do 155 | hPutStrLn stderr "You need to init the machine first." 156 | pure s 157 | ) 158 | 159 | , ( "stack" 160 | , \_ s -> flip catch (\(SomeException e) -> print e $> s) $ do 161 | case s of 162 | ReplMachineState (m':_) -> do 163 | case getStack m' of 164 | Left err -> 165 | hPutStrLn stderr (show err) 166 | Right stack -> 167 | print stack 168 | _ -> do 169 | hPutStrLn stderr "You need to init the machine first." 170 | pure s 171 | ) 172 | 173 | , ( "machines" 174 | , \_ s -> do 175 | putStrLn $ groom s 176 | pure s 177 | ) 178 | 179 | , ( "file" 180 | , parseFile 181 | ) 182 | ] 183 | 184 | parseFile :: [FilePath] -> ReplState -> IO ReplState 185 | parseFile args state = do 186 | catch 187 | (do 188 | case args of 189 | [file] -> do 190 | codeStr <- readFile file 191 | case parseCode "repl" codeStr of 192 | Left er -> do 193 | hPutStrLn stderr (parseErrorPretty er) 194 | pure state 195 | Right code -> do 196 | putStrLn "Code parsed successfully. To view it type 'code'." 197 | pure $ ReplMachineState [initMachine $ toCode [] code] 198 | xs -> do 199 | hPutStrLn stderr ("Expecting one filepath argument, but got: " ++ show (length xs)) 200 | pure state 201 | 202 | ) 203 | (\(SomeException e) -> do 204 | hPutStrLn stderr (show e) 205 | pure state 206 | ) 207 | 208 | 209 | initReplMachineState :: ReplState -> IO ReplState 210 | initReplMachineState s = do 211 | putStrLn "Please enter code. To mark you are done write 'done'. " 212 | maybeCode <- readCode 213 | case maybeCode of 214 | Nothing -> do 215 | hPutStrLn stderr "Failed to parse code. Reverting to last state." 216 | pure s 217 | Just code -> do 218 | putStrLn "Code parsed successfully. To view it type 'code'." 219 | pure $ ReplMachineState [initMachine code] 220 | 221 | readCode :: IO (Maybe Code) 222 | readCode = do 223 | go [] >>= \case 224 | [] -> do 225 | putStrLn "Doing nothing." 226 | pure Nothing 227 | code -> 228 | pure $ Just $ toCode [] code 229 | 230 | where 231 | go code = do 232 | putStr "...> " 233 | getLine >>= \case 234 | "quit" -> do 235 | putStrLn "Bye!" 236 | exitSuccess 237 | "discard" -> 238 | pure [] 239 | "done" -> 240 | pure $ concat $ reverse code 241 | line -> do 242 | case parseCodeLine "repl" line of 243 | Right c -> go (c : code) 244 | Left er -> do 245 | hPutStrLn stderr ("*** Error: Failed to read line.\n" ++ parseErrorPretty er) 246 | go code 247 | 248 | 249 | printCode :: ReplState -> IO ReplState 250 | printCode s = do 251 | case s of 252 | Done -> pure () 253 | NoState -> 254 | hPutStrLn stderr "No code to show yet. Use 'init' to insert code." 255 | ReplMachineState state -> case state of 256 | [] -> 257 | hPutStrLn stderr "No state available. Use 'init' to insert code." 258 | Machine{mCode} : _ -> 259 | putStrLn 260 | . ppCode 261 | $ mCode 262 | 263 | pure s 264 | 265 | printLine :: ReplState -> IO ReplState 266 | printLine s = do 267 | case s of 268 | Done -> pure () 269 | NoState -> 270 | hPutStrLn stderr "No code to show yet. Use 'init' to insert code." 271 | ReplMachineState state -> case state of 272 | [] -> 273 | hPutStrLn stderr "No state available. Use 'init' to insert code." 274 | m : _ -> do 275 | case getInstLine m of 276 | Left (Error _ str _ errtype) -> do 277 | hPutStrLn stderr $ unwords 278 | [ "*** Error in " 279 | , show str 280 | , show errtype 281 | ] 282 | Right line -> 283 | putStrLn $ concat 284 | [ show $ lineAnn line 285 | , ":" 286 | , ppInstruction $ lineInst line 287 | ] 288 | 289 | pure s 290 | 291 | readReg :: [String] -> ReplState -> IO ReplState 292 | readReg rs s = do 293 | case (map (map toUpper) rs, s) of 294 | (_, Done) -> pure () 295 | (_, NoState) -> 296 | hPutStrLn stderr "You need to init the machine first." 297 | (_, ReplMachineState []) -> 298 | hPutStrLn stderr "Invalid state." 299 | ([], _) -> 300 | hPutStrLn stderr "No registers requested." 301 | (regs, ReplMachineState (machine:_)) -> do 302 | let results = map (\reg -> (reg,) $ (`getReg` machine) <$> readMaybe reg) regs 303 | forM_ results $ \(reg, result) -> 304 | putStrLn 305 | $ reg ++ " = " ++ 306 | case result of 307 | Nothing -> 308 | "Unknown register" 309 | Just v -> 310 | show v 311 | pure s 312 | 313 | 314 | readMaybe :: Read a => String -> Maybe a 315 | readMaybe s = case reads s of 316 | [(a, "")] -> Just a 317 | _ -> Nothing 318 | 319 | trim :: String -> String 320 | trim = unwords . words 321 | 322 | runNext :: (State -> (Maybe Error, State)) -> ReplState -> IO ReplState 323 | runNext runner = \case 324 | NoState -> do 325 | hPutStrLn stderr "You need to init a machine first." 326 | pure NoState 327 | 328 | ReplMachineState [] -> do 329 | hPutStrLn stderr "Invalid state. Setting to no state." 330 | pure NoState 331 | 332 | ReplMachineState machines@(machine:_) -> do 333 | case (isHalt machine, runner machines) of 334 | (Right True, _) -> do 335 | putStrLn "Already halted." 336 | pure $ ReplMachineState machines 337 | 338 | (_, (Nothing, m')) -> do 339 | case (,) <$> isHalt (head m') <*> isBreakpoint (head m') of 340 | Right (True, _) -> 341 | putStrLn "Halted." 342 | Right (False, True) -> do 343 | putStrLn $ "Breakpoint reached." 344 | printLine (ReplMachineState m') $> () 345 | _ -> 346 | printLine (ReplMachineState m') $> () 347 | pure $ ReplMachineState m' 348 | 349 | (_, (Just (Error _ str _ errtype), m')) -> do 350 | hPutStrLn stderr $ unwords 351 | [ "*** Error in " 352 | , show str 353 | , show errtype 354 | ] 355 | pure $ ReplMachineState m' 356 | 357 | s -> pure s 358 | 359 | runPrev :: ReplState -> IO ReplState 360 | runPrev = \case 361 | NoState -> do 362 | hPutStrLn stderr "You need to init a machine first." 363 | pure NoState 364 | ReplMachineState [] -> do 365 | hPutStrLn stderr "Invalid state. Setting to no state." 366 | pure NoState 367 | ReplMachineState machines@(_:[]) -> do 368 | putStrLn "Already at the beginning." 369 | _ <- printLine (ReplMachineState machines) 370 | pure $ ReplMachineState machines 371 | ReplMachineState (_:rest) -> do 372 | _ <- printLine (ReplMachineState rest) 373 | pure $ ReplMachineState rest 374 | s -> pure s 375 | 376 | 377 | handleBreak :: (Int32 -> Machine -> Either [Char] Machine) 378 | -> String -> String -> [String] -> ReplState -> IO ReplState 379 | handleBreak handle addrmed addrming bps s = 380 | case (bps, s) of 381 | (_, Done) -> pure s 382 | (_, NoState) -> do 383 | hPutStrLn stderr "You need to init the machine first." 384 | pure s 385 | (_, ReplMachineState []) -> do 386 | hPutStrLn stderr "Invalid state." 387 | pure s 388 | ([], _) -> do 389 | hPutStrLn stderr "No breakpoints requested." 390 | pure s 391 | (_, ReplMachineState machines@(machine:_)) -> do 392 | let breaks = map (\b -> (b, readBreakpoint machine b)) bps 393 | forM_ breaks $ \(break, line) -> do 394 | case line of 395 | Just _ -> pure () 396 | Nothing -> 397 | hPutStrLn stderr $ "Unknown breakpoint: " ++ break 398 | let possiblebreaks = filter (isJust . snd) breaks 399 | (catMaybes -> truebreaks) <- 400 | forM possiblebreaks $ \(break, Just line) -> 401 | case handle line machine of 402 | Right _ -> do 403 | putStrLn $ "Breakpoint " ++ addrmed ++ " at line: " ++ show line ++ "." 404 | pure $ Just line 405 | Left err -> do 406 | hPutStrLn stderr $ "Error " ++ addrming ++ " breakpoint " ++ break ++ ": " ++ err 407 | pure $ Nothing 408 | 409 | if null truebreaks 410 | then 411 | pure $ ReplMachineState machines 412 | else 413 | pure $ ReplMachineState 414 | [ either (const m) id $ handle l m 415 | | m <- machines 416 | , l <- truebreaks 417 | ] 418 | 419 | readBreakpoint :: Machine -> String -> Maybe Int32 420 | readBreakpoint machine b = 421 | (readMaybe (map toUpper b) >>= pure . flip getReg machine) 422 | <|> readMaybe b 423 | <|> getLabelLineNum b machine 424 | 425 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-18.18 2 | 3 | packages: 4 | - '.' 5 | 6 | extra-deps: [] 7 | 8 | flags: {} 9 | 10 | extra-package-dbs: [] 11 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 586296 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/18.yaml 11 | sha256: 63539429076b7ebbab6daa7656cfb079393bf644971156dc349d7c0453694ac2 12 | original: lts-18.18 13 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Testing 4 | import qualified Simple 5 | import qualified Parser 6 | 7 | main :: IO () 8 | main = defaultMain tests 9 | 10 | tests :: TestTree 11 | tests = 12 | testGroup 13 | "Tests" 14 | [ Simple.tests 15 | , Parser.tests 16 | ] 17 | -------------------------------------------------------------------------------- /test/Parser.hs: -------------------------------------------------------------------------------- 1 | module Parser where 2 | 3 | import Language.X86 4 | 5 | import Testing 6 | import Simple 7 | 8 | 9 | tests :: TestTree 10 | tests = 11 | testGroup "Parser" $ 12 | mconcat 13 | [ zipWith (\n t -> testCase ("Simple " ++ show n) t) [1..] $ map ppParsePPparse simple 14 | , zipWith (\n t -> testCase ("Jumps " ++ show n) t) [1..] $ map ppParsePPparse jumps 15 | , zipWith (\n t -> testCase ("Stack " ++ show n) t) [1..] $ map ppParsePPparse stack 16 | , zipWith (\n t -> testCase ("Calls " ++ show n) t) [1..] $ map ppParsePPparse calls 17 | ] 18 | 19 | ppParsePPparse (snd -> insts) = 20 | case ppppp of 21 | Right _ -> pure () 22 | Left er -> 23 | errorWithoutStackTrace $ 24 | "Test failed to parse: " ++ parseErrorPretty er 25 | where 26 | ppppp = do 27 | i' <- parseCode "test1" (ppAsm insts) 28 | parseCode "test2" (ppAsm i') 29 | pure () 30 | 31 | 32 | -------------------------------------------------------------------------------- /test/Simple.hs: -------------------------------------------------------------------------------- 1 | 2 | module Simple where 3 | 4 | import Data.Int 5 | import Testing 6 | 7 | import Language.X86 8 | 9 | tests :: TestTree 10 | tests = 11 | testGroup "Simple" $ 12 | mconcat 13 | [ zipWith (\n t -> testProperty ("QuickCheck " ++ show n) t) [1..] qc 14 | , zipWith (\n t -> testCase ("Simple " ++ show n) t) [1..] $ map apply simple 15 | , zipWith (\n t -> testCase ("Jumps " ++ show n) t) [1..] $ map apply jumps 16 | , zipWith (\n t -> testCase ("Stack " ++ show n) t) [1..] $ map apply stack 17 | , zipWith (\n t -> testCase ("Calls " ++ show n) t) [1..] $ map apply calls 18 | ] 19 | 20 | qc :: [(Int32 -> Bool)] 21 | qc = 22 | [] 23 | 24 | apply = uncurry ($) 25 | 26 | simple :: [([Instruction] -> Assertion, [Instruction])] 27 | simple = 28 | [ ( testReg EAX 7 29 | , [ IMov (AE $ Var EAX) (AE $ Lit 7) 30 | ] 31 | ) 32 | , ( testReg EAX 7 33 | , [ IMov (AE $ Var EAX) (AE $ Lit 5) 34 | , IAdd (AE $ Var EAX) (AE $ Lit 2) 35 | ] 36 | ) 37 | , ( testReg EAX 7 38 | , [ IMov (AE $ Var EAX) (AE $ Lit 9) 39 | , ISub (AE $ Var EAX) (AE $ Lit 2) 40 | ] 41 | ) 42 | , ( testReg EAX 4 43 | , [ IMov (AE $ Var EAX) (AE $ Lit 5) 44 | , IMov (AE $ Var EBX) (AE $ Lit 4) 45 | , IAnd (AE $ Var EAX) (AE $ Var EBX) 46 | ] 47 | ) 48 | , ( testReg EAX 7 49 | , [ IMov (AE $ Var EAX) (AE $ Lit 5) 50 | , IMov (AE $ Var EBX) (AE $ Lit 2) 51 | , IXor (AE $ Var EAX) (AE $ Var EBX) 52 | ] 53 | ) 54 | , ( testReg EAX 5 55 | , [ IMov (AE $ Var EAX) (AE $ Lit 1) 56 | , IMov (AE $ Var EBX) (AE $ Lit 5) 57 | , IOr (AE $ Var EAX) (AE $ Var EBX) 58 | ] 59 | ) 60 | , ( testReg EAX 7 61 | , [ IMov (AE $ Var EAX) (AE $ Lit 14) 62 | , ISar (AE $ Var EAX) (AE $ Lit 1) 63 | ] 64 | ) 65 | , ( testReg EAX 14 66 | , [ IMov (AE $ Var EAX) (AE $ Lit 7) 67 | , ISal (AE $ Var EAX) (AE $ Lit 1) 68 | ] 69 | ) 70 | , ( testReg EAX 15 71 | , [ IMov (AE $ Var EAX) (AE $ Lit 3) 72 | , IMul (AE $ Lit 5) 73 | ] 74 | ) 75 | , ( testFlag ZF True 76 | , [ IMov (AE $ Var EAX) (AE $ Lit 7) 77 | , IMov (AE $ Var EBX) (AE $ Lit 7) 78 | , ICmp (AE $ Var EAX) (AE $ Var EBX) 79 | ] 80 | ) 81 | , ( testFlag ZF True 82 | , [ IMov (AE $ Var EAX) (AE $ Lit 5) 83 | , IMov (AE $ Var EBX) (AE $ Lit 2) 84 | , ITest (AE $ Var EAX) (AE $ Var EBX) 85 | ] 86 | ) 87 | , ( testFlag ZF False 88 | , [ IMov (AE $ Var EAX) (AE $ Lit 7) 89 | , IMov (AE $ Var EBX) (AE $ Lit 8) 90 | , ICmp (AE $ Var EAX) (AE $ Var EBX) 91 | ] 92 | ) 93 | ] 94 | 95 | 96 | jumps :: [([Instruction] -> Assertion, [Instruction])] 97 | jumps = 98 | [ ( testReg EAX 7 99 | , [ IMov (AE $ Var EAX) (AE $ Lit 6) 100 | , IJmp $ Var $ AL "after" 101 | , IMov (AE $ Var EAX) (AE $ Lit 1) 102 | , IJmp $ Var $ AL "end" 103 | , Label "after" 104 | , IAdd (AE $ Var EAX) (AE $ Lit 1) 105 | , Label "end" 106 | ] 107 | ) 108 | , ( testReg EBX 7 109 | , [ ICmp (AE $ Var EAX) (AE $ Lit 0) 110 | , IJz $ Var $ AL "after" 111 | , IMov (AE $ Var EBX) (AE $ Lit 6) 112 | , IJmp $ Var $ AL "end" 113 | , Label "after" 114 | , IMov (AE $ Var EBX) (AE $ Lit 7) 115 | , Label "end" 116 | ] 117 | ) 118 | 119 | -- JGE 120 | , ( testReg EBX 7 121 | , [ ICmp (AE $ Var EAX) (AE $ Lit 0) 122 | , IJge $ Var $ AL "after" 123 | , IMov (AE $ Var EBX) (AE $ Lit 6) 124 | , IJmp $ Var $ AL "end" 125 | , Label "after" 126 | , IMov (AE $ Var EBX) (AE $ Lit 7) 127 | , Label "end" 128 | ] 129 | ) 130 | , ( testReg EBX 7 131 | , [ ICmp (AE $ Var EAX) (AE $ Lit (-1)) 132 | , IJge $ Var $ AL "after" 133 | , IMov (AE $ Var EBX) (AE $ Lit 6) 134 | , IJmp $ Var $ AL "end" 135 | , Label "after" 136 | , IMov (AE $ Var EBX) (AE $ Lit 7) 137 | , Label "end" 138 | ] 139 | ) 140 | , ( testReg EBX 6 141 | , [ ICmp (AE $ Var EAX) (AE $ Lit 1) 142 | , IJge $ Var $ AL "after" 143 | , IMov (AE $ Var EBX) (AE $ Lit 6) 144 | , IJmp $ Var $ AL "end" 145 | , Label "after" 146 | , IMov (AE $ Var EBX) (AE $ Lit 7) 147 | , Label "end" 148 | ] 149 | ) 150 | , ( testReg EAX 2 151 | , [ IMov (AE (Var EAX)) (AE (Lit (-2147483647))) 152 | , ICmp (AE (Var EAX)) (AE (Lit 1)) 153 | , IJe (Var (AL "if_false__0")) 154 | , IMov (AE (Var EAX)) (AE (Lit 2)) 155 | , IJmp (Var (AL "if_done__0")) 156 | , Label "if_false__0" 157 | , IMov (AE (Var EAX)) (AE (Lit 7)) 158 | , Label "if_done__0" 159 | ] 160 | ) 161 | ] 162 | 163 | stack :: [([Instruction] -> Assertion, [Instruction])] 164 | stack = 165 | [ ( testReg EAX 7 166 | , [ IMov (AE $ Var EBX) (AE $ Lit 8) 167 | , IMov (AE $ Var EAX) (AE $ Lit 1) 168 | , IPush (AE $ Var EAX) 169 | , IPush (AE $ Var EBX) 170 | , IPop (AE $ Var EAX) 171 | , IPop (AE $ Var EBX) 172 | , ISub (AE $ Var EAX) (AE $ Var EBX) 173 | ] 174 | ) 175 | ] 176 | 177 | calls :: [([Instruction] -> Assertion, [Instruction])] 178 | calls = 179 | [ ( testReg EAX 7 180 | , [ ICall (Var (AL "set")) 181 | , IJmp (Var (AL "end")) 182 | , IMov (AE $ Var EAX) (AE $ Lit 8) 183 | , Label "set" 184 | , IMov (AE $ Var EAX) (AE $ Lit 7) 185 | , IRet 186 | , Label "end" 187 | ] 188 | ) 189 | ] 190 | 191 | -- Utils -- 192 | 193 | testReg reg val code = 194 | assertEq' 195 | (getReg reg) 196 | (getMachine =<< mToE (interpret [initMachine $ toCode [] code])) 197 | (pure val) 198 | 199 | testFlag flag val code = 200 | assertEq' 201 | (getFlag flag) 202 | (getMachine =<< mToE (interpret [initMachine $ toCode [] code])) 203 | (pure val) 204 | 205 | -------------------------------------------------------------------------------- /test/Testing.hs: -------------------------------------------------------------------------------- 1 | module Testing 2 | ( module Testing 3 | ) where 4 | 5 | import Language.X86 6 | import Data.Function as Testing 7 | import Test.Tasty as Testing 8 | import Test.Tasty.HUnit as Testing hiding ((@=?)) 9 | import Test.Tasty.QuickCheck as Testing 10 | import Text.Groom 11 | 12 | assertEq :: (Eq a, Show a) => a -> a -> Assertion 13 | assertEq x y = 14 | if y == x 15 | then 16 | pure () 17 | else do 18 | errorWithoutStackTrace $ unlines 19 | [ "" 20 | , "" 21 | , "Expected:" 22 | , "=========" 23 | , "" 24 | , "" ++ groom y 25 | , "" 26 | , "But got:" 27 | , "========" 28 | , "" 29 | , "" ++ groom x 30 | ] 31 | 32 | 33 | assertEq' :: (Show m, Eq a, Show a) => (m -> a) -> Either Error m -> (Either Error a) -> Assertion 34 | assertEq' f m y = 35 | if y == fmap f m 36 | then 37 | pure () 38 | else do 39 | errorWithoutStackTrace $ unlines 40 | [ "" 41 | , "" 42 | , "Expected:" 43 | , "=========" 44 | , "" 45 | , "" ++ groom y 46 | , "" 47 | , "But got:" 48 | , "========" 49 | , "" 50 | , "" ++ groom (f <$> m) 51 | , "" 52 | , "========" 53 | , "machine:" 54 | , "" 55 | , groom m 56 | ] 57 | -------------------------------------------------------------------------------- /x86-debug.cabal: -------------------------------------------------------------------------------- 1 | name: x86-debug 2 | version: 0.1.0.0 3 | synopsis: An x86 assembly debugger 4 | description: Please see README.md 5 | homepage: https://github.com/soupi/x86-debug 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Gil Mizrahi 9 | maintainer: gilmi@posteo.net 10 | copyright: 2018 Gil Mizrahi 11 | category: Compiler 12 | build-type: Simple 13 | extra-source-files: README.md 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: 19 | Language.X86 20 | , Language.X86.Run 21 | , Language.X86.Assembly 22 | , Language.X86.Interpreter 23 | , Language.X86.PP 24 | , Language.X86.Lexer 25 | , Language.X86.Parser 26 | other-modules: 27 | build-depends: 28 | base 29 | , containers 30 | , vector 31 | , bifunctors 32 | , groom 33 | , deepseq 34 | , megaparsec 35 | , parser-combinators 36 | 37 | default-extensions: 38 | ConstraintKinds 39 | DataKinds 40 | DeriveFunctor 41 | EmptyDataDecls 42 | FlexibleContexts 43 | KindSignatures 44 | LambdaCase 45 | MultiParamTypeClasses 46 | PatternGuards 47 | PatternSynonyms 48 | RankNTypes 49 | RecordWildCards 50 | ScopedTypeVariables 51 | TupleSections 52 | ViewPatterns 53 | 54 | default-language: Haskell2010 55 | ghc-options: -Wall 56 | -fno-warn-type-defaults 57 | 58 | executable x86-debug 59 | default-language: Haskell2010 60 | ghc-options: -fno-warn-type-defaults 61 | -threaded -rtsopts -with-rtsopts=-N 62 | hs-source-dirs: app 63 | main-is: Main.hs 64 | build-depends: base 65 | , x86-debug 66 | , optparse-generic 67 | , stm 68 | 69 | test-suite test 70 | default-language: Haskell2010 71 | type: exitcode-stdio-1.0 72 | hs-source-dirs: test 73 | main-is: 74 | Main.hs 75 | other-modules: 76 | Testing 77 | , Simple 78 | , Parser 79 | build-depends: base 80 | , groom 81 | , text 82 | , tasty 83 | , tasty-hunit 84 | , tasty-quickcheck 85 | , x86-debug 86 | ghc-options: -fno-warn-type-defaults 87 | -threaded -rtsopts -with-rtsopts=-N 88 | 89 | default-extensions: 90 | ConstraintKinds 91 | DeriveFunctor 92 | EmptyDataDecls 93 | KindSignatures 94 | LambdaCase 95 | MultiParamTypeClasses 96 | PatternGuards 97 | PatternSynonyms 98 | RankNTypes 99 | RecordWildCards 100 | ScopedTypeVariables 101 | TupleSections 102 | ViewPatterns 103 | 104 | source-repository head 105 | type: git 106 | location: https://github.com/soupi/x86-debug 107 | --------------------------------------------------------------------------------