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 " fname : _ -> do um <- newUM fname spin um return ()