脂肪を見つける（FATの探求）

特定のハードウェアとソフトウェアの複合体を開発する場合、クライアントデバイスを作成する必要がありました。他のデバイスでは、通常のUSBフラッシュドライブ、またはより正式にはUSB大容量記憶装置のように見えます。 デバイスは、デバイス上のファイル自体が存在せず、ネットワーク上にあるという事実にもかかわらず、外の世界に対して十分に大きいサイズ（2GB以上）のファイルでFATファイルシステムをシミュレートする必要があるという点で異常です。 とにかく、これらはファイルではなく、ある種のオーディオストリームです。

タスクは、一見シンプルです。ブロックを読み取る要求（SCSIコマンド）ごとに、このブロックの内容を提供します。 ブロックは、「ファイル」のいずれかに属するか、FATオーバーヘッド情報を含むことができます。

もちろん、最初に考えたのは、FATイメージをたとえばbzip2で圧縮し、必要に応じてデバイスで解凍することでした。 すぐに3つの問題が発生します。

• 100メガバイトのファイルといくつかのディレクトリのかかとから圧縮されたファイルシステムのイメージは、デバイス上のRAMの量を超える約125 KBを消費します。
  
• 明らかに、Bzip2はセクターについて何も知らず、スレッドレベルで動作するため、セクターごとにパックする必要があります。したがって、イメージサイズは非常に禁止されます：ご存知のように、小さなブロックでのパックは収益がありません-圧縮によるゲインに比べてオーバーヘッドが大きくなります
  
• イメージの準備（空のファイルのマウント、ファイルシステムの作成、パッキング）には多くの時間がかかり、推定数千人のユーザーがいるサーバーでの実装にはほとんど受け入れられません。 また、作成中のイメージ自体には、かなり顕著なディスク領域が必要です。
  

さて、bzip2をマイクロコントローラーに移植する必要があるという事実は言うまでもありません。

そのため、何か他のものを考え出す必要がありました。

この問題は次のように提起することができます。ファイルシステムの記述を何らかの形式で入力として受け取り、セクター番号の各要求に対してその内容を返すコードを記述する必要があります。 コンテンツはサービス情報またはファイルデータのいずれかであり、指定されたURLの対応するオーディオストリームから取得されます。

この質問の定式化により、規則のシステムに導かれます。


=>


クラスターはFATファイルシステム自体の概念であるため、「クラスター」ではなくセクターについて説明していることに注意してください。 デバイスはブロックレベルで動作し、セクターでもあります。 「プレイリスト」にそれぞれ2Gbの10個の「ファイル」が含まれているとします（2Gbは無限への実用的なアプローチです）。 各ルールのサイズが1バイトである場合、もちろんこれは不可能である場合、取得します。

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


すべてのルールのバイト。 やや合理的。 しかし、もちろん、ルールは各セクターに固有のものではありません。 セクターの範囲にルールを設定します。 これにより、一連のルールに導かれます。

(A) =>
(A,B) =>


また、セクター自体をパックしようとします。 データを圧縮するタスクに直面していないため、データ自体はデバイスで使用できず、Webから取得されるため、ファイルシステム自体のサービスデータを多少なりともコンパクトに表示する必要があります。 一見すると、このデータには多くの繰り返しシーケンスが含まれているため、次のようにコーディングします。繰り返しシーケンスは次のように表されます。

( RLE, , )


非反復シーケンスを次のように表します

( Sequence, )


さらに、すでにエンコードしたシーケンスまたはその一部は、再挿入せずに参照するのがよいでしょう。 おそらく別のシーケンスがあります

( , )


おそらく実装プロセス中に、ファイルシステム構造のよりコンパクトな表現のために他のシーケンスが表示される場合があります。

これはすべて、仮想マシンのコマンドシステムに非常に似ており、呼び出し、つまりスタックがあるためです。 最も単純な既知の仮想マシンは、砦の種類の1つです。 実際、これは逆です。
呼び出しからの戻りアドレスのスタックが追加されたステロイドに関するポーランド語のレコード。これにより、関数フレームの整理に煩わされる必要がなくなります。すべてが非常に単純です-呼び出しから戻るときに削除します
スタックRの最上位ワードで、それが指すアドレスに移動します。

さらに、2スタックマシンのトークンスレッドコード（およびこれになります）の密度は非常に良好であり、この場合、非常に適しています。

このようなコードの解釈は高速で、ネイティブコードよりも平均で5倍遅いだけでなく、非常に簡単です。

したがって、ある種のコーディングシステム、ルールのシステム、およびこれらのルールが実行される仮想マシンがあります。

特定の記述からこれらのルールを生成し、バイトコードを取得し、その解釈のためにマシンを実装することが残っています。 そして、その後にのみ何が起こったのかがわかります。

仮想マシンの実装により、状況は単純です。それぞれマイクロコントローラーで動作しますが、ここまでCオプションはありません。 確かに、そこに書き込むものが何もない可能性があります-どういうわけかそれを生成することが判明します
方法。

残っているのは、説明からのルールシステムの生成、説明自体、コード生成、およびこのコードのコマンドの説明だけです。 さらに、ルールを順番にチェックするのではなく、何らかの形で合理的にチェックすることをお勧めします。フォームでチェックを整理します
セクターあたりの比較数が比較数の2進対数のオーダーになるように、比較ツリー。

最初の分析は終了しました。プロトタイプを作成して、得られるものを確認する必要があります。

さまざまな次元とエンディアンのバイナリデータを生成し、場合によっては読み込む必要があり（FATサービスデータはローエンディアン形式で書き込まれます）、ネストされたデータ構造を操作する必要があります。

これは何に実装されますか？ C、C ++、またはPythonですか？ それともルビー？ 冗談。
もちろん、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) 
 

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は、「。」ディレクトリにすぎません。 そして、「..」は、ここで驚くべきことに、一流の物理的に存在するディレクトリエントリです。 幸いなことに
は単なるリンクであり、クラスターの割り当てを必要としません。

それ以外の場合、すべてが明らかです。型コンストラクタの最初の属性は一意の識別子です。 データの「ファイル」が要求されたファームウェアを理解するために、私たちにとって明らかに役立つことがあります。

2番目の属性はファイル名です。 ファイルの場合、サイズとデータも追加します。 もちろん、これはファイル自体のデータではなく、このデータを取得するデバイスのファームウェアを示すものです。 そこで、たとえば、syssh構造体またはストリームURLを記述できます。 したがって、ByteString。

ここで、ファイルシステムの要件を考慮して、何らかの方法でエントリを作成する必要があります。ルートを除く各ディレクトリには、エントリ「。」が含まれている必要があります。 および '..'は、対応するディレクトリを参照する必要があります。
同じレコード名、名前に禁止文字などを含めることはできません。 この構造を手動で作成することは難しく、さらに、APIのユーザーはこれに対処する必要があり、間違いなく何かを混乱させてすべてが壊れてしまうことがわかりますが、これは深刻な問題です。 したがって、モジュールからのエントリタイプのコンテンツのインポートを禁止し、ユーザーにより便利でエラー保護されたソリューションを提供することをお勧めします。 次のようなもの：

 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 
 

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


言語を知らない人でも、ここで説明されていることを理解できます。
実装は簡単です。何かを生成するために、すでに既製のMonad Writerがあります。

さらに、一意の識別子を配布する必要があります。そのため、何らかのカウンターを配置するStateも役立ちます。 StateとWriterをクロスさせたいので、モナド変換子は私たちを傷つけません。 このようなもの：

 newtype EntryIdT ma = 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 () 
 

newtype EntryIdT ma = 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 ()


各関数は、名前、サイズ、ネストされたレコードを構築するための別のモナド値などのパラメーターを取ります。 このような計算はそれぞれ個別のライターで実行され、識別子が一意になるように状態がドラッグされます。

そこで、ディレクトリ構造を設定しました。今度はなんとかしてルールを外す必要があります。

これを行うには、何らかの方法でデータファイルとディレクトリを「ディスク」に配置します。
これらは、最初にディレクトリ、次にファイルの順に配置されると想定しています。

 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 
 

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


コード全体は非常に明白です。すべてのレコードを取得し、「。」を削除します。 独自のクラスターを持たず、見知らぬ人を指すだけで、ディレクトリを最初に、次にファイルを作成します（違いはありませんが、より論理的です。
ボリュームの目次が読みやすくなります）、セクターを選択します（セクターを操作する方が便利です。「クラスター」は人工的な概念です）。それだけです。

uniplateモジュールのユニバース関数に注目する価値があります。 ネストされた構造のすべての要素をリストにリストし（必要に応じてリスト内包表記を使用）、再帰的な走査関数のルーチン作成を回避できます。

彼女のために、エントリ派生型（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 ab es Dir _ _ es -> writeEntries ab es File _ _ _ bs -> tell [RANGE ab (encodeBlock (BS.take (fatSectLen) bs))] where ... 
 

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 ab es Dir _ _ es -> writeEntries ab es File _ _ _ bs -> tell [RANGE ab (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 ... 
 

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 ...


ここでは、Data.Binary.Putの非常に便利なPutMモナドを使用します。これにより、任意のビット深度とエンディアンのデータを遅延バイト文字列に出力できます。

したがって、FATボリュームのディレクトリ構造、セクター別の割り当て、および対応するルールがあります。 私たちは何を残しましたか？

ここで、少し後退してFATデバイスを覚えておく必要があります。 Webや文献で広く利用されている不必要な詳細に触れない場合、FAT32は次のように設計されています。

     | BootSect | FAT32情報| FAT1 | FAT2 |データ|

これまでのところ、DATAのルールのみがあります。 FAT1およびFAT2はクラスター割り当てテーブルです。 各ファイルまたはディレクトリ（ファイルでもあります）は、データ領域内のクラスターのチェーンを占有し、データ領域内の各クラスターは、FAT1およびFAT2（同一）の32ビット値で表されます。

各FATセルにはファイルの次のクラスターの番号が含まれ、最後のクラスターには特別な値がマークされます。 ファイルの最初のクラスターの番号は、ディレクトリエントリに示されています。 チェーンの各セルに数値N + 1が書き込まれるように、データは順番に配置されます（Nは前の値です）。

ここで最初の問題が発生します。計算された10 x 20Gbの場合、このテーブルは655360の32ビット値を占有し、使用可能なRAMを再び超えます。 ただし、これらのルールは圧縮できません。
重複する値がないため、プリミティブRLEパッキングアルゴリズム。 ただし、このシーケンスを1回生成できたので、おそらく既にデバイス上で再度生成できます。

よく見ると、割り当てテーブルの1つのセクターの値は前のセクターの最大値に依存しており、一般に、シーケンスは次の式で決定されます。

     Na = BASE +（Nsect-M）*ステップ
     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) 
 

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


今後は、コールバックに別のルールを追加します。これはファイルデータセクターの生成後に呼び出す必要があります。これにより、デバイスファームウェアがバッファーを取得し、実データで埋めます。

ルールのセットの形式でテーブルをすぐに生成することは可能ですが、何らかの理由でバイナリ形式で必要でした。さらに、バイナリ文字列をエンコードするためのデバッグ関数が既にあり、直接生成では簡単です
間違えます。

このテーブルは非常に大きく、大きなデータ領域と小さなクラスターサイズの場合、貧弱なHaskellは苦労します。

ある時点で、大きなレイジーなWord32リストから、アプリケーションは本当に悪いと感じたので、レイジーなバイトラインにすばやく書き換え、runPut / runGetを使用して32ビット値をそこに入れて取得する必要がありました。

驚くべきことに、これは約10倍の加速をもたらし、すべてが許容可能な速度で動作し始めましたが、もちろん、ルールをすぐに生成し、データを作成しないように書き換える必要があります。
しかし、コンセプトについては、そうなります。

テーブルの生成関数とそのルールを省略します。それらは非常に大きいですが、同時に非常に明白です。

 type ClusterTable = BS.ByteString genFAT :: ClustSize32 -> Int -> [AllocEntry] -> ClusterTable encodeFAT :: Int -> ClusterTable -> [Rule] 
 

type ClusterTable = BS.ByteString genFAT :: ClustSize32 -> Int -> [AllocEntry] -> ClusterTable encodeFAT :: Int -> ClusterTable -> [Rule]


テーブルエンコーディング関数は、最初に各セクターを1つのルールREQ a（NSER _ _ _）に関連付け、次にセクターをペアで考慮し、2つのセクターが値の共通シーケンスを形成する場合、セクターのルールはセクターの範囲のルールに置き換えられ、結果は非常にコンパクトになりますここに持ってくることができるように：

 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 12128]
範囲33,231 [NSER 129 33 128]
 REQ 232 [SER 25601 25610、RLE 3 255、SEQ [0F]、SER 25612 25728]
範囲233431 [NSER 25729 233128]
 REQ 432 [SER 51201 51210、RLE 3 255、SEQ [0F]、SER 51212 51328]
範囲433 631 [NSER 51329 433 128]
 REQ 632 [SER 76801 76810、RLE 3 255、SEQ [0F]、SER 76812 76928]
範囲633 831 [NSER 76929 633 128]
 REQ 832 [SER 102401 102410、RLE 3 255、SEQ [0F]、SER 102412 102528]
範囲833 931 [NSER 102529 833 128]
 REQ 932 [SER 115201 115210、RLE 3 255、SEQ [0F]、RLE 468 0]
範囲933 1056 [RLE 512 0]

2メガバイトのデータよりも明らかに優れており、有望に見えます。
テーブルの2番目のコピーは定数に対して正確であるため、将来、オフセットから定数を減算して最初のテーブルを呼び出すことにより、このシーケンスを置き換えることができます。 しかし、それは後で。

したがって、FAT1、FAT2、およびDATAがあります。 BootSectおよびFAT32情報のみを取得します。 これは静的なバイナリデータなので、再びData.Binary.Putを使用してから、ルールにパックします。

これらの2つのモジュール（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 -- ... --    
 

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 nm = let (a, b, c) = M.splitLookup nm 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) 
 

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 nm = let (a, b, c) = M.splitLookup nm 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)


それは最良の選択肢ではないかもしれませんが、ルールは100未満であることが判明し、まだ心配することはできません。

仮想マシン、コマンドセット、およびコンパイラ次第です。

 -  ,     -     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]) 
 

- , - 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])


残念ながら、ここでは単純なHaskell型システムが見逃され始めています。コマンドとそのクラスにコンパイル時の不変式を設定したいので、たとえば、間違ったオペコードでチームを作成することはできません。 ただし、これを行うことはできませんが、各オペコードに個別の型、コマンドの実在データ型を導入したくはありませんが、メタプログラミングを使用してオペコードを生成する必要はありません。

良い時が来るまで先送りして、私たちが持っているものでうまく行こう。 とにかく、仮想マシンの実装のために、テストを書く必要があるので、そこに現れるエラーがポップアップします。

そのため、仮想マシンコマンドシステムがあります。ルールから構築された比較ツリーをコンパイルする必要があります。

 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 ab code ) = do s <- newLabel code' <- runGen' (scanmC code) >>= withLabel ex <- newLabel label s dup crng ab jz ex block code' label ex -- skip 
 

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 ab code ) = do s <- newLabel code' <- runGen' (scanmC code) >>= withLabel ex <- newLabel label s dup crng ab jz ex block code' label ex -- skip


Writerモナドの上に構築された、eDSLを使用したものを生成するお気に入りの方法を次に示します。

比較ツリーからフラットコードを生成すると、たとえば、ブロックからの長い出口チェーンが発生するなど、多くの「スノー」が発生します。

 L1: ... JMP L2 L2: JMP L3 L3: JMP L4 L4: EXIT 
 

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 ... 
 

... 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 ...


理想的ではありませんが、鼻水はありません。一般的なコードはプロシージャに部分的に割り当てられており、ブランチツリーがあります。 します

それを何かで実行することは残っています。そのためには、最終的に仮想マシン自体を実装する必要があります。

オペコードのみが大幅に変更されるため、単純にCで作成できますが、経験から、オペコードとCコードの整合性を後で監視するよりも、すべてを生成する方が良いことが示されています。これを検証する方法はありません。また、コンパイラーがそれを生成し、vmが完全に異なるものを解釈したい状況は、かなりありそうです。したがって、すべてを生成する方が良いです。繰り返しますが、Cを生成するためのミニeDSLの概要は、括弧、インデント、セミコロンを閉じる必要がありません。

再び作家、さまざまな...

 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 ... 
 

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; ... 
 

#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; ...


まあ、それはする必要があります。重要なニュアンス：スイッチが遷移テーブルにコンパイルされるためには、ラベルの値が順番に移動し、穴がないことが必要です。そして、おそらくバイトに収まります。これらのヒューリスティックに違反した場合、Cコンパイラは比較ツリーを生成できますが、この場合はまったく適合しません。オペコードタイプのEnumインスタンスの定義をオペコードシーケンスに提供しました（上記を参照）。

GCCがそのような拡張機能をサポートしているとしても、Cには変数アドレスにナビゲートする標準的な方法がないように思えます。すべての興味深いプラットフォームにのみGCCがあるわけではないため、スイッチベースの解釈に限定しています。

仮想マシンの準備ができました。彼女のテストを書きましょう。これは簡単です。テスト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 
 

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) 
 

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 ... ... 
 

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 ... ...


実行し、すべての問題を修正し、コアでクラッシュします（驚くほど少数）

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

... 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 
 

... 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を少し上回り、さらなる最適化に役立ちます。3Gは言うまでもなく、GSM / EDGEを介した動的ダウンロードでも2Kbは非常に許容可能なサイズです。

Fortパフォーマンスは最適化にも役立ちます。最も極端な場合、Cでコンパイルしてからネイティブプロセッサコードにコンパイルできるという事実は言うまでもありません。

ここに、国民経済におけるHaskellの利点についての短い話があります。