summaryrefslogtreecommitdiff
path: root/bf.hs
blob: d369a871e50fdae74cc051625629bdb41609c134 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
import Text.Parsec
import Text.Parsec.String
import Control.Monad.State
import qualified Data.IntMap as M
import Data.Word
import System.Environment
import System.Console.GetOpt
import System.Exit
import Data.Maybe
import System.FilePath
import LLVM.Core
import LLVM.Util.Optimize

data BFInstruction = GoBack | GoForward | Increment | Decrement | Input
                   | Output | Loop [BFInstruction]
                   deriving (Show)

parseBack, parseForward, parseIncrement, parseLoop,
 parseDecrement, parseInput, parseOutput :: Parser BFInstruction

parseGen :: Char -> BFInstruction -> Parser BFInstruction
parseGen x y = char x >> return y

parseBack = parseGen '<' GoBack
parseForward = parseGen '>' GoForward
parseIncrement = parseGen '+' Increment
parseDecrement = parseGen '-' Decrement
parseInput = parseGen ',' Input
parseOutput = parseGen '.' Output

parseLoop = do
  char '['
  insn <- parseInstructions
  char ']'
  return $ Loop insn

parseComment :: Parser ()
parseComment = do
  many $ noneOf "<>+-,.[]"
  return ()

parseInstruction :: Parser BFInstruction
parseInstruction = do
  parseComment
  i <- parseBack <|> parseForward <|> parseIncrement <|> parseDecrement
       <|> parseInput <|> parseOutput <|> parseLoop
  parseComment
  return i

parseInstructions :: Parser [BFInstruction]
parseInstructions = many parseInstruction

type BFRunner = StateT (Int, M.IntMap Word8) IO ()

zeroise :: Maybe Word8 -> Word8
zeroise = maybe 0 id

runInstruction :: BFInstruction -> BFRunner

runInstruction GoBack = modify (\(h,m) -> (h-1, m))
runInstruction GoForward = modify (\(h,m) -> (h+1, m))
runInstruction Increment = do
  (bfHead, bfMap) <- get
  let val = zeroise (M.lookup bfHead bfMap)
  put (bfHead, M.insert bfHead (val + 1) bfMap)
runInstruction Decrement = do
  (bfHead, bfMap) <- get
  let val = zeroise (M.lookup bfHead bfMap)
  put (bfHead, M.insert bfHead (val - 1) bfMap)
runInstruction Input = do
  (bfHead, bfMap) <- get
  c <- liftIO getChar
  put (bfHead, M.insert bfHead (fromIntegral (fromEnum c)) bfMap)
runInstruction Output = do
  (bfHead, bfMap) <- get
  let val = zeroise (M.lookup bfHead bfMap)
  liftIO $ putChar $ toEnum $ fromIntegral val
runInstruction loop@(Loop insns) = do
  (bfHead, bfMap) <- get
  let val = zeroise (M.lookup bfHead bfMap)
  case val of
    0 -> return ()
    _ -> runInstructions insns >> runInstruction loop

runInstructions :: [BFInstruction] -> BFRunner
runInstructions = mapM_ runInstruction

--------------------- Options --------------------------------
data Action = ParseOnly | Interpret | Bitcode deriving (Show, Eq)

data Options = Options
               { optHelp :: Bool
               , optVersion :: Bool
               , optAction :: Action
               }
               deriving (Show)

defaultOptions :: Options
defaultOptions =
  Options { optHelp = False
          , optVersion = False
          , optAction = Interpret
          }

options :: [OptDescr (Options -> Options)]
options = [ Option ['v']     ["version"]
            (NoArg (\ opts -> opts { optVersion = True }))
            "show the version of the bf interpreter"
          , Option ['h']     ["help"]
            (NoArg (\ opts -> opts { optHelp = True }))
            "show help for the bf interpreter"
          , Option ['p']     ["parse"]
            (NoArg (\ opts -> opts { optAction = ParseOnly }))
            "parse the input and display it"
          , Option ['i']     ["interpret"]
            (NoArg (\ opts -> opts { optAction = Interpret }))
            "parse the input and interpret it"
          , Option ['c']     ["bitcode"]
            (NoArg (\ opts -> opts { optAction = Bitcode }))
            "parse the input and outputs a bitcode file"
          ]

usage :: String
usage = usageInfo header options
  where
    header = "Usage: bf [OPTION...] filename\n\n"

bfOptions :: [String] -> IO (Options, Maybe String)
bfOptions argv =
  case getOpt Permute options argv of
    (o, [n], []  ) -> return (foldl (flip id) defaultOptions o, Just n)
    (o, _,   []  ) -> return (foldl (flip id) defaultOptions o, Nothing)
    (_, _,   errs) -> ioError $ userError $ concat errs ++ usage

---------- Compiler ------------

compileBody :: [BFInstruction] -> CodeGenModule (Function (IO Word32))
compileBody insn = do
  getc <- newNamedFunction ExternalLinkage "getchar" :: TFunction (IO Word8)
  putc <- newNamedFunction ExternalLinkage "putchar" :: TFunction (Word8 -> IO ())
  bzero <- newNamedFunction ExternalLinkage "bzero"  :: TFunction (Ptr Word8 -> Word32 -> IO ())

  createNamedFunction ExternalLinkage "main" $ do
    headp <- alloca
    tape <- (arrayAlloca (65536 :: Word32)) :: CodeGenFunction r0 (Value (Ptr Word8))
    store (value zero) headp

    call bzero tape $ valueOf 65536

    let compileInstruction :: BFInstruction -> CodeGenFunction r0 Terminate
        compileInstruction GoBack = do
          head' <- load (headp :: Value (Ptr Word16))
          head'' <- isub head' (1 :: Word16)
          store head'' headp

        compileInstruction GoForward = do
          head' <- load (headp :: Value (Ptr Word16))
          head'' <- iadd head' (1 :: Word16)
          store head'' headp

        compileInstruction Increment = do
          head' <- load (headp :: Value (Ptr Word16))
          head'' <- zext head'
          vp <- getElementPtr tape ((head'' :: Value Word32), ())
          val <- load vp
          val' <- iadd val (1 :: Word8)
          store val' vp

        compileInstruction Decrement = do
          head' <- load (headp :: Value (Ptr Word16))
          head'' <- zext head'
          vp <- getElementPtr tape ((head'' :: Value Word32), ())
          val <- load vp
          val' <- isub val (1 :: Word8)
          store val' vp

        compileInstruction Input = do
          head' <- load (headp :: Value (Ptr Word16))
          head'' <- zext head'
          vp <- getElementPtr tape ((head'' :: Value Word32), ())
          c <- call getc
          store c vp

        compileInstruction Output = do
          head' <- load (headp :: Value (Ptr Word16))
          head'' <- zext head'
          vp <- getElementPtr tape ((head'' :: Value Word32), ())
          c <- load vp
          call putc c
          return ()

        compileInstruction (Loop is') = do
          loop <- newBasicBlock
          body <- newBasicBlock
          exit <- newBasicBlock

          br loop

          defineBasicBlock loop

          head' <- load (headp :: Value (Ptr Word16))
          head'' <- zext head'
          vp <- getElementPtr tape ((head'' :: Value Word32), ())
          c <- load vp
          t <- cmp CmpNE c (0::Word8)
          condBr t body exit

          defineBasicBlock body
          compileInstructions is'
          br loop

          defineBasicBlock exit

        compileInstructions = mapM_ compileInstruction

    compileInstructions insn
    ret (0 :: Word32)


writeBitcodeFile :: [BFInstruction] -> FilePath -> IO ()
writeBitcodeFile insns fname = do
  m <- newModule
  defineModule m (compileBody insns)
  optimizeModule 100 m
  writeBitcodeToFile fname m

main :: IO ()
main = do
  argv <- getArgs
  (opts, fname) <- bfOptions argv

  when (optVersion opts) $ do
    putStrLn "bf Version 1"
    exitSuccess
  when (optHelp opts) $ do
    putStrLn usage
    exitSuccess
  when (fname == Nothing) $ do
    putStrLn "You must supply exactly one file name to bf\n"
    putStrLn usage
    exitFailure
  let fname' = fromJust fname
  let action = optAction opts
  cont <- readFile fname'
  case parse parseInstructions fname' cont of
    Left e -> print e
    Right insns -> do
      case action of
        ParseOnly -> print insns
        Interpret -> evalStateT (runInstructions insns) (0, M.empty)
        Bitcode -> writeBitcodeFile insns (replaceExtension fname' ".bc")