array-forth 0.2.0.6 → 0.2.1.4
raw patch · 10 files changed
+419/−154 lines, 10 filesdep +arraydep +modular-arithmeticdep ~Chartdep ~basedep ~mcmc-synthesis
Dependencies added: array, modular-arithmetic
Dependency ranges changed: Chart, base, mcmc-synthesis, optparse-applicative, vector
Files
- array-forth.cabal +60/−48
- src/Chart.hs +3/−3
- src/Language/ArrayForth/Channel.hs +67/−0
- src/Language/ArrayForth/Core.hs +73/−0
- src/Language/ArrayForth/Distance.hs +2/−1
- src/Language/ArrayForth/Interpreter.hs +60/−48
- src/Language/ArrayForth/State.hs +110/−26
- src/Language/ArrayForth/Synthesis.hs +8/−8
- src/Run.hs +29/−16
- test/Language/ArrayForth/Test.hs +7/−4
array-forth.cabal view
@@ -1,57 +1,41 @@ -- Initial arrayForth.cabal generated by cabal init. For further -- documentation, see http://haskell.org/cabal/users-guide/ --- The name of the package. name: array-forth---- The package version. See the Haskell package versioning policy (PVP) --- for standards guiding when and how versions should be incremented.--- http://www.haskell.org/haskellwiki/Package_versioning_policy--- PVP summary: +-+------- breaking API changes--- | | +----- non-breaking API additions--- | | | +--- code changes with no API change-version: 0.2.0.6+version: 0.2.1.4 --- A short (one-line) description of the package. synopsis: A simple interpreter for arrayForth, the language used on GreenArrays chips.- description: This is a package for working with arrayForth. This is a variant of Forth used by GreenArrays chips. This package contains an arrayForth simulator, two different representations of arrayForth programs and some utilities like parsing. It also supports synthesizing arrayForth programs using MCMC. The basic idea is to find arrayForth programs by taking a simple prior distribution of programs and using a randomized hill-climbing algorithm to find a program fulfilling certain tests. --- A longer description of the package.--- description: ---- The license under which the package is released. license: GPL-3---- The file containing the license text. license-file: LICENSE --- The package author(s). author: Tikhon Jelvis <tikhon@jelv.is>---- An email address to which users can send suggestions, bug reports, and --- patches.-maintainer: tikhon@jelv.is---- A copyright notice.--- copyright: +maintainer: Tikhon Jelvis <tikhon@jelv.is> category: Language- build-type: Simple---- Constraint on the version of Cabal needed to build this package. cabal-version: >=1.8 source-repository head type: git location: git://github.com/TikhonJelvis/array-forth.git +flag synthesis+ description: build the mcmc synthesis demo app+ default: False++flag chart+ description: build the charting facilities for analyzing the synthesizer+ default: False++ library- -- Modules exported by the library.- exposed-modules: Language.ArrayForth.Distance, + exposed-modules: Language.ArrayForth.Core+ Language.ArrayForth.Channel+ Language.ArrayForth.Distance, Language.ArrayForth.Interpreter, Language.ArrayForth.NativeProgram, Language.ArrayForth.Opcode,@@ -60,36 +44,64 @@ Language.ArrayForth.Stack, Language.ArrayForth.State, Language.ArrayForth.Synthesis- hs-source-dirs: src- -- Modules included in this library but not exported.- -- other-modules: - - -- Other library packages from which modules are imported.- build-depends: base >3 && <=5, mcmc-synthesis >=0.1, MonadRandom ==0.1.*,- OddWord >=1.0.0, split ==0.1.*, vector ==0.9.*- GHC-options: -Wall -funbox-strict-fields -fno-warn-orphans -rtsopts+ build-depends: base >=4.7 && <=5, + array >=0.4,+ mcmc-synthesis >=0.1.2.1, + modular-arithmetic ==1.*,+ MonadRandom ==0.1.*, + OddWord >=1.0.0, + split ==0.1.*, + vector >=0.9 && <0.11 + GHC-options: -Wall -funbox-strict-fields -rtsopts+ executable mcmc-demo Main-is: src/Main.hs- build-depends: base >3 && <=5, mcmc-synthesis >=0.1, array-forth,- MonadRandom ==0.1.*, optparse-applicative ==0.5.*- GHC-options: -Wall -rtsopts + if flag(synthesis)+ build-depends: array-forth,+ base >4.7 && <=5, + mcmc-synthesis >=0.1.2.1, + MonadRandom ==0.1.*,+ optparse-applicative >=0.7 && <0.10+ GHC-options: -Wall -rtsopts+ else + buildable: False + executable array-forth Main-is: src/Run.hs- build-depends: base >3 && <=5, vector ==0.9.*, split ==0.1.*, array-forth++ build-depends: array-forth,+ base >4.7 && <=5,+ split ==0.1.*,+ vector >=0.9 && <0.11+ GHC-options: -Wall -rtsopts executable chart Main-is: src/Chart.hs- build-depends: base >3 && <=5, mcmc-synthesis >=0.1, array-forth, Chart >=0.16,- MonadRandom ==0.1.*, optparse-applicative ==0.5.*- GHC-options: -Wall -rtsopts -O2 + if flag(chart)+ build-depends: array-forth,+ base >4.7 && <=5,+ Chart >=0.16 && <1.0,+ mcmc-synthesis >=0.1.2.1,+ MonadRandom ==0.1.*,+ optparse-applicative >=0.7 && <0.10++ GHC-options: -Wall -rtsopts -O2+ else+ buildable: False+ test-suite test-array-forth Type: exitcode-stdio-1.0 Main-is: test/Language/ArrayForth/Test.hs- build-depends: base >3 && <=5, QuickCheck >= 2 && <3, HUnit >= 1 && < 2,- test-framework-th ==0.*, test-framework-quickcheck2 ==0.*,- test-framework-hunit ==0.*, array-forth++ build-depends: array-forth,+ base >4.7 && <=5,+ HUnit >= 1 && < 2,+ QuickCheck >= 2 && <3,+ test-framework-hunit ==0.*,+ test-framework-quickcheck2 ==0.*,+ test-framework-th ==0.*
src/Chart.hs view
@@ -48,7 +48,7 @@ <> short 'p' <> value inclusiveOr <> metavar "NAME"- <> reader parseProblem+ <> eitherReader parseProblem <> help problemHelp) <*> option (long "samples" <> short 's'@@ -75,10 +75,10 @@ problemHelp = printf "The problem to run. Currently, the valid choices are:\n%s" names where names = init . unlines $ map (((replicate 30 ' ' ++ "- ") ++ ) . fst) problems -parseProblem :: String -> Either ParseError (Problem Program DefaultScore)+parseProblem :: String -> Either String (Problem Program DefaultScore) parseProblem problem = case lookup problem problems of Just p -> return p- Nothing -> Left . ErrorMsg $ printf "Problem name %s is not recognized." problem+ Nothing -> Left $ printf "Problem name %s is not recognized." problem range :: [Double] range = [0..]
+ src/Language/ArrayForth/Channel.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE RecordWildCards #-}++-- | Defines the basic operations for reading and writing through ports.+--+-- Each core has four ports connecting it to its neighbors. The cores+-- around the edges have ports connected to IO devices. A "Channel" is+-- just a type containing the four ports that you can write to or read+-- from.+module Language.ArrayForth.Channel where++import Control.Applicative ((<|>))++import Data.Bits (testBit)+import Data.Monoid (Monoid (..))++import Language.ArrayForth.Opcode (F18Word)++-- | A channel representing the four communication directions a core+-- may use. In practice, these will either be hooked up to other cores+-- or to IO. Nothing represents no message; if there is a word,+-- execution will block.+data Channel = Channel { right, down, left, up :: Maybe F18Word } deriving (Show, Eq)++-- | The four possible port directions. +data Port = R | D | L | U deriving (Show, Eq, Bounded, Enum)++-- The monoid instance is based around *replacement*.+instance Monoid Channel where+ mempty = emptyChannel+ c₁ `mappend` c₂ = Channel { right = right c₁ <|> right c₂+ , down = down c₁ <|> down c₂+ , left = left c₁ <|> left c₂+ , up = up c₁ <|> up c₂ }++-- | An empty channel has no reads or writes and doesn't block execution.+emptyChannel :: Channel+emptyChannel = Channel Nothing Nothing Nothing Nothing++-- | Write to the ports specified by the given memory address. This+-- will clear all the channels not being written to (by setting them+-- to Nothing).+--+-- The ports to use are specified by bits 5–8 of the address. These+-- bits correspond respectively to up, left, down and right. Bits 5+-- and 7 are inverted—0 turns the channel *on*.+writePort :: F18Word -- ^ The address to write to. Only bits 5–8 are considered.+ -> F18Word -- ^ The word to write to the channel.+ -> Channel -- ^ The resulting channel, with any unused ports empty.+writePort ports word = Channel { right = [ word | testBit ports 8 ]+ , down = [ word | not $ testBit ports 7 ]+ , left = [ word | testBit ports 6 ]+ , up = [ word | not $ testBit ports 5 ] }++-- | Read the inputs from the ports specified by the given+-- address. The address is handled the same way as in+-- @'writePort'@. Returns @Nothing@ if blocked on the read.+--+-- If more than one of the read ports has data, this currently just+-- chooses the first one based on the right, down, left, up order. I+-- don't know if this is the correct behavior—perhaps I should just+-- xor them together or something?+readPort :: F18Word -> Channel -> Maybe F18Word+readPort ports Channel {..} = [ word | testBit ports 8, word <- right ]+ <|> [ word | not $ testBit ports 7, word <- down ]+ <|> [ word | testBit ports 6, word <- left ]+ <|> [ word | not $ testBit ports 5, word <- up ]
+ src/Language/ArrayForth/Core.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}+-- | This module defines a type representing the location of a core in+-- the 8 × 18 grid.+-- +-- All of the actually interesting code is in the typeclass instances.+module Language.ArrayForth.Core where++import Data.Modular ++import Text.Printf (printf)++-- | The address of a core. There are 144 cores in an 8 × 18+-- array. The address has the row number followed by the column+-- number.+-- +-- As a string, the core addresses are displayed as a single+-- three-digit number, just like in the GreenArray documentation. So+-- @Core 7 17@ becomes @\"717\"@.+-- +-- Core addresses behave like numbers: you can use numeric literals+-- and add them together. For example, @[0..] :: [Core]@ gets you the+-- list of all the core addresses. @(move core = core + Core 1 1)@ is+-- a function that moves you up and over by one core.+data Core = Core !(ℤ/8) !(ℤ/18)++-- | Returns all the neighbors of a core. Most cores have four+-- neighbors; the ones along the edges only have three and the ones at+-- the corners two.+--+-- They always come in the order right, down, left up, with Nothing in+-- place of non-existant cores.+neighbors :: Core -> [Maybe Core]+neighbors core@(Core row col) = [ [ core + Core 1 0 | row /= maxBound ] + , [ core + Core 0 1 | col /= maxBound ] + , [ core + Core (-1) 0 | row /= minBound ] + , [ core + Core 0 (- 1) | col /= minBound ] ]++-- Follows the same format as the documentation does: (7, 17) becomes 717.+instance Show Core where show (Core row col) = printf "%d%.2d" (unMod row) (unMod col)++deriving instance Eq Core+deriving instance Ord Core++instance Enum Core where+ fromEnum (Core r c) = fromInteger $ unMod r * 18 + unMod c+ toEnum n+ | n >= 0 && n < 144 = Core (toMod' $ n `div` 18) (toMod' $ n `mod` 18)+ | otherwise = error "Core index out of bounds."++ -- Taken directly from the documentation for Enum:+ enumFrom x = enumFromTo x maxBound+ enumFromThen x y = enumFromThenTo x y bound+ where bound | fromEnum y >= fromEnum x = maxBound+ | otherwise = minBound++instance Bounded Core where+ minBound = Core 0 0+ maxBound = Core 7 17++-- Core addresses from a group, eh?+instance Num Core where+ fromInteger = toEnum . fromIntegral++ Core r₁ c₁ + Core r₂ c₂ = Core (r₁ + r₂) (c₁ + c₂)+ Core r₁ c₁ * Core r₂ c₂ = Core (r₁ * r₂) (c₁ * c₂)++ signum (Core r c) = Core (signum r) (signum c)+ abs (Core r c) = Core (abs r) (abs c)+ negate (Core r c) = Core (negate r) (negate c)
src/Language/ArrayForth/Distance.hs view
@@ -3,6 +3,7 @@ import Data.Bits (Bits, popCount, xor) import Data.List (genericLength)+import Data.Maybe (fromJust) import Data.Monoid import Language.ArrayForth.Interpreter (Trace)@@ -29,7 +30,7 @@ -- between the given memory locations. locations :: [F18Word] -> (State -> State -> Distance) locations addresses s₁ s₂ = Sum . fromIntegral . sum $ zipWith countBits (go s₁) (go s₂)- where go state = map (memory state !) addresses+ where go state = map (fromJust . (memory state !)) addresses -- | Returns a score that counts the number of matching states -- according to some projection function.
src/Language/ArrayForth/Interpreter.hs view
@@ -1,9 +1,11 @@-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-} module Language.ArrayForth.Interpreter where -import Data.Bits (bit, bitSize, complement,- shift, testBit, xor, (.&.),- (.|.))+import Data.Bits+import Data.Functor ((<$>))+import Data.Maybe (fromJust, fromMaybe, mapMaybe) import Language.ArrayForth.NativeProgram import Language.ArrayForth.Opcode@@ -39,7 +41,8 @@ -- | Executes a single word in the given state, incrementing -- the program counter and returning all the intermediate states. stepAll :: State -> [State]-stepAll state@State {p} = wordAll (next state) $ state {p = p + 1, i = toBits $ next state}+stepAll state = fromMaybe [] $ go <$> next state+ where go instrs = wordAll instrs . incrP $ state {i = toBits <$> next state} -- | Executes a single word in the given state, returning the last -- resulting state.q@@ -58,7 +61,7 @@ -- | Trace a program until it either hits four nops or all 0s. stepProgram :: State -> Trace stepProgram = takeWhile (not . done) . traceProgram- where done state = i state == 0x39ce7 || i state == 0+ where done state = i state == Just 0x39ce7 || i state == Just 0 -- | Runs the program unil it hits a terminal state, returning only -- the resulting state.@@ -72,15 +75,15 @@ -- | Estimates the execution time of a program trace. countTime :: Trace -> Double-countTime = runningTime . map (fromBits . i)+countTime = runningTime . mapMaybe (fmap fromBits . i) -- | Checks that the program trace terminated in at most n steps, -- returning Nothing otherwise. throttle :: Int -> Trace -> Either Trace Trace-throttle n state | null res = Right [startState]- | length res == n = Left res- | otherwise = Right res- where res = take n state+throttle n states | null res = Right [startState]+ | length res == n = Left res+ | otherwise = Right res+ where res = take n states -- | Does the given opcode cause the current word to stop executing? endWord :: Opcode -> Bool@@ -91,46 +94,55 @@ run :: Opcode -> [State] -> [State] run op trace = trace ++ [execute op $ last trace] --- | Executes an opcode on the given state.+-- | Executes an opcode on the given state. If the state is blocked on+-- some communication, nothing changes. execute :: Opcode -> State -> State-execute op state@State {a, b, p, r, s, t, memory} = case op of- Ret -> fst . rpop $ state {p = r}- Exec -> state {r = p, p = r}- Unext -> if r == 0 then fst $ rpop state else state {r = r - 1, p = p - 1}- FetchP -> dpush (state {p = p + 1}) $ memory ! p- FetchPlus -> dpush (state {a = a + 1}) $ memory ! a- FetchB -> dpush state $ memory ! b- Fetch -> dpush state $ memory ! a- StoreP -> state' {p = p + 1, memory = set memory p top}- StorePlus -> state' {a = a + 1, memory = set memory a top}- StoreB -> state' {memory = set memory b top}- Store -> state' {memory = set memory a top}- MultiplyStep -> multiplyStep- Times2 -> state {t = t `shift` 1}- Div2 -> state {t = t `shift` (-1)}- Not -> state {t = complement t}- Plus -> state' {t = s + t}- And -> state' {t = s .&. t}- Or -> state' {t = s `xor` t}- Drop -> fst $ dpop state- Dup -> dpush state t- Pop -> let (s', res) = rpop state in dpush s' res- Over -> dpush state s- ReadA -> dpush state a- Nop -> state- Push -> rpush state' top- SetB -> state' {b = top}- SetA -> state' {a = top}- _ -> error "Cannot jump without an address!"- where (state', top) = dpop state+execute op state@State {..} = fromMaybe state [ res | res <- result, not $ blocked res ]+ where result = case op of+ FetchP -> dpush (incrP state) <$> memory ! p+ FetchPlus -> dpush (state {a = a + 1}) <$> memory ! a+ FetchB -> dpush state <$> memory ! b+ Fetch -> dpush state <$> memory ! a+ _ -> Just normal+ normal = case op of+ Ret -> fst . rpop $ state {p = r}+ Exec -> state {r = p, p = r}+ Unext -> if r == 0 then fst $ rpop state+ else state {r = r - 1, p = p - 1}+ StoreP -> incrP $ set state' p top+ StorePlus -> set (state' { a = a + 1 }) a top+ StoreB -> set state' b top+ Store -> set state' a top+ MultiplyStep -> multiplyStep+ Times2 -> state {t = t `shift` 1}+ Div2 -> state {t = t `shift` (-1)}+ Not -> state {t = complement t}+ Plus -> state' {t = s + t}+ And -> state' {t = s .&. t}+ Or -> state' {t = s `xor` t}+ Drop -> fst $ dpop state+ Dup -> dpush state t+ Pop -> uncurry dpush $ rpop state+ Over -> dpush state s+ ReadA -> dpush state a+ Nop -> state+ Push -> rpush state' top+ SetB -> state' {b = top}++ SetA -> state' {a = top}+ _ -> error "Cannot jump without an address!"++ (state', top) = dpop state+ -- TODO: support different word sizes? multiplyStep- | even a = let t0 = (t .&. 1) `shift` (bitSize t - 1) in+ | even a = let t0 = (t .&. 1) `shift` (size - 1) in state { a = t0 .|. a `shift` (-1)- , t = t .&. bit 17 .|. t `shift` (-1)}- | otherwise = let sum0 = (s + t) `shift` (bitSize t - 1)- sum17 = (s + t) .&. bit 17 in+ , t = t .&. bit (size - 1) .|. t `shift` (-1)}+ | otherwise = let sum0 = (s + t) `shift` (size - 1)+ sum17 = (s + t) .&. bit (size - 1) in state { a = sum0 .|. a `shift` (-1) , t = sum17 .|. (s + t) `shift` (-1) }+ size = bitSize t -- | Execute a jump instruction to the given address. jump :: Opcode -> F18Word -> State -> State@@ -139,6 +151,6 @@ Call -> (rpush state p) {p = addr} Next -> if r == 0 then fst $ rpop state else state {r = r - 1, p = addr} If -> if t /= 0 then state {p = addr} else state- MinusIf -> if t `testBit` pred (bitSize (0 :: F18Word)) then state else state {p = addr}+ MinusIf -> if t `testBit` pred size then state else state {p = addr} _ -> error "Non-jump instruction given a jump address!"-+ where size = bitSize (0 :: F18Word)
src/Language/ArrayForth/State.hs view
@@ -1,4 +1,16 @@-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+-- | This module defines types and functions for working with the+-- state of a single core.+--+-- The most important type is State, which contains all the+-- information about the core. This includes the registers, the+-- memory, both stacks and communication ports. Right now, it's just a+-- big record; in the future, I might make it more polymorphic using+-- lenses.+--+-- There are also some useful types and functions for working with the+-- memory of a chip and its communication channels. module Language.ArrayForth.State where import Data.Functor ((<$>))@@ -7,21 +19,53 @@ import Text.Printf (printf) +import Language.ArrayForth.Channel import Language.ArrayForth.NativeProgram import Language.ArrayForth.Opcode (F18Word) import Language.ArrayForth.Stack --- | The chip's RAM and ROM-type Memory = Vector Int+ -- TODO: Figure out how to deal with different reads in ports. +-- | The chip's RAM, ROM and IO channels. The RAM and ROM should each+-- contain 64 words.+--+-- For now, input and output is split into two different types, even+-- though they're combined on the physical chip. I'm simply not sure+-- how to handle the case that both chips simultaneously write to the+-- same channel.+data Memory = Memory { ram :: Vector Int+ , rom :: Vector Int+ , input :: Channel+ , output :: Channel } deriving (Show, Eq)++-- | Memory with RAM and ROM zeroed out and nothing on the+-- communication channels. emptyMem :: Memory-emptyMem = V.replicate 64 0+emptyMem = Memory { ram = V.replicate 64 0+ , rom = V.replicate 64 0+ , input = emptyChannel+ , output = emptyChannel } --- | A state representing the registers, stacks and memory of a core.+-- | The number of words in memory. Both ram and rom are this+-- size. For some reason, the ram and rom address spaces are *double*+-- this size respectively, wrapping around at the half-way point.+memSize :: Num a => a+memSize = 0x03F++-- | A state representing the registers, stacks, memory and+-- communication channels of a core. Note that all the fields are+-- strict; they should also be unboxed thanks to+-- @-funbox-strict-fields@ (set in the .cabal file).+--+-- For now, this is just a record; however, I might rewrite it to use+-- lenses in the near future. data State =- State { a, b, i, p, r, s, t :: !F18Word+ State { a, b, p, r, s, t :: !F18Word+ , i :: !(Maybe F18Word)+ -- ^ the i register can be @Nothing@ if it is blocked on a+ -- communication port. , dataStack, returnStack :: !Stack- , memory :: !Memory }+ , memory :: !Memory } instance Show State where show State {p, a, b, r, s, t, dataStack} =@@ -31,53 +75,93 @@ -- | The state corresponding to a core with no programs loaded and no -- instructions executed. startState :: State-startState = State 0 0 0 0 0 0 0 empty empty emptyMem+startState = State 0 0 0 0 0 0 (Just 0) empty empty emptyMem --- | The next word of instructions to execute in the given state.-next :: State -> Instrs-next State {memory, p} = fromBits $ memory ! p --- | Pops the data stack of the given state, updating s and t.+-- | Increment the p register for the given state. If p is in RAM or+-- ROM, this wraps p as appropriate. If p is in IO, this does nothing+-- and p remains unchanged.+incrP :: State -> State+incrP state@State { p } = state { p = nextP }+ where nextP | p < 2 * memSize = succ p `mod` (2 * memSize)+ | p < 4 * memSize = (succ p `mod` (2 * memSize)) + 2 * memSize+ | otherwise = p++-- | The next word of instructions to execute in the given+-- state. Returns @Nothing@ if @p@ is blocked on a communication+-- channel.+next :: State -> Maybe Instrs+next State { memory, p } = fromBits <$> memory ! p++-- | Pops the data stack of the given state, updating @s@ and @t@. dpop :: State -> (State, F18Word) dpop state@State {s, t, dataStack} = let (ds', res) = pop dataStack in (state {t = s, s = res, dataStack = ds'}, t) --- | Push a word onto the data stack, updating s and t.+-- | Push a word onto the data stack, updating @s@ and @t@. dpush :: State -> F18Word -> State dpush state@State {s, t, dataStack} word = state {t = word, s = t, dataStack = push dataStack s} --- | Pops the return stack of the given state, updating r.+-- | Pops the return stack of the given state, updating @r@. rpop :: State -> (State, F18Word) rpop state@State {r, returnStack} = let (rs', res) = pop returnStack in (state {r = res, returnStack = rs'}, r) --- | Push a word onto the return stack, updating r.+-- | Push a word onto the return stack, updating @r@. rpush :: State -> F18Word -> State rpush state@State {r, returnStack} word = state {r = word, returnStack = push returnStack r} --- | Force an address to be in range of memory: [0,64).+-- | Force an address to be in range of memory: [0,64), also+-- converting between different integral types. toMem :: (Integral a, Integral b) => a -> b toMem = fromIntegral . (`mod` 64) --- | Read the memory at a location given by a Forth word.-(!) :: Memory -> F18Word -> F18Word-memory ! i | toMem i < V.length memory = fromIntegral $ memory V.! toMem i- | otherwise = error "Memory out of bounds."+-- | Read the memory at a location given by a Forth word. Returns+-- @Nothing@ if blocked on a communication channel.+(!) :: Memory -> F18Word -> Maybe F18Word+Memory {..} ! i | i < 2 * memSize = Just . fromIntegral $ ram V.! toMem i+ | i < 4 * memSize = Just . fromIntegral $ rom V.! toMem i+ | otherwise = readPort i input --- | Set the memory using Forth words.-set :: Memory -> F18Word -> F18Word -> Memory-set mem index value = mem // [(toMem index, fromIntegral $ value)]+-- | Set the memory using Forth words. A state with anything in the+-- output channel remains blocked until one of the active ports is+-- read.+set :: State -> F18Word -> F18Word -> State+set state@State {memory = memory@Memory {..}} i value+ | i < 2 * memSize = state { memory = updatedRam }+ | i < 4 * memSize = error "Cannot set memory in the ROM!"+ | otherwise = state { memory = updatedOutput }+ where updatedRam = memory { ram = ram // [(toMem i, fromIntegral value)] }+ updatedOutput = memory { output = writePort i value } +-- | Is the state is blocked because it has written to a port? Note+-- that this does *not* consider being blocked on a read!+blocked :: State -> Bool+blocked State { memory = Memory { output } } = output /= emptyChannel+ -- | Loads the given program into memory at the given starting -- position. setProgram :: F18Word -> NativeProgram -> State -> State-setProgram start program state = state' { i = toBits $ next state' }+setProgram start program state = state' { i = toBits <$> next state' } where state' = loadMemory start (fromIntegral . toBits <$> program) state -- | Load the given memory words into the state starting at the given -- address. loadMemory :: F18Word -> [F18Word] -> State -> State-loadMemory start values state@State {memory} =- state { memory = memory // zip [toMem start..] (fromIntegral <$> values) }+loadMemory start values state@State {memory = memory@Memory {..}} =+ state { memory = memory {+ ram = ram // zip [toMem start..] (fromIntegral <$> values) } }++-- This code in particular would probably have been much nicer with lenses! +-- | Sets the input value at the given port.+sendInput :: Port -> F18Word -> State -> State+sendInput port value state@(State { memory = memory@Memory {..} }) = updated+ where updated = state {+ memory = case port of+ R -> memory { input = input { right = Just value } }+ D -> memory { input = input { down = Just value } }+ L -> memory { input = input { left = Just value } }+ U -> memory { input = input { up = Just value } }+ }
src/Language/ArrayForth/Synthesis.hs view
@@ -12,7 +12,7 @@ import Data.Function (on) import Data.Functor ((<$>)) import Data.List (elemIndices, genericLength, (\\))-import Data.Monoid (Monoid (..), (<>))+import Data.Monoid (Monoid (..)) import Language.ArrayForth.Distance import Language.ArrayForth.Interpreter@@ -49,7 +49,7 @@ where specs = stepProgram . load spec <$> inputs results = stepProgram . load program <$> inputs throttled = zipWith go specs results- where go spec trace = either id id $ throttle (length spec) trace+ where go spec' trace' = either id id $ throttle (length spec') trace' -- | Using a given correctness measure, produce a score also -- containing performance.@@ -57,8 +57,8 @@ withPerformance score spec result = DefaultScore (toScore $ score spec res) performance where res = either id id $ throttle (length spec) result performance = case throttle (length spec) result of- Right res -> (countTime spec - countTime res) / 10- Left res -> countTime spec - countTime res - 1e10+ Right res' -> (countTime spec - countTime res') / 10+ Left res' -> countTime spec - countTime res' - 1e10 -- | Given a specification program and some inputs, evaluate a program -- against the specification for both performance and@@ -99,10 +99,10 @@ removePairs :: Distr Instruction -> Mutation Program removePairs instrDistr program = mix [(mutateInstructionsAt instrDistr is program, 1.0) | is <- findPairs program]- where findPairs program = do (a, b) <- pairs- indexA <- elemIndices a program- indexB <- elemIndices b program- return [indexA, indexB]+ where findPairs program' = do (a, b) <- pairs+ indexA <- elemIndices a program'+ indexB <- elemIndices b program'+ return [indexA, indexB] -- | The default mutations to try. For now, this will either change an -- instruction or swap two instructions in the program, with equal
src/Run.hs view
@@ -7,9 +7,9 @@ import Language.ArrayForth.Interpreter (eval, runNativeProgram) import Language.ArrayForth.Parse (isNumber)-import Language.ArrayForth.Program (toNative, readProgram)-import Language.ArrayForth.State (State (..), setProgram,- startState)+import Language.ArrayForth.Program (readProgram, toNative)+import Language.ArrayForth.State (Memory (..), State (..),+ setProgram, startState) import System.Environment (getArgs) import System.IO (hFlush, stdout)@@ -24,23 +24,36 @@ _ -> putStrLn $ "Too many arguments!" repl :: IO ()-repl = go 0 startState- where go loc state =- do inp <- putStr "λ>" >> hFlush stdout >> getLine- case inp of- ":" -> putStrLn "Please specify a command!" >> go loc state- ':' : commands -> let command : args = words commands in- run command args >>= uncurry go- program -> execute $ readProgram program- where execute (Left err) = print err >> go loc state- execute (Right program) = print res >> go p res+repl = putStrLn errorMessage >> go (0, startState)+ where errorMessage = "Type :help for a list of possible command."+ + go (loc, state) = do+ inp <- putStr "λ>" >> hFlush stdout >> getLine+ case inp of+ ":" -> do+ putStrLn ("Please specify a valid command. " ++ errorMessage)+ go (loc, state)+ ':' : commands -> let command : args = words commands in+ run command args >>= go+ program -> execute $ readProgram program+ where helpMessage = unlines $ [+ ":help — list the possible commands",+ ":reset — reset all the registers and memory to 0",+ ":p — print the value of the p register (the program counter)",+ ":p <n> — set the p register to the given address n; a manual jump instruction",+ ":memory — print all of the memory in a reasonably easy to read format"]+ + execute (Left err) = print err >> go (loc, state)+ execute (Right program) = print res >> go (p, res) where res@State {p} = eval $ setProgram loc (toNative program) state run "reset" _ = (0, startState) <$ print startState+ run "p" [] = (loc, state) <$ print (p state) run "p" args- | null args || not (isNumber $ head args) =+ | not (isNumber $ head args) = (loc, state) <$ putStrLn "Invalid arguments!" | otherwise = let n = read $ head args in (n, state { p = n }) <$ print state { p = n } run cmd args = (loc, state) <$ continue cmd args- continue "memory" _ = mapM_ print . chunk 8 . V.toList $ memory state- continue cmd _ = printf "Unknown command `%s'!\n" cmd+ continue "help" _ = putStr helpMessage+ continue "memory" _ = mapM_ print . chunk 8 . V.toList . ram $ memory state+ continue cmd _ = printf "Unknown command `%s'!\n%s" cmd errorMessage
test/Language/ArrayForth/Test.hs view
@@ -7,15 +7,16 @@ import Control.Applicative ((<$>), (<*>)) import Data.Bits (complement, xor, (.&.))+import Data.Maybe (fromJust) -import Language.ArrayForth.Interpreter+import Language.ArrayForth.Interpreter hiding (run) import Language.ArrayForth.NativeProgram import Language.ArrayForth.Opcode-import Language.ArrayForth.Parse ()+import Language.ArrayForth.Parse () import Language.ArrayForth.Program import Language.ArrayForth.Stack-import Language.ArrayForth.State hiding (State (..))-import qualified Language.ArrayForth.State as S+import Language.ArrayForth.State hiding (State (..), (!))+import qualified Language.ArrayForth.State as S import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2@@ -65,6 +66,8 @@ main = $(defaultMainGenerator) run = runNativeProgram startState . read++memory ! address = fromJust $ memory S.! address -- Instruction utilities tests: prop_bits word = word == (toBits $ fromBits word)