Permalink
Browse files

added profile target

  • Loading branch information...
1 parent c2b2b08 commit 30024c2b0aeb7b35df6263dc3dcfe94eff79194b Joel Stanley committed Apr 20, 2010
Showing with 38 additions and 14 deletions.
  1. +4 −2 Halfs/Inode.hs
  2. +3 −3 halfs.cabal
  3. +8 −8 test/src/Driver.hs
  4. +23 −1 test/src/Tests/CoreAPI.hs
View
@@ -767,7 +767,7 @@ allocFill dev bm avail blksToAlloc contsToAlloc existing = do
-- currently "flattens" BlockGroup; see comment in writeStream
mbg <- lift $ BM.allocBlocks bm blksToAlloc
case mbg of
- Nothing -> throwError HE_AllocFailed
+ Nothing -> dbug ("allocBlocks alloc fail") $ throwError HE_AllocFailed
Just bg -> return $ BM.blkRangeBG bg
--
allocConts =
@@ -780,7 +780,9 @@ allocFill dev bm avail blksToAlloc contsToAlloc existing = do
case mcr of
Nothing -> return Nothing
Just cr -> Just `fmap` lift (buildEmptyCont dev cr)
- maybe (throwError HE_AllocFailed) (return) mconts
+ maybe (dbug ("allocConts alloc fail") $ throwError HE_AllocFailed)
+ (return)
+ mconts
-- | Truncates the stream at the given a stream index and length offset, and
-- unallocates all resources in the corresponding free region
View
@@ -37,7 +37,7 @@ library
System.Device.File,
System.Device.Memory,
System.Device.ST
- GHC-Options: -O2 -Wall -fno-ignore-asserts
+ GHC-Options: -O2 -Wall -fno-ignore-asserts -threaded
extensions: FlexibleContexts, FlexibleInstances,
ScopedTypeVariables,
GeneralizedNewtypeDeriving,
@@ -50,11 +50,11 @@ executable halfs-tests
build-depends: QuickCheck == 2.1.0.2,
directory >= 1.0.0.3,
- random >= 1.0.0.1
+ random >= 1.0.0.1
hs-source-dirs: test/src .
main-is: Driver.hs
- ghc-options: -O2 -Wall -fno-ignore-asserts -threaded
+ ghc-options: -O2 -Wall -fno-ignore-asserts -threaded
executable halfs
build-depends: HFuse >= 0.2.2
View
@@ -12,14 +12,14 @@ import qualified Tests.Serdes as SD
qcProps :: [(Args, Property)]
qcProps =
- BD.qcProps True -- run in "quick" mode for Block Devices
- ++
- BM.qcProps True -- run in "quick" mode for Block Map
- ++
- SD.qcProps True -- run in "quick" mode for Serdes
- ++
- IN.qcProps True -- run in "quick" mode for Inode
- ++
+-- BD.qcProps True -- run in "quick" mode for Block Devices
+-- ++
+-- BM.qcProps True -- run in "quick" mode for Block Map
+-- ++
+-- SD.qcProps True -- run in "quick" mode for Serdes
+-- ++
+-- IN.qcProps True -- run in "quick" mode for Inode
+-- ++
CA.qcProps True -- run in "quick" mode for CoreAPI
main :: IO ()
View
@@ -36,7 +36,7 @@ import Tests.Instances (printableBytes, filename)
import Tests.Types
import Tests.Utils hiding (HalfsM)
--- import Debug.Trace
+import Debug.Trace
--------------------------------------------------------------------------------
@@ -52,6 +52,7 @@ type HalfsProp =
qcProps :: Bool -> [(Args, Property)]
qcProps quick =
[
+{-
exec 10 "Init and mount" propM_initAndMountOK
,
exec 10 "fsck" propM_fsckOK
@@ -83,6 +84,8 @@ qcProps quick =
exec 10 "Simple rmlink" propM_simpleRmlinkOK
,
exec 10 "Simple rename" propM_simpleRenameOK
+-}
+ propM_profileMe
]
where
exec = mkMemDevExec quick "CoreAPI"
@@ -773,6 +776,25 @@ propM_simpleRenameOK _g dev = do
[d1, d2, d3, f1, f2, f3] =
map (rootPath </>) ["d1", "d2", "d3", "f1", "f2", "f3"]
+propM_profileMe :: (Args, Property)
+propM_profileMe = (,) stdArgs{maxSuccess = 1} $ monadicIO $ go $ \dev -> do
+ fs <- mkNewFS dev >> mountOK dev
+ trace ("created fs") $ do
+ execH "propM_profileMe" fs "create and write" $ do
+ createFile fn defaultFilePerms
+ trace ("created file") $ do
+ withFile fn (fofWriteOnly True) $ \fh -> do
+ forM addrs $ \addr -> do
+-- trace ("Writing " ++ show (BS.length chunk) ++ " bytes to "
+-- ++ fn ++ " at offset " ++ show addr) $ do
+ write fh addr chunk
+ where
+ fn = rootPath </> "theFile"
+ go f = run (memDev g) >>= (`whenDev` run . bdShutdown) f
+ g = BDGeom 65536 4096 -- 256 MiB FS
+ chunk = BS.replicate 4096 0x42 -- 4k chunk
+ addrs = [ i * 4096 | i <- [0..32767]] -- lower 128 MiB addrs
+
--------------------------------------------------------------------------------
-- Misc

0 comments on commit 30024c2

Please sign in to comment.