halfs-0.2: Halfs/TheBlockMap.hs
{-# LANGUAGE PatternSignatures #-}
-----------------------------------------------------------------------------
-- |
-- Module : TheBlockMap
--
-- Maintainer : Isaac Jones <ijones@galois.com>
-- Stability : alpha
-- Portability : GHC
--
-- Explanation: Tracks free blocks in the filesystem. Does not track
-- non-free blocks. Exists as a FIFO queue to avoid block reuse.
-- This is also true when syncing to the disk; it syncs in FIFO order,
-- so when its read from the disk, the least-recently-used block is on
-- the end, and won't be used for a while. -- The number of bytes in
-- the block map file does _not_ change, but not all of those bytes
-- will always be used. That is, the block map file is a fixed size,
-- does not shrink after newFS.
module Halfs.TheBlockMap (TheBlockMap -- abstract
,mkBlockMap
,allocateBlock
,freeBlock
,freeBlocks
,bmTotalSize
,bmDirty
,newFS
,findAddress
,unitTests)
where
import Halfs.Inode (Inode(metaData), InodeMetadata(level)
,newInode, firstFreeInodeDiskAddr)
import Halfs.TestFramework (Test(..), UnitTests, (~:), (~=?),
hunitToUnitTest)
import Data.Integral ( INInt, intToINInt )
import Halfs.Utils (DiskAddress, BlockNumber,
FileType (File),
blockPointersPerIndirectBlock,
blockPointersPerInode)
-- Base
import Data.Queue (listToQueue, addToQueue, deQueue, Queue, queueToList, queueLength)
import qualified Data.Set as Set
import Control.Exception(assert)
-- TODO: each block of blockmap should have a dirty bit (inside the
-- inode)
data TheBlockMap = TheBlockMap {freeBlocks :: Queue DiskAddress
,_freeBlocksSet :: Set.Set DiskAddress
,bmDirty :: Bool
,bmTotalSize :: INInt -- total number of blocks
}
-- |todo: check to see if new epoch, optimize allocation by using a
-- window and passing in a hint of where it "should" go. "Nothing"
-- means that the disk is full.
allocateBlock :: TheBlockMap -> Maybe (DiskAddress, TheBlockMap)
allocateBlock (TheBlockMap inBlockMap inBlockSet _ s)
= case deQueue inBlockMap of
Nothing -> Nothing -- Nothing free!
Just (addr, newBlockMap)
-> Just ((assert (addr /= 0) addr), TheBlockMap newBlockMap (Set.delete addr inBlockSet) True s)
freeBlock :: TheBlockMap -> DiskAddress -> TheBlockMap
freeBlock (TheBlockMap inBlockMap inBlockSet _ len) addr
= assert (not (Set.member addr inBlockSet)) $
assert (addr > 0 && addr < len) $
TheBlockMap (addToQueue inBlockMap (assert (addr /= 0) addr)) (Set.insert addr inBlockSet) True len
{-
where addToQueue' q addr = listToQueue (take offset xs ++ [addr] ++ drop offset xs)
where xs = queueToList q
offset = 200
-}
-- |smart constructor for TheBlockMap
newFS :: INInt -- ^Length of the device in blocks
-> TheBlockMap
newFS len -- 0 and 1 are inode file and inodemap file
= mkBlockMap (listToQueue [firstFreeInodeDiskAddr .. (len - 1)]) True len
mkBlockMap :: Queue DiskAddress -> Bool -> INInt -> TheBlockMap
mkBlockMap free busy size
= assert (queueLength free == Set.size freeSet) $
TheBlockMap free freeSet busy size
where freeSet = Set.fromList (queueToList free)
instance Show TheBlockMap where
show (TheBlockMap free _ de tot) = "TheBlockMap [" ++ showBM (queueToList free) ++ "] " ++ show de ++ " " ++ show tot
where
commas [] = ""
commas xs = foldl1 (\ a b -> a ++ "," ++ b) xs
showBM xs = commas
[ if a == b
then
show a
else show a ++ ".." ++ show b
| (a,b) <- combine [ (x,x) | x <- xs ] ]
combine ((a,b):(c,d):r) | b+1 == c = combine ((a,d):r)
combine (v:r) = v: combine r
combine [] = []
{-
instance Show TheBlockMap where
show (TheBlockMap fb _ _)
= fmap (\x -> if isFree x then "-" else "X")
-}
-- ------------------------------------------------------------
-- * Computing the location on disk of this block
-- ------------------------------------------------------------
findAddress :: Inode -- ^Inode that contains the blocks
-> BlockNumber -- ^Address we're looking for, 0 indexed
-> [INInt] -- ^dereference locations at each level, 0 indexed
findAddress inode findMe
= addrList (level $ metaData inode)
1
(intToINInt blockPointersPerIndirectBlock)
(intToINInt blockPointersPerInode)
findMe
-- |Compute the list of locations in a tree with the given branching
-- factor. Counts up to totalLevels, zero indexed. That is, if I'm
-- looking for the 3rd element in a zero indexed binary tree with two
-- levels, it'll be [1,1]. addrList 3 3 2 10 == [1,0,1]
addrList :: INInt -- Levels
-> INInt -- current level
-> INInt -- branching factor
-> INInt -- base buckets
-> BlockNumber -- address to find
-> [INInt]
addrList totalLevels currLevel branchingFactor baseBuckets findMe
| findMe >= numBuckets totalLevels branchingFactor baseBuckets
= error "block too big, should have resized"
| currLevel > totalLevels = []
| otherwise = let bucketLoc = absBucket totalLevels currLevel
branchingFactor baseBuckets findMe
prevLevel = currLevel - 1
prevBucket = absBucket totalLevels prevLevel
branchingFactor baseBuckets findMe
answer = if currLevel == 1
then bucketLoc
else bucketLoc - (branchingFactor * prevBucket)
in answer : (addrList totalLevels (currLevel + 1)
branchingFactor baseBuckets findMe)
-- |How many buckets at this level for this branching factor?
numBuckets :: INInt -- current level
-> INInt -- branching factor
-> INInt -- base buckets
-> INInt
numBuckets 0 _ _ = error "zero"
numBuckets 1 _ b = b
numBuckets currLevel branchingFactor baseBuckets
= (numBuckets (currLevel - 1) branchingFactor baseBuckets) * branchingFactor
-- Get the bucket of this element as if this entire level were one node
absBucket :: INInt -- total levels
-> INInt -- current level
-> INInt -- branching factor
-> INInt -- base buckets
-> BlockNumber -- location to find.
-> INInt
absBucket _ _ _ _ 0 = 0
absBucket totalLevels currLevel branchingFactor baseBuckets findMe =
let maxElems = numBuckets totalLevels branchingFactor baseBuckets
buckets = numBuckets currLevel branchingFactor baseBuckets
itemsPerBucket = maxElems `div` (assert (buckets /= 0) buckets)
-- Below "1" adjustments are because addresses start at zero.
in (ceiling $ toRational (findMe+1) / toRational itemsPerBucket) - 1
-- ------------------------------------------------------------
-- * Testing
-- ------------------------------------------------------------
unitTests :: UnitTests
unitTests = hunitToUnitTest hunitTests
hunitTests :: [Test]
hunitTests = let inode' = newInode 0 File
inode = inode'{metaData=(metaData inode'){level=2}}
inode2 = inode'{metaData=(metaData inode'){level=3}}
(maxAddr::INInt) = (16 * (1024 ^ (2::Int))) - 1 -- for 3 levels
in
["simple Address List 1" ~: "failed" ~: [1,0,1] ~=? addrList 3 1 3 2 10
,"simple Address List 2" ~: "failed" ~: [1,0,2] ~=? addrList 3 1 3 2 11
,"simple Address List 2" ~: "failed" ~: [1,1,1] ~=? addrList 3 1 3 2 13
,"disk addr list 1" ~: "failed" ~: [0,0] ~=? findAddress inode 0
,"disk addr list 2" ~: "failed" ~: [0,1] ~=? findAddress inode 1
,"disk addr list 3" ~: "failed" ~: [0,1023] ~=? findAddress inode 1023
,"disk addr list 4" ~: "failed" ~: [1,0] ~=? findAddress inode 1024
,"disk addr list 3 lev. 1" ~: "failed" ~: [0,1,0] ~=? findAddress inode2 1024
,"disk addr list 3 lev. 2" ~: "failed"
~: [0,0,1023] ~=? findAddress inode2 1023
,"disk addr list 3 lev. 3" ~: "failed" ~: [0,5,0] ~=? findAddress inode2 5120
,"max addr" ~: "failed" ~: maxAddr ~=? (numBuckets 3 1024 16) - 1
,"max addr loc" ~: "failed" ~: [15, 1023, 1023]
~=? findAddress inode2 maxAddr
-- FIX: Should test address maxAddr + 1 which should fail
]