never executed always true always false
1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE RecordWildCards #-}
3 {-# LANGUAGE ScopedTypeVariables #-}
4 {-# OPTIONS_GHC -fno-full-laziness #-}
5
6 {-|
7 Description : Brainfuck Virtual Machine
8 Copyright : (c) Sebastian Galkin, 2018
9 License : GPL-3
10
11 Functions to evaluate a compiled Brainfuck program.
12 -}
13 module HBF.Eval
14 ( MachineType
15 , eval
16 , evalWith
17 , evalWithIO
18 , evalWithMachine
19 , emptyMachine
20 , mkMachine
21 , VMOptions(..)
22 , defaultVMOptions
23 , unsafeParse
24 , parse
25 , parsePure
26 ) where
27
28 import Control.Monad (replicateM_, when)
29 import Control.Monad.Primitive (PrimMonad, PrimState)
30 import Data.Coerce (coerce)
31 import Data.Int (Int8)
32 import Data.Maybe (fromMaybe)
33 import Data.Monoid ((<>))
34 import qualified Data.Vector.Fusion.Stream.Monadic as VStream
35 import qualified Data.Vector.Generic as GV
36 import qualified Data.Vector.Generic.Mutable as MV
37 import qualified Data.Vector.Unboxed
38 import Options.Applicative (Parser, ParserInfo,
39 ParserResult, argument,
40 auto, defaultPrefs,
41 execParserPure, fullDesc,
42 handleParseResult, header,
43 help, helper, info, long,
44 metavar, option, progDesc,
45 short, str, switch, value,
46 (<**>))
47 import System.Environment (getArgs)
48
49 import HBF.Types
50
51 -- | An alias for a 'Machine' in which memory is an unboxed vector of bytes.
52 type MachineType = Machine (Data.Vector.Unboxed.Vector Int8)
53
54 {-# INLINABLE eval #-}
55 -- | Evaluate the given program returning the end state of the 'Machine'. The evaluation can
56 -- happen in any 'PrimMonad' for which we can do I/O. The reason to use 'PrimState' is that
57 -- we will use mutable vectors for the evaluation.
58 eval :: (PrimMonad m, MachineIO m) => Program Optimized -> m MachineType
59 eval = evalWithMachine defaultVMOptions emptyMachine
60
61 {-# INLINABLE evalWith #-}
62 -- | Evaluate the given program returning the end state of the 'Machine'. The evaluation can
63 -- happen in any 'PrimMonad' for which we can do I/O. The reason to use 'PrimState' is that
64 -- we will use mutable vectors for the evaluation. 'VMOptions' are used to tune the details
65 -- of the VM, like available memory, verbosity, etc.
66 evalWith ::
67 (PrimMonad m, MachineIO m)
68 => VMOptions
69 -> Program Optimized
70 -> m MachineType
71 evalWith opts program =
72 evalWithMachine opts (mkMachine (vmOptsMemoryBytes opts)) program
73
74 {-# INLINABLE evalWithIO #-}
75 -- | Evaluate the given program returning the end state of the 'Machine'. The evaluation
76 -- happens in IO, so Input/Output is done to the console.
77 evalWithIO :: VMOptions -> Program Optimized -> IO MachineType
78 evalWithIO opts program = do
79 machine <- evalWith opts program
80 when (vmOptsDumpMemory opts) $ print machine
81 return machine
82
83 {-# SPECIALISE evalWithMachine ::
84 VMOptions -> MachineType -> Program Optimized -> IO MachineType #-}
85
86 {-# INLINABLE evalWithMachine #-}
87 -- | Evaluate the given program returning the end state of the 'Machine'. The evaluation can
88 -- happen in any 'PrimMonad' for which we can do I/O. The reason to use 'PrimState' is that
89 -- we will use mutable vectors for the evaluation. 'VMOptions' are used to tune the details
90 -- of the VM, like memory available, verbosity, etc. The evaluation starts with the specified
91 -- 'MachineType', so the memory and initial pointer can be configured before running.
92 evalWithMachine ::
93 forall m. (PrimMonad m, MachineIO m)
94 => VMOptions
95 -> MachineType
96 -> Program Optimized
97 -> m MachineType
98 evalWithMachine _ Machine {..} program = do
99 mem <- GV.thaw memory
100 finalPointer <- mutableEval (instructions program) mem 0
101 finalMemory <- GV.unsafeFreeze mem
102 return Machine {memory = finalMemory, pointer = finalPointer}
103 -- For some reason making this function a top level binding brings down performance by compiling
104 -- without native arithmetic. Even if we add SPECIALIZE pragma
105 -- Maybe this is the reason why we also need -fno-full-laziness
106 where
107 mutableEval ::
108 forall v. (MV.MVector v Int8)
109 => [Op]
110 -> v (PrimState m) Int8
111 -> MemOffset
112 -> m MemOffset
113 mutableEval [] _ pos = return pos
114 mutableEval (op:ops) mem pos =
115 case op of
116 Inc n memOffset ->
117 MV.unsafeModify mem (+ fromIntegral n) (o2i $ pos + memOffset) *>
118 mutableEval ops mem pos
119 Move n -> mutableEval ops mem (pos + coerce n)
120 Out times memOffset -> do
121 val <- MV.unsafeRead mem (o2i $ pos + memOffset)
122 replicateM_ times (putByte val)
123 mutableEval ops mem pos
124 In times memOffset ->
125 if times == 0
126 then mutableEval ops mem pos
127 else let input :: m (Maybe Int8)
128 input =
129 foldr (flip (*>)) (return Nothing) $
130 replicate times getByte
131 in do input >>=
132 MV.write mem (o2i $ pos + memOffset) . fromMaybe 0
133 mutableEval ops mem pos
134 Loop l -> do
135 let go pos' = do
136 condition <- MV.unsafeRead mem (o2i pos')
137 if condition == 0
138 then mutableEval ops mem pos'
139 else (do pos'' <- mutableEval l mem pos'
140 go pos'')
141 go pos
142 Clear offset ->
143 MV.unsafeWrite mem (o2i $ pos + offset) 0 *> mutableEval ops mem pos
144 Mul factor from to -> do
145 x <- MV.unsafeRead mem (o2i $ pos + from)
146 MV.unsafeModify
147 mem
148 (\old -> old + x * factor2i factor)
149 (o2i $ pos + from + to)
150 mutableEval ops mem pos
151 Scan Up offset ->
152 let start = o2i $ pos + offset
153 slice :: v (PrimState m) Int8
154 slice = MV.slice start (MV.length mem - start) mem
155 in do Just idx <- VStream.findIndex (== 0) (MV.mstream slice) -- todo error handling
156 mutableEval ops mem (MemOffset $ start + idx)
157 Scan Down offset ->
158 let end = o2i $ pos + offset
159 slice :: v (PrimState m) Int8
160 slice = MV.slice 0 (end + 1) mem
161 in do Just idx <- VStream.findIndex (== 0) (MV.mstreamR slice) -- todo error handling
162 mutableEval ops mem (MemOffset $ end - idx)
163
164 o2i :: MemOffset -> Int
165 o2i = coerce
166
167 {-# INLINE o2i #-}
168 factor2i :: MulFactor -> Int8
169 factor2i = fromIntegral . (coerce :: MulFactor -> Int)
170
171 {-# INLINE factor2i #-}
172 -- | Size of the default VM memory, in bytes.
173 machineSize :: Word
174 machineSize = 30000
175
176 -- | A VM 'Machine' with the default memory available.
177 emptyMachine :: MachineType
178 emptyMachine = mkMachine machineSize
179
180 -- | Create a new machine with the given memory
181 mkMachine :: Word -> MachineType
182 mkMachine n = Machine {memory = GV.replicate (fromIntegral n) 0, pointer = 0}
183
184 -- | Command line arguments for the VM evaluator.
185 data VMOptions = VMOptions
186 { vmOptsMemoryBytes :: Word -- ^ Available memory in bytes.
187 , vmOptsDumpMemory :: Bool -- ^ Dump the contents of the memory after executing a program
188 , vmOptsProgramPath :: FilePath -- ^ Path to the compiled program
189 } deriving (Show)
190
191 -- | Default configuration for the VM.
192 defaultVMOptions :: VMOptions
193 defaultVMOptions =
194 VMOptions
195 { vmOptsMemoryBytes = 30000
196 , vmOptsDumpMemory = False
197 , vmOptsProgramPath = ""
198 }
199
200 optionsP :: Parser VMOptions
201 optionsP =
202 (\mem dump input ->
203 VMOptions
204 { vmOptsMemoryBytes = mem
205 , vmOptsDumpMemory = dump
206 , vmOptsProgramPath = input
207 }) <$>
208 option
209 auto
210 (long "memory" <> short 'm' <> metavar "BYTES" <>
211 value (vmOptsMemoryBytes defaultVMOptions) <>
212 help "Size of the memory [in bytes] used to run the program") <*>
213 switch
214 (long "dump-memory" <> short 'd' <>
215 help "Dump the contents of the memory when the program is finished") <*>
216 argument str (metavar "PROGRAM" <> help "Path to the compiled program")
217
218 parserInfo :: ParserInfo VMOptions
219 parserInfo =
220 info
221 (optionsP <**> helper)
222 (fullDesc <> progDesc "Run the compiled Brainfuck program in PROGRAM file" <>
223 header "An optimizing Brainfuck compiler and evaluator")
224
225 -- | Parse a list of command line arguments
226 parsePure :: [String] -> ParserResult VMOptions
227 parsePure = execParserPure defaultPrefs parserInfo
228
229 -- | Parse a list of command line arguments printing errors to the stderr
230 unsafeParse :: [String] -> IO VMOptions
231 unsafeParse = handleParseResult . parsePure
232
233 -- | Parse command line arguments printing errors to the stderr
234 parse :: IO VMOptions
235 parse = getArgs >>= unsafeParse