qute

  1-- SPDX-FileCopyrightText: 2025 Sören Tempel <soeren+git@soeren-tempel.net>
  2--
  3-- SPDX-License-Identifier: GPL-3.0-only
  4
  5module Language.QBE.Simulator.Default.Funcs (lookupSimFunc) where
  6
  7import Control.Monad.Error.Class (throwError)
  8import Control.Monad.IO.Class (MonadIO, liftIO)
  9import Data.Array (Array, bounds, listArray, (!))
 10import Data.Bits ((.&.))
 11import Data.ByteString.Lazy qualified as B
 12import Data.Word (Word32, Word64)
 13import Language.QBE.Simulator.ABI.C (charRepr, readArray, writeBuffer)
 14import Language.QBE.Simulator.ABI.Errno qualified as ERR
 15import Language.QBE.Simulator.ABI.POSIX qualified as POSIX
 16import Language.QBE.Simulator.Error (EvalError (FuncArgsMismatch))
 17import Language.QBE.Simulator.Expression qualified as E
 18import Language.QBE.Simulator.State (Simulator, toAddress)
 19import Language.QBE.Types qualified as QBE
 20import System.Exit (ExitCode (ExitFailure), exitWith)
 21import System.IO (Handle, stderr, stdin, stdout)
 22
 23mkErrno :: (E.ValueRepr v) => ERR.Errno -> v
 24mkErrno err =
 25  E.fromLit (QBE.Base QBE.Long) $
 26    -(fromIntegral $ ERR.errno err)
 27
 28fromByteString :: (E.ValueRepr v) => B.ByteString -> [v]
 29fromByteString = map (E.fromLit QBE.Byte . fromIntegral) . B.unpack
 30
 31toByteString :: (E.ValueRepr v) => [v] -> B.ByteString
 32toByteString = B.pack . map (fromIntegral . E.toWord64)
 33
 34readArray' :: (Simulator m v, E.ValueRepr v) => v -> QBE.LoadType -> v -> m [v]
 35readArray' startPtr elemTy size = do
 36  startAddr <- toAddress startPtr
 37  readArray startAddr elemTy $ E.toWord64 size
 38
 39writeBuffer' :: (Simulator m v, E.ValueRepr v) => v -> [v] -> m ()
 40writeBuffer' startPtr elems = do
 41  startAddr <- toAddress startPtr
 42  writeBuffer startAddr elems
 43
 44------------------------------------------------------------------------
 45
 46data FileEntry
 47  = FileEntry
 48  { fdFlags :: Word32,
 49    -- TODO: Use a polymoprh representation for `fdHandle` which is
 50    -- parameterized over a `ValueRepr` to allow an implementation
 51    -- of custom file-like objects.
 52    fdHandle :: Handle
 53  }
 54
 55isWritable :: FileEntry -> Bool
 56isWritable FileEntry {fdFlags = flags} =
 57  flags .&. POSIX.oWRONLY /= 0
 58
 59isReadable :: FileEntry -> Bool
 60isReadable FileEntry {fdFlags = flags} =
 61  flags == POSIX.oRDONLY || flags == POSIX.oRDWR
 62
 63writeEntry :: (MonadIO m, E.ValueRepr v) => FileEntry -> [v] -> m (Maybe Word64)
 64writeEntry entry bytes
 65  | isWritable entry = do
 66      let bs = toByteString bytes
 67      liftIO $ B.hPut (fdHandle entry) bs
 68      pure $ Just (fromIntegral $ B.length bs)
 69  | otherwise = pure Nothing
 70
 71readEntry :: (MonadIO m, E.ValueRepr v) => FileEntry -> Int -> m (Maybe [v])
 72readEntry entry num
 73  | isReadable entry = do
 74      bs <- liftIO $ B.hGet (fdHandle entry) num
 75      pure $ Just (fromByteString bs)
 76  | otherwise = pure Nothing
 77
 78------------------------------------------------------------------------
 79
 80-- TODO: Track open files in the Simulator Env to allow opening files.
 81openFiles :: Array Int FileEntry
 82openFiles =
 83  listArray
 84    (0, 2)
 85    [ FileEntry POSIX.oRDONLY stdin,
 86      FileEntry POSIX.oWRONLY stdout,
 87      FileEntry POSIX.oWRONLY stderr
 88    ]
 89
 90getFile :: Int -> Maybe FileEntry
 91getFile fd =
 92  let (_, fdMax) = bounds openFiles
 93   in if fd > fdMax
 94        then Nothing
 95        else Just $ openFiles ! fd
 96
 97------------------------------------------------------------------------
 98
 99sysWrite :: (MonadIO m, E.ValueRepr v, Simulator m v) => QBE.GlobalIdent -> [v] -> m (Maybe v)
100sysWrite _ [fd, arrayPtr, size] = do
101  case getFile (fromIntegral $ E.toWord64 fd) of
102    Nothing -> pure $ Just (mkErrno ERR.EBADF)
103    Just fe -> do
104      bArray <- readArray' arrayPtr charRepr size
105      retVal <- writeEntry fe bArray
106      pure $ case retVal of
107        Nothing -> Just $ mkErrno ERR.EIO
108        Just nb -> Just $ E.fromLit (QBE.Base QBE.Word) nb
109sysWrite ident _ = throwError $ FuncArgsMismatch ident
110
111sysRead :: (MonadIO m, E.ValueRepr v, Simulator m v) => QBE.GlobalIdent -> [v] -> m (Maybe v)
112sysRead _ [fd, bufPtr, bufSize] = do
113  case getFile (fromIntegral $ E.toWord64 fd) of
114    Nothing -> pure $ Just (mkErrno ERR.EBADF)
115    Just fe -> do
116      retVal <- readEntry fe (fromIntegral $ E.toWord64 bufSize)
117      case retVal of
118        Nothing -> pure $ Just (mkErrno ERR.EIO)
119        Just nb -> do
120          writeBuffer' bufPtr nb
121          let nread = fromIntegral (length nb)
122           in pure $ Just (E.fromLit (QBE.Base QBE.Word) nread)
123sysRead ident _ = throwError $ FuncArgsMismatch ident
124
125sysExit :: (MonadIO m, E.ValueRepr v, Simulator m v) => QBE.GlobalIdent -> [v] -> m (Maybe v)
126sysExit _ [status] =
127  let code = fromIntegral $ E.toWord64 status
128   in liftIO $ exitWith (ExitFailure code)
129sysExit ident _ = throwError $ FuncArgsMismatch ident
130
131------------------------------------------------------------------------
132
133-- TODO: Register functions dynamically.
134lookupSimFunc ::
135  (MonadIO m, E.ValueRepr v, Simulator m v) =>
136  QBE.GlobalIdent ->
137  Maybe ([v] -> m (Maybe v))
138lookupSimFunc i@(QBE.GlobalIdent "qute_exit") = Just (sysExit i)
139lookupSimFunc i@(QBE.GlobalIdent "qute_read") = Just (sysRead i)
140lookupSimFunc i@(QBE.GlobalIdent "qute_write") = Just (sysWrite i)
141lookupSimFunc _ = Nothing