279 lines
9.9 KiB
Haskell
279 lines
9.9 KiB
Haskell
module Main where
|
|
|
|
import Control.Monad
|
|
import Data.Binary
|
|
import Data.Bits
|
|
import qualified Data.ByteString as BS
|
|
import qualified Data.IntMap.Strict as M
|
|
import qualified Data.Vector.Unboxed.Mutable as V
|
|
import GHC.IO.Handle.FD (isEOF, stdout)
|
|
import System.Environment
|
|
import System.IO (hSetBinaryMode)
|
|
|
|
data UniversalMachine = UM { umRegisters :: V.IOVector Word32
|
|
, umArrays :: M.IntMap (V.IOVector Word32)
|
|
, umArrayId :: !Word32
|
|
, umFinger :: !Word32
|
|
}
|
|
|
|
data OpNumber = CondMove
|
|
-- ^ The register A receives the value in register B, unless
|
|
-- the register C contains 0
|
|
| ArrIndex
|
|
-- ^ The register A receives the value stored at offset in
|
|
-- register C in the array identified by B
|
|
| ArrAmend
|
|
-- ^ The array identified by A is amended at the offset in
|
|
-- register B to store the value in register C
|
|
| Add
|
|
-- ^ The register A receives the value in register B plus the
|
|
-- value in register C, modulo 2^32
|
|
| Mult
|
|
-- ^ The register A receives the value in register B times the
|
|
-- value in register C, modulo 2^32
|
|
| Div
|
|
-- ^ The register A receives the value in register B divided
|
|
-- by the value in register C, if any, where each quantity is
|
|
-- treated as an unsigned 32 bit number
|
|
| NotAnd
|
|
-- ^ Each bit in the register A receives the 1 bit if either
|
|
-- register B or register C has a 0 bit in that position.
|
|
-- Otherwise the bit in register A receives the 0 bit.
|
|
| Halt
|
|
-- ^ The universal machine stops computation.
|
|
| Alloc
|
|
-- ^ A new array is created with a capacity of platters
|
|
-- commensurate to the value in the register C. This new array
|
|
-- is initialized entirely with platters holding the value 0.
|
|
-- A bit pattern not consisting of exclusively the 0 bit, and
|
|
-- that identifies no other active allocated array, is placed
|
|
-- in the B register.
|
|
| Abandon
|
|
-- ^ The array identified by the register C is abandoned.
|
|
-- Future allocations may reuse the identifier.
|
|
| Output
|
|
-- ^ The value in register C is displayed on the console
|
|
-- immediately. Only values between and including 0 and 255 are
|
|
-- allowed.
|
|
| Input
|
|
-- ^ The universal machine waits for input on the console.
|
|
-- When input arrives, the register C is loaded with the input,
|
|
-- which must be between and including 0 and 255. If the end of
|
|
-- input has been signaled, then the register C is endowed with
|
|
-- a uniform value pattern where every place is pregnant with
|
|
-- the 1 bit.
|
|
| LoadProg
|
|
-- ^ The array identified by the B register is duplicated and
|
|
-- the duplicate shall replace the '0' array, regardless of
|
|
-- size. The execution finger is placed to indicate the platter
|
|
-- of this array that is described by the offset given in C,
|
|
-- where the value of 0 denotes the first platter, 1 the
|
|
-- second, et cetera.
|
|
--
|
|
-- The '0' array shall be the most sublime choice for loading,
|
|
-- and shall be handled with the utmost velocity.
|
|
| Orthography
|
|
-- ^ The value indicated is loaded into the register A
|
|
-- forthwith.
|
|
deriving (Eq, Ord, Enum, Bounded, Show, Read)
|
|
|
|
data Operator = Std { op :: !OpNumber
|
|
, argA :: !Word8
|
|
, argB :: !Word8
|
|
, argC :: !Word8
|
|
}
|
|
| Spl { op :: !OpNumber
|
|
, argA :: !Word8
|
|
, val :: !Word32
|
|
}
|
|
deriving (Eq, Show, Read)
|
|
|
|
|
|
opDecode :: Word32 -> Operator
|
|
opDecode p = let op_ = fromIntegral (p `shiftR` 28)
|
|
argA_ = fromIntegral (p `shiftR` 6) .&. 0x7
|
|
argB_ = fromIntegral (p `shiftR` 3) .&. 0x7
|
|
argC_ = fromIntegral p .&. 0x7
|
|
splA_ = fromIntegral (p `shiftR` 25) .&. 0x7
|
|
val_ = fromIntegral p .&. 0x01ffffff
|
|
name_ = toEnum op_
|
|
in case name_ of
|
|
Orthography -> Spl name_ splA_ val_
|
|
_ -> Std name_ argA_ argB_ argC_
|
|
|
|
fetchReg :: Word8 -> UniversalMachine -> IO Word32
|
|
fetchReg r um = umRegisters um `V.read` fromIntegral r
|
|
|
|
setReg :: Word8 -> Word32 -> UniversalMachine -> IO ()
|
|
setReg r num um = V.write (umRegisters um) (fromIntegral r) num
|
|
|
|
fetchMem :: Word32 -> Word32 -> UniversalMachine -> IO Word32
|
|
fetchMem arr off um = do
|
|
let bank = umArrays um M.! fromIntegral arr
|
|
bank `V.read` fromIntegral off
|
|
|
|
allocMem :: Word32 -> UniversalMachine -> IO (Word32, UniversalMachine)
|
|
allocMem size um = do
|
|
arr <- V.replicate (fromIntegral size) 0
|
|
let idx = umArrayId um
|
|
let newArrays = M.insert (fromIntegral idx) arr (umArrays um)
|
|
return (idx, um{ umArrays = newArrays, umArrayId = idx+1 })
|
|
|
|
freeMem :: Word32 -> UniversalMachine -> IO UniversalMachine
|
|
freeMem idx um = do
|
|
let newArrays = M.delete (fromIntegral idx) (umArrays um)
|
|
return um{ umArrays = newArrays }
|
|
|
|
writeMem :: Word32 -> Word32 -> Word32 -> UniversalMachine -> IO ()
|
|
writeMem arr off num um = do
|
|
let targetArr = umArrays um M.! fromIntegral arr
|
|
targetArr `V.write` fromIntegral off $ num
|
|
|
|
incFinger :: UniversalMachine -> UniversalMachine
|
|
incFinger um@(UM { umFinger = f }) = um { umFinger = f + 1 }
|
|
|
|
|
|
opExec :: Operator -> UniversalMachine -> IO UniversalMachine
|
|
|
|
opExec oper@(Std { op = CondMove }) um = do
|
|
c <- fetchReg (argC oper) um
|
|
unless (c == 0) $ do
|
|
b <- fetchReg (argB oper) um
|
|
setReg (argA oper) b um
|
|
return um
|
|
|
|
opExec oper@(Std { op = ArrIndex }) um = do
|
|
arr <- fetchReg (argB oper) um
|
|
off <- fetchReg (argC oper) um
|
|
num <- fetchMem (fromIntegral arr) (fromIntegral off) um
|
|
setReg (argA oper) num um
|
|
return um
|
|
|
|
opExec oper@(Std { op = ArrAmend }) um = do
|
|
arr <- fetchReg (argA oper) um
|
|
off <- fetchReg (argB oper) um
|
|
num <- fetchReg (argC oper) um
|
|
writeMem (fromIntegral arr) (fromIntegral off) num um
|
|
return um
|
|
|
|
opExec oper@(Std { op = Add }) um = do
|
|
b <- fetchReg (argB oper) um
|
|
c <- fetchReg (argC oper) um
|
|
let num = b + c
|
|
setReg (argA oper) num um
|
|
return um
|
|
|
|
opExec oper@(Std { op = Mult }) um = do
|
|
b <- fetchReg (argB oper) um
|
|
c <- fetchReg (argC oper) um
|
|
let num = b * c
|
|
setReg (argA oper) num um
|
|
return um
|
|
|
|
opExec oper@(Std { op = Div }) um = do
|
|
b <- fetchReg (argB oper) um
|
|
c <- fetchReg (argC oper) um
|
|
let num = b `div` c
|
|
unless (c == 0) $ setReg (argA oper) num um
|
|
return um
|
|
|
|
opExec oper@(Std { op = NotAnd }) um = do
|
|
b <- fetchReg (argB oper) um
|
|
c <- fetchReg (argC oper) um
|
|
let num = complement (b .&. c)
|
|
setReg (argA oper) num um
|
|
return um
|
|
|
|
opExec (Std { op = Halt }) _ = error "Halted!"
|
|
|
|
opExec oper@(Std { op = Alloc }) um = do
|
|
size <- fetchReg (argC oper) um
|
|
(addr, um') <- allocMem size um
|
|
setReg (argB oper) addr um'
|
|
return um'
|
|
|
|
opExec oper@(Std { op = Abandon }) um = do
|
|
c <- fetchReg (argC oper) um
|
|
freeMem c um
|
|
|
|
opExec oper@(Std { op = Output }) um = do
|
|
c <- fetchReg (argC oper) um
|
|
BS.hPut stdout $ BS.singleton (fromIntegral c)
|
|
return um
|
|
|
|
opExec oper@(Std { op = Input }) um = do
|
|
eof <- isEOF
|
|
c <- if eof then return 0xffffffff
|
|
else liftM (fromIntegral . fromEnum) getChar
|
|
setReg (argC oper) c um
|
|
return um
|
|
|
|
opExec oper@(Std { op = LoadProg }) um = do
|
|
b <- fetchReg (argB oper) um
|
|
c <- fetchReg (argC oper) um
|
|
if b /= 0 then
|
|
do let bank = umArrays um M.! fromIntegral b
|
|
newbank <- V.clone bank
|
|
let newarrays = M.insert 0 newbank (umArrays um)
|
|
return um { umFinger = c, umArrays = newarrays }
|
|
else return (um { umFinger = c })
|
|
|
|
opExec (Spl { op = Orthography
|
|
, argA = a
|
|
, val = v }) um = do
|
|
setReg a v um
|
|
return um
|
|
|
|
bytesToWord :: BS.ByteString -> (Word32, BS.ByteString)
|
|
bytesToWord bs = let a = BS.index bs 0
|
|
b = BS.index bs 1
|
|
c = BS.index bs 2
|
|
d = BS.index bs 3
|
|
in
|
|
((fromIntegral a :: Word32) `shiftL` 24 .|.
|
|
(fromIntegral b :: Word32) `shiftL` 16 .|.
|
|
(fromIntegral c :: Word32) `shiftL` 8 .|.
|
|
(fromIntegral d :: Word32), BS.drop 4 bs)
|
|
|
|
loadProgram :: String -> IO (V.IOVector Word32)
|
|
loadProgram file = do
|
|
chars <- BS.readFile file
|
|
prog <- V.replicate (BS.length chars `div` 4) 0
|
|
go chars 0 prog
|
|
return prog
|
|
where
|
|
go bs i vec = do
|
|
let (w32, rest) = bytesToWord bs
|
|
vec `V.write` i $ w32
|
|
unless (BS.length rest < 4) $ go rest (i+1) vec
|
|
|
|
newUM :: String -> IO UniversalMachine
|
|
newUM file = do
|
|
regs <- V.replicate 8 0
|
|
progVec <- loadProgram file
|
|
let arrays = M.fromList [(0, progVec)]
|
|
putStrLn "Finished loading Universal Machine!"
|
|
return UM { umRegisters = regs
|
|
, umArrays = arrays
|
|
, umArrayId = 1
|
|
, umFinger = 0
|
|
}
|
|
|
|
spin :: UniversalMachine -> IO UniversalMachine
|
|
spin um@UM{ umFinger = finger } = do
|
|
oper <- fetchMem 0 (fromIntegral finger) um
|
|
um2 <- opExec (opDecode oper) (incFinger um)
|
|
spin um2
|
|
|
|
|
|
main :: IO ()
|
|
main = do
|
|
args <- getArgs
|
|
hSetBinaryMode stdout True
|
|
case args of
|
|
[] -> putStrLn "Usage: um <filename>"
|
|
fname : _ -> do
|
|
um <- newUM fname
|
|
spin um
|
|
return ()
|