Improve Haskell brainfuck2 benchmarks

brainfuck2/bf-vector.hs

@@ -0,0 +1,98 @@
+import Data.Vector ((!?))
+import qualified Data.Vector as V
+import qualified Data.Vector.Mutable as M
+import qualified Data.Vector.Unboxed.Mutable as U
+import Data.Char (chr)
+import System.Environment (getArgs)
+import System.IO (hFlush, hPutChar, stdout)
+
+data Op = Inc | Dec | MoveL | MoveR | Print | Bne Int | Beq Int  
+    deriving Show
+
+parse :: [Char] -> IO (V.Vector Op)
+parse src = do
+    ops <- M.unsafeNew len
+    go [] src' ops 0
+  where
+    src' = filter (`elem` "+-<>.[]") src
+    len = length src'
+
+    go :: [Int] -> [Char] -> M.IOVector Op -> Int -> IO (V.Vector Op)
+    go js (c : cs) ops i = case c of
+        '+' -> do
+            M.unsafeWrite ops i Inc
+            go js cs ops (i + 1)
+        '-' -> do
+            M.unsafeWrite ops i Dec
+            go js cs ops (i + 1)
+        '<' -> do
+            M.unsafeWrite ops i MoveL
+            go js cs ops (i + 1)
+        '>' -> do
+            M.unsafeWrite ops i MoveR
+            go js cs ops (i + 1)
+        '.' -> do
+            M.unsafeWrite ops i Print
+            go js cs ops (i + 1)
+        '[' -> do
+            M.unsafeWrite ops i (Beq len)
+            go (i : js) cs ops (i + 1)
+        ']' -> case js of
+            [] -> do
+                M.unsafeWrite ops i (Bne 0)
+                go [] cs ops (i + 1)
+            j : jt -> do
+                M.unsafeWrite ops i (Bne $ j + 1)
+                M.unsafeWrite ops j (Beq $ i + 1)
+                go jt cs ops (i + 1)
+        _ -> do
+            M.unsafeWrite ops i (Beq $ i + 1)
+            go js cs ops (i + 1)
+    go _ [] ops _ = V.unsafeFreeze ops
+
+run :: V.Vector Op -> IO ()
+run ops = do
+    tape <- U.new 8
+    go 0 tape 0
+  where
+    go :: Int -> U.IOVector Int -> Int -> IO ()
+    go i tape j = j `seq` case ops !? i of
+        Just Inc -> do
+            v <- U.unsafeRead tape j
+            U.unsafeWrite tape j (v + 1)
+            go (i + 1) tape j
+        Just Dec -> do
+            v <- U.unsafeRead tape j
+            U.unsafeWrite tape j (v - 1)
+            go (i + 1) tape j
+        Just MoveL -> go (i + 1) tape (j - 1)
+        Just MoveR -> do
+            let l = U.length tape
+            if j + 1 >= U.length tape
+            then do
+                tape' <- U.grow tape l
+                go (i + 1) tape' (j + 1)
+            else go (i + 1) tape (j + 1)
+        Just Print -> do
+            v <- U.unsafeRead tape j
+            hPutChar stdout $ chr v
+            hFlush stdout
+            go (i + 1) tape j
+        Just (Bne k) -> do
+            v <- U.unsafeRead tape j
+            if v /= 0
+            then go k tape j
+            else go (i + 1) tape j
+        Just (Beq k) -> do
+            v <- U.unsafeRead tape j
+            if v == 0
+            then go k tape j
+            else go (i + 1) tape j
+        Nothing -> pure ()
+
+main :: IO ()
+main = do
+    [filename] <- getArgs
+    src <- readFile filename
+    ops <- parse src
+    run ops

brainfuck2/bf.hs

@@ -1,72 +1,58 @@
-module Main where
-
-import qualified Data.Array.Base as ArrayBase
-import qualified Data.Array.Unboxed as UArray
+import Control.Arrow (first)
 import Data.Char (chr)
+import Data.Function (fix)
 import System.Environment (getArgs)
-import System.IO (hFlush, stdout)
-
-data Op = Inc Int | Move Int | Print | Loop [Op] deriving Show
-data Tape = Tape { tapeData :: UArray.UArray Int Int
-                 , tapePos :: Int
-                 } deriving Show
-
-current :: Tape -> Int
-current tape = ArrayBase.unsafeAt (tapeData tape) (tapePos tape)
+import System.IO (hFlush, hPutChar, stdout)
 
-inc :: Int -> Tape -> Tape
-inc delta tape =
-    tape { tapeData = newData }
-  where
-    newData = ArrayBase.unsafeReplace (tapeData tape)
-                                      [(tapePos tape, (current tape) + delta)]
+data Op = Inc | Dec | MoveL | MoveR | Print | Loop [Op]
+    deriving Show
 
-move :: Int -> Tape -> Tape
-move m tape =
-    tape { tapeData = newData, tapePos = newPos }
+parse :: [Char] -> [Op]
+parse = fst <$> go
   where
-    curData = tapeData tape
-    len = ArrayBase.numElements curData
-    newPos = (tapePos tape) + m
-    asc = ArrayBase.assocs curData
-    newData = if newPos < len
-              then curData
-              else ArrayBase.unsafeArray (0, newPos)
-                                         (asc ++ [(i, 0) | i <- [len..newPos]])
-
-parse :: ([Char], [Op]) -> ([Char], [Op])
-parse ([], acc) = ([], reverse acc)
-parse (c:cs, acc) =
-    case c of
-        '+'       -> parse (cs, Inc 1:acc)
-        '-'       -> parse (cs, Inc (-1):acc)
-        '>'       -> parse (cs, Move 1:acc)
-        '<'       -> parse (cs, Move (-1):acc)
-        '.'       -> parse (cs, Print:acc)
-        '['       -> parse (newCs, Loop loop:acc)
-                     where (newCs, loop) = parse (cs, [])
-        ']'       -> (cs, reverse acc)
-        otherwise -> parse (cs, acc)
+    go :: [Char] -> ([Op], [Char])
+    go (c : cs) = case c of
+        '+' -> first (Inc :) (go cs)
+        '-' -> first (Dec :) (go cs)
+        '<' -> first (MoveL :) (go cs)
+        '>' -> first (MoveR :) (go cs)
+        '.' -> first (Print :) (go cs)
+        '[' -> first (Loop os :) (go cs')
+            where (os, cs') = go cs
+        ']' -> ([], cs)
+        _ -> go cs
+    go [] = ([], [])
+
+data IntStream = !Int :- IntStream
+    deriving Show
+
+data Tape = Tape IntStream !Int IntStream
+    deriving Show
+
+blank :: Tape
+blank = Tape (fix (0 :-)) 0 (fix (0 :-))
 
 run :: [Op] -> Tape -> IO Tape
-run [] tape = return tape
-run (op:ops) tape = do
-    case op of
-        Inc d -> run ops $ inc d tape
-        Move m -> run ops $ move m tape
-        Print -> do
-            putStr $ [chr $ current tape]
-            hFlush stdout
-            run ops tape
-        Loop loop -> do
-            if current tape == 0
-            then run ops tape
-            else do
-                newTape <- run loop tape
-                run (op:ops) newTape
-
+run (o : os) tape = case o of
+    Inc -> let Tape ls v rs = tape
+            in run os $ Tape ls (v + 1) rs
+    Dec -> let Tape ls v rs = tape
+            in run os $ Tape ls (v - 1) rs
+    MoveL -> let Tape (l :- lt) v rs = tape
+              in run os $ Tape lt l (v :- rs)
+    MoveR -> let Tape ls v (r :- rt) = tape
+              in run os $ Tape (v :- ls) r rt
+    Print -> let Tape _ v _ = tape
+              in hPutChar stdout (chr v) *> hFlush stdout *> run os tape
+    Loop os' -> let Tape _ v _ = tape
+                 in if v /= 0
+                    then run (o : os) =<< run os' tape
+                    else run os tape
+run [] tape = pure tape
+
+main :: IO ()
 main = do
     [filename] <- getArgs
     source <- readFile filename
-    let (_, ops) = parse (source, [])
-    run ops (Tape (ArrayBase.unsafeArray (0, 0) [(0, 0)]) 0)
+    _ <- run (parse source) blank
+    pure ()