Pull to refresh

В поисках жирного (The Quest For FAT)

Haskell
При разработке некоего программно-аппаратного комплекса потребовалось создать клиентское устройство, которое для прочих устройств должно выглядеть как обычная USB-флешка, или если более формально, то USB Mass Storage Device. Необычность устройства в том, что оно должно имитировать для внешнего мира файловую систему FAT с файлами достаточно большого размера (2GB и и более), при том, что сами файлы на устройстве, конечно, отсутствуют и находятся в сети. Да и вообще это не файлы, а некие аудио-потоки.

Задача, на первый взгляд, простая: на каждый запрос на чтение блока (команду SCSI) отдаем содержимое этого блока. Блок может либо принадлежать какому-нибудь из «файлов», либо содержать служебную информацию FAT.

Первая мысль была, конечно, запаковать образ FAT при помощи, например, bzip2 и распаковывать на устройстве по мере надобности. Проблем возникает сразу три:

  • Сжатый образ файловой системы из пятка 100-мегабайтных файлов и нескольких каталогов занимает что-то около 125Kb, что превышает объем RAM на устройстве.
  • Bzip2, видимо, не знает ничего о секторах и работает на уровне потоков, следовательно, упаковывать придется посекторно, следовательно размеры образа будут совсем запредельными: как известно, паковать маленькими блоками невыгодно — накладные расходы велики по сравнению с выигрышем от сжатия.
  • Подготовка образа (монтирование пустого файла, создание файловой системы, запаковка) занимает немало времени и едва ли приемлема для реализации на сервере с рассчетными тысячами пользователей. Да и сам образ в процессе создания требует какого-то достаточно заметного места на дисках.


Ну это не говоря вообще о том, что придется портировать bzip2 на микроконтроллер.

Таким образом, нужно было придумать что-то еще.

Задачу можно поставить следующим образом: необходимо написать код, который будет принимать на вход некоторое описание файловой системы в каком-то виде, и на каждый запрос номера сектора возвращать его содержимое. Содержимым является либо служебная информация, либо данные файла, которые берутся из соответствующего ему аудиопотока по заданному URL.

Такая постановка вопроса приводит нас к системе правил:


Номер сектора => Содержимое сектора


Заметим, что речь идет именно о секторах, а не «кластерах», так как кластер — это понятие самой файловой системы FAT. Устройства работают на уровне блоков, они же секторы. Допустим, наш «плейлист» содержит 10 «файлов» по 2Gb каждый (2Gb — это такое практическое приближение к бесконечности). Если каждое правило имеет размер один байт, что, конечно, невозможно, то у нас получается.

2*1024*1024*1024 * 10 / 512 = 41 943 040


байт на все правила. Несколько больше разумного. Но, естественно, правила не уникальны для каждого сектора. Будем задавать правила для диапазонов секторов. Это приводит нас к набору правил:

Номер сектора (A) => Содержимое сектора
Диапазон секторов (A,B) => Содержимое сектора


Попробуем упаковать также сами сектора. Поскольку задачи сжатия данных перед нами не стоит — сами-то данные в устройстве отсутствуют и берутся из Сети, то нужно просто как-то более-менее компактно представлять служебные данные самой файловой системы. На первый взгляд, в этих данных много повторяющихся последовательностей, так что будем кодировать следующим образом: повторяющиеся последовательности представляем как

(Признак RLE, Количество, Символ)


Неповторяющиеся последовательности представим как

(Признак Sequence, Последовательность символов)


Кроме того, те последовательности которые мы уже закодировали, или их части хорошо бы не вставлять повторно, а ссылаться на них. Вероятно, у нас появляется еще последовательность

(Вызов последовательности, идентификатор)


Возможно в процессе реализации могут появится и другие последовательности для более компактного представления структур файловой системы.

Все это очень похоже на систему команд какой-то виртуальной машины, а раз есть вызовы, то есть и стек. Наиболее простая из известных виртуальных машин — это какая-нибудь из разновидностей форта. Фактически, это обратная
польская запись на стероидах, с добавленным стеком адресов возврата из вызовов, которая избавляет от необходимости возиться с организацией фреймов функций: все предельно просто — при возврате из вызова снимаем
верхнее слово со стека R и переходим по адресу, на который оно указывает.

Кроме того, token threaded код (а это будет именно он) для двухстековой машины обладает очень хорошой плотностью, что нас, в данном случае, очень устраивает.

Интерпретировать такой код быстро, получается всего в среднем в пять раз медленнее, чем нативный код, и к тому же очень просто.

Итак, у нас есть какая-то система кодирования, система правил и некая виртуальная машина на которой эти правила должны проигрываться.

Осталось сгенерировать эти правила из некоего описания, получить байткод и реализовать машину для его интерпретации. И только потом мы увидим, что получилось.

С реализацией виртуальной машины ситуация простая: работать она будет на микроконтроллере, соответственно, тут пока без вариантов Си. Правда, возможно что писать там нечего — получится ее сгенерировать каким-нибудь
образом.

Остается генерация системы правил из описания, само описание, генерация кода и описание команд этого кода. Кроме того, правила хорошо бы проверять не последовательно, а как-то более разумно: организовать проверки в виде
дерева сравнений, так что бы количество сравнений на каждый сектор было порядка бинарного логарифма от количества сравнений.

C первичным анализом закончили, надо бы сделать прототип и посмотреть, что у нас получится.

Нам понадобится генерация и, возможно, чтение бинарных данных различной размерности и эндианности (служебные данные FAT записываются в low-endian формате) и работа с вложенными структурами данных.

На чем бы это реализовать? C, С++ или, может, Python? Или Ruby? Шутка.
Разумеется, будем делать на Haskell: задача не самая простая, требуется какая-никакая производительность, да и времени у нас немного. Ну и все равно, сервер, который будет вызывать этот код, реализован тоже на
Haskell, так что выбор вполне естественный.

Приступим.

Центральной вещью в системе являются «правила». В них преобразуется описание файловой системы, из них генерируется код. Опишем их:

data Rule = REQ Int [Chunk] | RANGE Int Int [Chunk] deriving Show
data Chunk = SEQ BS.ByteString
| RLE Int Word8
deriving (Eq, Ord)


Кроме того, есть описание самой файловой системы, которая состоит из каталогов и файлов, с некоторой спецификой самой FAT.

data Entry =  DirRoot Int [Entry]
            | DirDot     Int
            | DirDotDot  Int
            | Dir Int String [Entry]
            | File Int String Int BS.ByteString
    deriving (Eq, Ord, Data, Typeable, Show)



Тут остановимся подробнее. Странные конструкторы DirDor и DirDotDot — не что иное, как каталоги '.' и '..', которые — вот сюрприз — являются первоклассными, физически присутствующими записями каталогов. К счастью, они
являются только ссылками и не требуют для себя выделения кластеров.

В остальном все довольно очевидно: первым атрибутом конструкторов типа является уникальный идентификатор. Он явно может пригодиться нам, что бы разбираться в прошивке, из какого «файла» были запрошены данные.

Вторым атрибутом является имя файла. В случае файла добавим так же его размер и данные. Это, конечно, не данные самого файла, а какое-то указание прошивке устройства, откуда эти данные брать. Туда можно записать, например, сишную структуру или URL потока. Поэтому ByteString.

Теперь нам нужно как-то сконструировать Entry, учитывая требования файловой системы: каждый каталог, кроме корневого должен содержать записи '.' и '..', они должны ссылаться на соответствующие им каталоги, не должно быть
одинаковых имен записей, названия не должны содержать запрещенных символов ну и так далее и так далее. Видно, что вручную эту структуру создавать тяжело, кроме того этим должен заниматься пользователь API, а он обязательно что-нибудь перепутает и все сломается, а дело серьезное. Так что лучше запретим импорт содержимого типа Entry из нашего модуля, и предоставим пользователю какое-нибудь более удобное и защищенное от ошибок решение. Что-нибудь наподобие:

fileContents = ... 

fatSample2 = filesystem $ do
    file "file0" (16384) fileContents 
    dir "A" $ do
      file "file1" (megs 100) fileContents 
      dir "C" $ do
        file "file3" (megs 100) fileContents 
        file "file4" (megs 100) fileContents 
        file "file5" (megs 100) fileContents 
        dir "E" $ emptyDir 
      
     dir "B" $ do
       file "file2" (megs 50) emptyFile



Выглядит неплохо, даже не знающий языка может понять, что тут описывается.
Реализовать несложно: для генерации чего попало уже есть готовая монада Writer.

Кроме того, нам понадобится раздавать уникальные идентификаторы, так что пригодится еще и State, куда мы и положим какой-нибудь счетчик. Поскольку мы хотим скрестить State и Writer, нам не помешает монадный трансформер. Приблизительно так:

newtype EntryIdT m a = EntryIdT {
    runF :: (WriterT [Entry] (StateT (Int, Int) m)) a 
} deriving (Monad, MonadWriter [Entry], MonadState (Int, Int))

type EntryIdM = EntryIdT Identity

runEntryIdM :: (Int, Int) -> EntryIdM a -> ([Entry], (Int, Int))
runEntryIdM init f = runState (execWriterT (runF f)) init

filesystem :: EntryIdM () -> Entry
filesystem f = DirRoot 0 dirs
  where dirs = fst $ runEntryIdM (1,0) f

dir :: String -> EntryIdM () -> EntryIdM ()
file :: String -> Int -> (EntryInfo -> BS.ByteString) -> EntryIdM ()



Каждая функция принимает параметры вроде имени, размера и еще монадическое значение для конструирования вложенных записей. Каждое такое вычисление будет запускаться в отдельном Writer, а State будет протаскиваться общий, что бы гарантировать уникальность идентификаторов.

Итак, структуру каталогов задали, теперь нам нужно получить из нее каким-то образом правила.

Для этого нужно как-то разместить данные файлов и каталогов на «диске».
Будем считать, что они размещаются последовательно, сначала каталоги, потом файлы:

data AllocEntry = AllocEntry { beginSect :: Int
                             , endSect   :: Int
                             , entry     :: Entry
                             } deriving (Show)

allocate :: ClustSize32 -> Int -> Entry -> [AllocEntry]
allocate cl from = eFix . eAlloc . eOrder . filter eFilt . universe
  where eFilt (File _ _ _ _) = True
        eFilt (Dir _ _ _)    = True
        eFilt (DirRoot _ _)  = True
        eFilt _            = False
        eOrder = uncurry (++) . partition (not.isFile)
        eAlloc = reverse . snd . foldl fentry (from, [])
        fentry (n, xs) e =
          let sectors = entryLen cl e `div` fatSectLen
              begin = n
              end   = begin + sectors - 1
              n'    = n + sectors
              allocated = AllocEntry begin end e
          in (n', allocated : xs)
        eFix = id



Код в целом достаточно очевиден: берем все записи, убираем '.' и '..' которые не имеют собственных кластеров, а только указывают на чужие, делаем так, что бы сначала шли каталоги, потом файлы (разницы нет, но так логичнее,
да и оглавление тома будет быстрее читаться), выделяем секторы (нам удобнее работать с секторами, «кластеры» понятие искусственное) и все.

Стоит отметить функцию universe из модуля uniplate. Она позволяет перечислить все элементы вложенной структуры в виде списка (при желании — с list comprehension), что бы избежать рутинного написания функций рекурсивного обхода.

Именно ради нее мы объявили тип Entry deriving (Data, Typeable) выше.

Имея файлы, размещенные по секторам, нам уже ничего не стоит сгенерировать правила для них:

generateData :: Maybe CalendarTime -> ClustSize32 -> [AllocEntry] -> [Rule]
generateData ct cl es = mergeRules $ execWriter $ do
  forM_ es $ \(AllocEntry {beginSect = a, endSect = b, entry = e}) -> do
    case e of
      DirRoot _ es  -> writeEntries a b es
      Dir _ _ es    -> writeEntries a b es
      File _ _ _ bs -> tell [RANGE a b (encodeBlock (BS.take (fatSectLen) bs))]
  where
    ...



функция encodeBlock здесь умеет кодировать ByteString в последовательность правил, writeEntries — генерирует записи каталогов и кодирует их, а mergeRule пытается объединять диапазоны секторов последовательно идущих правил.

Генерация одной записи каталога выглядит примерно так:

entryRecordShort :: String
                 -> Int
                 -> Int
                 -> Maybe CalendarTime
                 -> [ATTR] 
                 -> BS.ByteString
entryRecordShort nm size clust clk a = runPut $ do
putNameASCII nm -- Name
putWord8 (fatAttrB a) -- Attr
putWord8 0      -- NTRes
putWord8 0      -- CrtTimeTenth
putWord16le cT  -- CrtTime
putWord16le cD  -- CrtDate
putWord16le cD  -- LstAccDate
putWord16le cHi -- FstClusHI
putWord16le cT  -- WrtTime
putWord16le cD  -- WrdDate
putWord16le cLo -- FstClusLO
putWord32le (fromIntegral size) -- FileSize
where ...



Тут используется исключительно полезная монада PutM из Data.Binary.Put, которая позволяет выводить данные любой разрядности и эндианности в ленивую байт-строку.

Итак, у нас есть структура каталогов тома FAT, у нас есть их размещение по секторам и соответствующие правила. Что нам осталось?

Тут нужно отступить немного в сторону и вспомнить устройство FAT. Если не вдаваться в лишние подробности, широко доступные в Сети и литературе, то FAT32 устроен так:

    |BootSect|FAT32 Info|FAT1|FAT2|DATA|


Пока у нас есть только правила для DATA. FAT1 и FAT2 — это таблицы размещения кластеров. Каждый файл или каталог (который тоже файл) занимает цепочку кластеров в области данных, а каждый кластер области данных представлен 32-битным значением в FAT1 и FAT2 (они идентичны).

В каждой ячейки FAT записан номер следующего кластера файла, последний кластер помечен специальным значением. Номер первого кластер файла указывается в записи каталога. Данные у нас размещаются последовательно, так что в каждой ячейке цепочки будет записано число N+1, где N — предыдущее значение.

Здесь возникает первая проблема: для наших рассчетных 10 x 20Gb эта таблица будет занимать целых 655360 32-битных значений, что опять превышает доступную оперативную память. При этом, эти правила не могут быть сжат
нашим примитивным алгоритмом упаковки RLE, так как тут нет повторяющихся значений. Впрочем, раз мы это последовательность смогли сгенерировать один раз, то, наверное, сможем сгенерить и еще раз, уже на устройстве.

Пристальное вглядывание показало, что значения в одном секторе таблицы размещения зависят от максимального значения в предыдущем, а в целом последовательность определяется выражением:

    Na = BASE + (Nsect - M)*STEP
    Ni <- [Na, Na + 1 ..]


где Na — первое значение для данного сектора, Nsect — номер запрошенного сектора (будет на вершине стека нашей форт-машины), M, BASE и STEP — константы, вычисляемые статически, Ni — i-ое число последовательности, а всего в секторе их, очевидно, 512/4.

Таким образом мы обзавелись новой последовательностью, которая генерирует серию значений на основе динамических данных (номера сектора). Добавим типы для этой последовательности и смежных:

data Chunk = SEQ BS.ByteString
           | RLE Int Word8 
           | SER Word32 Word32
           | NSER Word32 Int Word32 -- base offset step
           | CALLBACK Word8
           deriving (Eq, Ord)



Забегая вперед, добавим еще правило для коллбэка, который должен быть вызван после генерации сектора данных файла, что бы прошивка устройства взяла буфер и наполнила его реальными данными.

Можно было бы сразу генерировать таблицу в виде набора правил, но мне зачем-то она понадобилась в бинарном виде, кроме того уже есть отлаженная функция кодирования бинарных строк, а в непосредственной генерации легко
наделать ошибок.

Таблица эта достаточно большая, и в случае большой области данных и маленького размера кластера бедному хаскеллу приходится туго.

В какой-то момент от большого ленивого списка Word32 приложению стало совсем плохо, поэтому пришлось быстро переписать на ленивые байтстроки и использовать runPut / runGet для помещения туда и извлечения оттуда 32-битных значений.

Удивительно, но это привело к ускорению где-то в десять раз и всё стало работать с приемлемой скоростью, хотя, конечно, следует переписать это таким образом, что бы сразу генерировать правила и не создавать данных.
Но для концепта пойдет и так.

Сами функции генерации таблицы и правил для неё опустим, они достаточно большие, но при этом вполне очевидные:
type ClusterTable = BS.ByteString 
genFAT :: ClustSize32 -> Int -> [AllocEntry] -> ClusterTable
encodeFAT :: Int -> ClusterTable -> [Rule]



Функция кодирования таблицы сначала ставит каждому сектору в соответствие одно правило REQ a (NSER _ _ _ ), потом рассматривает секторы попарно и если два сектора образуют общую последовательность значений, то правило для сектора заменяется правилом для диапазона секторов, итог получается достаточно компактен для того, что бы можно было привести его здесь:

REQ 32 [SEQ [F8],RLE 2 255,SEQ [0F],RLE 3 255,SEQ [0F],
        RLE 3 255,SEQ [0F],RLE 3 255,SEQ [0F],RLE 3 255,
        SEQ [0F],RLE 3 255,SEQ [0F],RLE 3 255,SEQ [0F],
        SEQ [08],RLE 3 0,SEQ [09],RLE 3 0,SEQ [0A],
        RLE 3 0,RLE 3 255,SEQ [0F],SER 12 128]
RANGE 33 231 [NSER 129 33 128]
REQ 232 [SER 25601 25610,RLE 3 255,SEQ [0F],SER 25612 25728]
RANGE 233 431 [NSER 25729 233 128]
REQ 432 [SER 51201 51210,RLE 3 255,SEQ [0F],SER 51212 51328]
RANGE 433 631 [NSER 51329 433 128]
REQ 632 [SER 76801 76810,RLE 3 255,SEQ [0F],SER 76812 76928]
RANGE 633 831 [NSER 76929 633 128]
REQ 832 [SER 102401 102410,RLE 3 255,SEQ [0F],SER 102412 102528]
RANGE 833 931 [NSER 102529 833 128]
REQ 932 [SER 115201 115210,RLE 3 255,SEQ [0F],RLE 468 0]
RANGE 933 1056 [RLE 512 0]


Выглядит многообещающе, явно лучше, чем двухмегабайтный кусок данных.
Вторая копия таблицы совпадает с точностью до констант, так что в перспективе можно заменить эту последовательность вычитанием константы из смещения и вызовом первой таблицы. Но это потом.

Итак, у нас ест FAT1, FAT2 и DATA. Остается получить только BootSect и FAT32 Info. Это статические бинарные данные, так что мы опять используем Data.Binary.Put, а потом упакуем в правила.

Эти два модуля (Put и Get) буквально незаменимы и лично я их котирую выше, чем бинарные паттерны в Erlang, хотя это и субъективно.

fatGenBoot32 :: FAT32GenInfo -> BS.ByteString 
fatGenBoot32 info = addRsvd $ runPut $ do
                                -- BOOT AREA   sect0
  putBytes [0xEB, 0x58, 0x90]   --  0 JmpBoot
  putBytes bsOEMName            --    OEMName
  putWord16le bps               --    BytesPerSec
  putWord8 spc                  --    SectPerClust
  putWord16le rsvd              --    ReservedSecCnt
  putWord8 2                    --    NumFATs
  putWord16le 0                 --    RootEntCnt
  putWord16le 0                 --    TotSec16
  putWord8 0xF8                 --    Media
  putWord16le 0                 --    FAT16Sz
  putWord16le 0x3F              --    SectPerTract
  putWord16le 0xFF              --    NumHeads
  putWord32le 0                 --    HiddSec
  putWord32le sectNum           --    TotSec32
                                -- FAT32 Structure
  putWord32le fsect             --    FATSz32
  -- ...
  -- и так далее



Напускаем на результат наш упаковщик, сливаем правила в диапазоны, и получаем окончательный список правил, описывающий всю нашу файловую систему.

Итак, набор правил у нас есть. Осталось сгенерировать для них дерево сравнений и
скомпилировать все это в байткод.

Начнем с дерева:


data CmpTree = GEQ Int CmpTree CmpTree | CODE [Rule]
  deriving (Show)

mkCmpTree :: [Rule] -> CmpTree
mkCmpTree r = mkTree' rulemap
  where rulemap = M.fromList $ map (\x -> (fsect x, x)) r
        splitGeq n m =
          let (a, b, c) = M.splitLookup n m
          in (a, c `M.union` (maybe M.empty (M.singleton n) b))

        mkTree' xs | M.null xs     = CODE [] 
                   | M.size xs < 3 = CODE (map snd (M.toList xs))
                   | otherwise =
          let ks = map fst $ M.toAscList xs
              n = ks !! (length ks `div` 2)
              (le, geq) = splitGeq n xs
          in GEQ n (mkTree' le) (mkTree' geq)



Может не самый оптимальный вариант, но правил получилось менее сотни, можно пока не беспокоиться.

Дело за виртуальной машиной, набором команд и компилятором:

- классификатор команд, команды могут кодироваться разнообразно
- для достижения максимальной компактности
class OpcodeCL a where
  isRLE  :: a -> Bool
  arity0 :: a -> Bool
  arity1 :: a -> Bool
  arity2 :: a -> Bool
  arity3 :: a -> Bool
  firstCode :: a
  lastCode  :: a

data Opcode =  DUP | DROP
             | CONST | CRNG
             | JNZ | JZ | JGQ | JNE | JMP | CALLT | CALL | RET
             | NOT | EQ | NEQ | GT | LE | GQ | LQ | RNG
             | LOADS2 | LOADS3 | LOADS4 | LOADS5 | LOADS6 | LOADS7
             | LOADS8 | LOADS9 | LOADS10 | LOADSN
             | SER | NSER | NSER128
             | RLE1 | RLE2 | RLE3 | RLE4 | RLE5 | RLE6 | RLE7 | RLE8
             | RLE16 | RLE32 | RLE64 | RLE128 | RLE256 | RLE512 | RLEN
             | OUTLE | OUTBE | OUTB
             | NOP
             | CALLN
             | DEBUG
             | EXIT
  deriving (Eq, Ord, Enum, Show)

data CmdArg = W32 Word32 | W16 Word16 | W8 Word8 | ADDR Addr

data Addr = ALabel Label | AOffset Int

data Cmd =  Cmd0 Opcode
          | CmdConst Word32
          | Cmd1 Opcode CmdArg
          | Cmd2 Opcode CmdArg CmdArg
          | Cmd3 Opcode CmdArg CmdArg CmdArg
          | CmdJmp Opcode Addr
          | CmdCondJmp Opcode Addr
          | CmdLabel Label
          | RawByte Word8

type Label = Int

type Block = (Label, [Cmd])




Увы, тут простой системы типов хаскелла начинает не хватать: хочется задать инварианты времени компиляции для команд и их классов, так, что бы, например, нельзя было создать команду с неверным опкодом. Но просто этого сделать нельзя, а вводить отдельный тип для каждого опкода, экзистенциальный тип данных для команды и еще использовать метапрограммирование для генерации опкодов не хочется.

Отложим до лучших времен, обойдемся тем, что есть. Все равно для реализации виртуальной машины придется написать тесты, так что посаженные ошибки всплывут там.

Итак, система команд виртуальной машины есть, теперь нужно скомпилировать в нее дерево сравнений, построенное из наших правил:

mkVMCode :: CmpTree -> [Block]
mkVMCode xs = normalize maxl code
	-- 	skip
    scanT :: CmpTree -> GenM ()
    scanT (GEQ n left right) = do
      s <- newLabel
      l <- runGen' (scanT left)  >>= withLabel
      r <- runGen' (scanT right) >>= withLabel

      _ex <- newLabel

      label s
      dup
      cnst n
      jgq (labelOf r)
      block l >> jmp _ex
      block r >> label _ex

    scanT (CODE [])    = op0 EXIT
    scanT (CODE rules) = mapM_ scanR rules

    scanR :: Rule -> GenM ()
    scanR ( REQ n code ) = do
      s <- newLabel
      code' <- runGen' (scanmC code) >>= withLabel
      ex <- newLabel
 
      label s
      dup
      cnst n
      jne ex
      block code'
      label ex

    scanR ( RANGE a b code ) = do
      s <- newLabel
      code' <- runGen' (scanmC code) >>= withLabel
      ex <- newLabel
 
      label s
      dup
      crng a b
      jz ex
      block code'
      label ex

	--  skip



Здесь применен излюбленный способ генерации всякой всячины при помощи eDSL, построенных поверх монады Writer.

Генерация плоского кода из дерева сравнений приводит к множеству «соплей», например к длинным цепочкам выхода из блоков:

L1:
    ...
    JMP L2

L2:
    JMP L3

L3:
    JMP L4

L4:
    EXIT



прыжкам в следующие блоки и так далее. normalize устраняет эти безобразия, и разбивает код на блоки, каждый из которых начинается с метки, и заканчивается командой безусловного перехода в следующий блок. Внутри блока отсутствуют команды условного или безусловного перехода, они допустимы только в конце. Такие блоки нужны нам для вычисления смещения меток. После него можно слить блоки, избавившись от лишних переходов окончательно.

Напишем инстанс Show для нашего байткода для красивой печати форта и посмотрим, что у нас получается после оптимизации блоков:

...

L215:
    DUP
    CONST 2122
    JGQ L220
    DUP
    CRNG 00000843 00000849
    JZ L235
    RLE512 00
    EXIT
L220:
    DUP
    CRNG 0000084A 000C8869
    JZ L223
    LOADS2
    BYTE 48
    BYTE 45
    RLE2 4C
    LOADS7
    BYTE 4F
    BYTE 20
    BYTE 57
    BYTE 4F
    BYTE 52
    BYTE 4C
    BYTE 44
    RLE2 21
    CALLN 00
    EXIT
L223:
    DUP
    CRNG 000C886A 000E1869
    JZ L235
    RLE512 00
    CALLN 00 ;; а вот и вызов коллбэка прошивки --- значит, это сектор данных
    EXIT     ;; файла
L235:
    EXIT
...

L0:
    LOADS5
    BYTE 02
    BYTE 08
    BYTE 20
    BYTE 00
    BYTE 02
    RET

...



Не идеально, но отсутствуют сопли, общий код частично выделен в процедуры, дерево ветвлений имеется. Пойдет.

Осталось на чем-нибудь это запустить, для этого нам нужно реализовать, наконец, саму виртуальную машину.

Ее можно и просто написать на Си, так как значительно меняются только опкоды, но как показывает опыт, лучше уж ее генерировать всю, чем потом следить за консистентностью опкодов и кода на Си. Проверить это никак нельзя, и ситуация когда компилятор производит одно, а vm интерпретировать хочет совсем другое, вполне вероятна. Так что лучше уж генерировать всё. Набросаем опять мини-eDSL для генерации Си, что бы не утруждаться закрытием скобок, отступами и точками с запятой.

Опять Writer, никакого разнообразия…

stubs :: String
stubs = 
  envFile $ do
    comment "top of the file"
    put "#include <stdint.h>"
    put "#include \"emufatstubs.h\""
    defines
...

  stmt (pt codeType ++ op `assign` "code")

    endl

    push a "n"

    put "for(;;)"

    braces $ indented $ do

      put "switch(*op)"
      braces $ do
        forM_ codes $ \op -> do
          put (printf "case %s:" (show op))
          indented $ decode op
          endl
        put "default:"
        indented $ exit
  
  exitLabel
  indented $ stmt "return 0"

...

decode (CRNG)    = do
  skip "1"
  stmt (tmp0 `assign` pop a)
  stmt (tmp1 `assign` decode32) >> skip "4"
  stmt (tmp2 `assign` decode32) >> skip "4"
  push a ( _and (tmp0 `gq` tmp1) (tmp0 `lq` tmp2) )
  next

decode (CALL)    = do
  skip "1"
  stmt (tmp0 `assign` decode32) >> skip "4"
  stmt (push' r pc')
  jump tmp0

...



Посмотрим, что у нас получилось:

#define DEFSTACK(n, t, l) ...
#define RESET(a) ...
#define PTOP(a) ...
#define TOP(a) ...
#define POP(a) ...
#define PUSH(a,v) ...
#define NEXT(x) ...
#define JUMP(x, b, o) ...
#define SKIP(x, n) ...
#define PC(x, b) ...
#define DECODE32(op) ...
#define DECODE8(op) ...

    ...

    DEFSTACK(a, uint32_t, 16);
    DEFSTACK(r, uint32_t, 8);

    uint32_t tmp0;
    uint32_t tmp1;
    uint32_t tmp2;
    uint32_t tmp3;

    ...

    uint8_t *op = code;

    PUSH(a, n);
    for(;;)
    {
        switch(*op)
        {
    ...
        case CRNG:
            SKIP(op, (1));
            tmp0 = POP(a);
            tmp1 = DECODE32(op);
            SKIP(op, (4));
            tmp2 = DECODE32(op);
            SKIP(op, (4));
            PUSH(a, ((tmp0 >= tmp1) && (tmp0 <= tmp2)));
            NEXT(op);
    ...
        case CALL:
            SKIP(op, (1));
            tmp0 = DECODE32(op);
            SKIP(op, (4));
            PUSH(r, PC(op, code));
            JUMP(op, code, tmp0);
    ...	

        case EXIT:
            goto _exit;

        default:
            goto _exit;
        }
    }

_exit:
    return 0;

    ...



Ну, что и должно быть. Важный нюанс: что бы switch скомпилировался в таблицу переходов, нужно, что бы значения его меток шли последовательно и не имели дырок. И, вероятно, укладывались в байт. В случае нарушения этих эвристик компиляторы Си могут сгенерировать дерево сравнений, что нас в данном случае совершенно не устраивает. Последовательность опкодов мы обеспечили определением инстанса Enum для нашего типа Opcode (см. выше).

Какая жалость, что такой низкоуровневый, казалось бы, Си не имеет в стандарте способов перехода по переменному адресу, хоть GCC и поддерживает такое расширение. Только не для всех интересных платформ есть GCC, так что ограничимся switch-based интерпретацией.

Наша виртуальная машина готова. Напишем для нее тесты. Это легко — пусть тестовая VM принимает на вход поток байткодов, генерирует содержимое буфера в результате их интерпретации и отдает в выходной поток. Каждый тест кейс, таким образом, будет считаться пройденным, если содержимое буфера в итоге соответствует ожиданиям.

Напишем тесты…

testJne = makeTest $ do
  [l1, l2] <- replicateM 2 newLabel
  
  cnst 1
  cnst 2
  jne l1
  exit

  label l1
  cnst 0xCAFEBABE -- 1
  outle

  cnst 1
  cnst 1
  jne l2
  cnst 0xCAFEBABE -- 2
  outle
  exit

  label l2
  cnst 0xFFFFFFFF
  outle




… и тест-кейсы:

tests = testSuite $ do
  ...
  test "testJne"   testJne (assert $ do
                              a <- getWord32le
                              b <- getWord32le
                              return $ a == 0xCAFEBABE && b == 0xCAFEBABE)



и оболочку для их запуска:

runTest :: String -> Test -> IO Bool 
runTest path (T{tname=nm, tcode=code, tcheck = tc})= do
  let bin = toBinary code
  (inp,out,err,pid) <- runInteractiveProcess path [] Nothing Nothing
  BS.hPut inp bin
  hClose inp
  res <- BS.hGetContents out
  let r = tc res
  hPutStrLn stderr (printf "test %-24s : %s" nm (if r then "PASSED" else "FAILED !"))
  return r

...
case args of
    ...
    ... -> mapM_ (runTest path) tests
    ...
...



Запустим, устраним все проблемы и падения в core (на удивление немногочисленные)

...
test testJgq                  : PASSED
test testJne                  : PASSED
test testCallRet1             : PASSED
...



и запустим все вместе:

...
helloFile = const $ BS8.pack "HELLO WORLD!!"

fatSample2 = filesystem $ do
  file "file0" (16384) helloFile 
  dir "A" $ do
    file "file1" (megs 100) helloFile 
    dir "C" $ do
      file "file3" (megs 100) helloFile 
      file "file4" (megs 100) helloFile 
      file "file5" (megs 100) helloFile 
      dir "E" $ emptyDir 
      
  dir "B" $ do
    file "file2" (megs 50) emptyFile
...

$ ./FatGen bin | cbits/genfat 1000000 > fat.img
  521106 / 1000000      ( 13027 kb/s) 

$ fsck.vfat ./fat.img         

dosfsck 3.0.9, 31 Jan 2010, FAT32, LFN
Free cluster summary uninitialized (should be 15863)
./fat.img: 10 files, 115209/131072 clusters

$ sudo mount -o loop ./fat.img /mnt/test2/

$ find /mnt/test2/
/mnt/test2/
/mnt/test2/FILE0
/mnt/test2/A
/mnt/test2/A/FILE1
/mnt/test2/A/C
/mnt/test2/A/C/FILE3
/mnt/test2/A/C/FILE4
/mnt/test2/A/C/FILE5
/mnt/test2/A/C/E
/mnt/test2/B
/mnt/test2/B/FILE2




Все работает как и ожидалось: образ файловой системы генерируется, проходит проверку и монтируется. Содержимое соответствует описанию на нашем eDSL.

Размер скомпилированного файла правил при этом составляет немногим более 2Kb и поддается дальнейшей оптимизации, 2Kb это вполне приемлемый размер для динамической загрузки даже по GSM/EDGE, не говоря о 3G.

Оптимизации поддается и производительность форта, не говоря о том, что в самом крайнем случае его можно скомпилировать в Си и затем в нативный код процессора.

Вот такой небольшой рассказ о пользе хаскелла в народном хозяйстве.
Tags:haskellforthembedded
Hubs: Haskell
Total votes 57: ↑57 and ↓0+57
Views3.4K

Popular right now