diff --git a/LICENSE-2.0.txt b/LICENSE-2.0.txt new file mode 100644 --- /dev/null +++ b/LICENSE-2.0.txt @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/exe-src/Main.hs b/exe-src/Main.hs new file mode 100644 --- /dev/null +++ b/exe-src/Main.hs @@ -0,0 +1,56 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, TypeFamilies, TemplateHaskell #-} + +module Main ( + main +) where + +import Data.Int +import Data.Word +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString as B +import qualified Test.QuickCheck as QC +import Test.QuickCheck.Arbitrary +import System.Environment +import Language.Haskell.TH +import Database.Perdure.TestState +import Database.Perdure.TestPersistent +import Database.Perdure.TestStoreFile +import Database.Perdure.TestMap +import Cgm.TH.Label + +import Cgm.Control.Profile + +main :: IO () +main = getArgs >>= argsMain + +argsMain :: [String] -> IO () +argsMain (x:xs) = maybe invalidArgs ($ xs) $ lookup x mains +argsMain [] = invalidArgs + +invalidArgs :: IO () +invalidArgs = putStrLn $ "Invalid arguments, first argument should be one of " ++ (show $ map fst mains) + +mains :: [(String, [String] -> IO ())] +mains = [ + $(label 'testStoreFile), + $(label 'testPersistent), + $(label 'testPersistentMap), + $(label 'testSeqPersistent), + $(label 'testStates), + $(label 'testStatesDag), + $(label 'testMap) + -- $(label 'testStatesDestroysRaw1), + ] diff --git a/perdure.cabal b/perdure.cabal new file mode 100644 --- /dev/null +++ b/perdure.cabal @@ -0,0 +1,243 @@ +Name: perdure +version: 0.1.0 +cabal-version: >= 1.8 +build-type: Simple +license: OtherLicense +license-file: "LICENSE-2.0.txt" +copyright: (c) 2010-2012 Cognimeta Inc. +maintainer: Patrick Premont +homepage: https://github.com/Cognimeta/perdure +package-url: +bug-reports: +synopsis: Robust persistence for acyclic immutable data +description: + Perdure™, a Cognimeta product, aims to provide a simple and robust persistence mechanism for acyclic + immutable data with an easily comprehensible cost-model. It persists to raw block devices. + . + For some classes of applications, it can replace the use of traditional DMBS and keep the data modelled in + a manner that is natural for purely functional languages. It is not quite orthogonal persistence for + Haskell, which would automatically turn any non-persistent program into a persistent one, but it aims to + minimize the scope of changes required to make an application persistent. + . + The persistence process is strict, it does not persist thunks or closures, but only the fully evaluated + data, which must be acyclic. It also requires some changes to the data types and algorithms. References + must be inserted at some strategic places within data structures. These cut the structure into separately + loadable parts. These parts should hold at least a few hundred bytes to reduce the frequency of disk + reads. The application has control over the representation so it can optimize it in terms of the + anticipated access patterns. A SizeRef reference type is provided which separates automatically if its size + threshold is reached, and inlines the data otherwise. As a convenience, a Map type is also provided which + uses SizeRef on internal tree nodes. It can grow beyond the memory size and still remain efficient for + lookups and traversals. Other persistent data structures with similar properties can be built on top of + Perdure™. + . + For the user application, dereferencing is a pure computation. This is similar to lazy loading, but the + reference data types do not hold ordinary references to their referent, only their location. This allows + the referent to be unloaded transparently. Also since the reference holds the location and size of the data + on the storage medium, dereferencing is very simple and efficient. No index need to be accessed, we only + need to check a cache in case the data is already loaded. + . + Persisters for data types are created using safe combinators. Serialization is done at the bit level, + allowing for very compact representations. + . + Undetected corruption is virtually impossible even in the presence of drive failures. Each separately + loadable section has a 128-bit digest, and that digest is stored in the reference(s). This approach + alleviates the need for low-level storage replication such as RAID, and takes care of replication at the + persistence layer level. This seems appropriate given the increasing need for geographically distributed + replication. + . + Persistence occurs in discrete transactions. These run in the IO monad. Transactions may be requested by + multiple threads but they may block until they get their turn. Within a transaction, multiple threads or sparks + can be used to examine the current state and compute the next state to be persisted. + . + Reference counting is used to automatically reclaim unused storage. + . + Since persisted data is immutable, it is trivial for applications to keep some or all historical states by + using a list-like type as their root persisted type. Those past states can be used for analysis or possibly + to recover data lost because of an application-level error. The library includes a History data type which + automatically preserves a greater number of recent states and fewer older states. + . + We support 32bit, 64bit, little-endian and big-endian architectures. We allow platforms to write data and + generate digests in their native format for maximum speed, but they should be able to read the data written + by other platforms with the necessary conversions. Each reference stores the endianness and word size of the + referent representation so databases can be moved between platforms without any conversion, and they could + be read concurrently by different platforms. + . + A general mechanism 'Database.Perdure.Rev' is provided to upgrade the persisted types. + Its goal is similar to that of the safecopy package. Here however, the Rev module simply exports a type + that is similar to Either but whose persister leaves room in the representation to accommodate future + versions. We use it to create growing lists of alternatives such as User1.User :> User0.User :> NoRev. + This type should always be your root persisted type. You should also use it on the nested parts of + your data whose type is more subject to change: this will avoid having to propagate all type changes up + to the root. + . + This library is young and there remains limitations that will need to be addressed in future releases: + . + * Memory references are not tracked. At this point it is assumed that the current persisted state is the + only root for persistent GC purposes. So no reference must be kept to previous persisted states. This is + not enforced by the API so care is needed. Otherwise dereferencing a dangling reference might fail + (but will not return bad data thanks to the digest). + . + * Care is needed by the application developers to ensure they do not change type persisters. The persisters + themselves are not persisted so the library cannot verify that it is using the same persister as with + previous executions. There are two problems with persisting persisters: they are not acyclic, and they + refer to user specified bijections. We encourage you to treat types and persisters as immutable code. Put + each persisted type in a distinct file, such as User0.hs. When a revision is needed create User1.hs. + . + * The current allocation strategy is trivial. We must add a new node type in the free space representation + that will allow us to search efficiently for a block of sufficient size. We currently scan all free + intervals from the start. This relatively simple fix should be done shortly, but until it is done the library will + not be appropriate for databases beyond ~100MB. + . + * Reclamation of free space simply occurs after some fixed number of state writes. + . + * Replication is local only at the moment. We write to all replicas, and read from the first correct one. We + need to support remote storage which can become temporarily unavailable, and user controlled policies + regarding those occurrences. Note that quorum voting is not needed for replica control of most (non-root) + allocations because digests are contained in the references and we can detect when we are reading outdated + data. + . + * Only raw disks configured for write-through caching will guarantee atomicity. Any other setup introduces + more layers, such as file systems, which could lie about when data has actually been written out to + disk. Perhaps our view is too pessimistic, and with proper action by this library other storage types could + be supported. Currently file based storage is only supported for testing purposes and should not be used + for live databases. + . + * A directory of bad sectors with alternative locations will need to be added. It will only need to be looked-up + and updated for reads with incorrect digests. + . + * Sharing is not realized unless it happens in separate steps. During the writing of some state, a + reference creates an allocation. In subsequent states we can refer to that same reference in multiple + locations and sharing will occur. If a reference is shared in memory before being first written out, it + will be written out multiple times without sharing of the referent. In the future we may rely on + System.Mem.StableName to improve on that. + . + * Currently, references are local. We would like to be able to refer to the allocations of another thread or + process. This will be a more involved addition so it will require distributed garbage collection such as + weighted reference counting. + . + * Documentation and examples are not sufficient and should be our first focus. For a minimal example, + look at Database.Perdure.TestState.testStatesF in exe-src. + . + Given those limitations, Perdure™ is not applicable for very large scale projects at the moment. But it can + be ideal for smaller projects where there is no point in burdening the developer with a distinct data + model. It can also be used as a temporary solution before integrating to external databases. + . + Cognimeta's Iota Charts web application , is based on Perdure™ and has been has + been live for close to a year. Its database is relatively small at ~80MB currently, but we have been very + pleased with the results. + . + Perdure™ has been developed by Cognimeta Inc. over the past two years. We are releasing this as open + source under the permissive Apache license 2.0. The persistence mechanism is relatively simple and concise + and its open source nature can provide the inquisitive user with added confidence about the security of its + data. Also Cognimeta has been using Haskell exclusively, and has benefited from many + excellent open source libraries. We are happy to contribute back, and are hoping for constructive and + critical feedback from this very bright community. +category: Databases +author: Patrick Premont for Cognimeta Inc. +tested-with: +data-files: +data-dir: "" +extra-source-files: +extra-tmp-files: + +library + buildable: True + hs-source-dirs: src + if arch(i386) + cpp-options: -DWORDSIZE=32 + if arch(x86_64) + cpp-options: -DWORDSIZE=64 + extensions: CPP + exposed-modules: + Database.Perdure + Database.Perdure.AllocCopy + Database.Perdure.Allocator + Database.Perdure.ArrayRef + Database.Perdure.CDeserializer + Database.Perdure.CRef + Database.Perdure.CSerializer + Database.Perdure.Count + Database.Perdure.DRef + Database.Perdure.Data.Map + Database.Perdure.Data.MapMultiset + Database.Perdure.Decrementer + Database.Perdure.Deref + Database.Perdure.History + Database.Perdure.Incrementer + Database.Perdure.LocalStoreFile + Database.Perdure.Package + Database.Perdure.Persistent + Database.Perdure.RNF + Database.Perdure.Ref + Database.Perdure.ReplicatedFile + Database.Perdure.Rev + Database.Perdure.RootValidator + Database.Perdure.SingleStoreFile + Database.Perdure.SizeRef + Database.Perdure.Space + Database.Perdure.SpaceBook + Database.Perdure.SpaceTree + Database.Perdure.State + Database.Perdure.StoreFile + Database.Perdure.Validator + Database.Perdure.WValidator + Database.Perdure.WordArrayRef + Database.Perdure.WordNArrayRef + Database.Perdure.WriteBits + other-modules: + Database.Perdure.Digest + build-depends: + base >= 4.5.0.0 && < 5, + template-haskell >= 2.7.0.0, + cognimeta-utils == 0.1.0, + QuickCheck >=2.4.0.1, + strict >= 0.3.2, + mtl >= 2.1.2, + transformers >= 0.3.0.0, + filepath >= 1.3.0.0, + containers >= 0.4.2.1, + binary >= 0.5.1.0, + collections-api >= 1.0.0.0, + cryptohash == 0.7.2, + -- ***** cryptohash >= 0.7.3 has updated Skein to version 1.3, so the upgrade would require full rebuilds of our databases + bytestring >= 0.9.2.1, + array >= 0.4.0.0, + stm >= 2.3, + ghc-prim >= 0.2.0.0, + primitive >= 0.4.1, + tagged >= 0.4.2.1, + data-lens >= 2.9.0, + data-lens-fd >= 2.0.2, + data-lens-template >= 2.1.5, + comonad-transformers >= 2.1.1.1, + time >= 1.4.0.1, + unix >= 2.5.1.0, + data-binary-ieee754 >= 0.4.2.1, + lrucache >= 1.1.1, + deepseq >= 1.3.0.0, + deepseq-th >= 0.1.0.3 + + ghc-options: -rtsopts -fcontext-stack=80 -O2 -funfolding-use-threshold=24 -pgmP cpphs -optP --cpp + extensions: + +source-repository head + type: git + location: git://github.com/Cognimeta/perdure.git + +executable perdure + hs-source-dirs: exe-src + main-is: Main.hs + other-modules: + build-depends: + base >= 4.5.0.0, + template-haskell >= 2.7.0.0, + cognimeta-utils == 0.1.0, + mtl >= 2.1.2, + deepseq, + QuickCheck >=2.4.0.1, + perdure >= 0.1.0, + transformers >= 0.3.0.0, + bytestring >= 0.9.2.1, + containers >= 0.4.2.1, + MonadRandom == 0.1.3 + ghc-options: -rtsopts -fcontext-stack=80 -fno-warn-duplicate-exports -O2 -funfolding-use-threshold=24 -threaded diff --git a/src/Database/Perdure.hs b/src/Database/Perdure.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure.hs @@ -0,0 +1,74 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Database.Perdure( + module Database.Perdure.Persistent, + defaultRootLocation, + newCachedFile, + PVar, + openPVar, + createPVar, + updatePVar, + updateInspectPVar + ) where + +import Prelude() +import Cgm.Prelude +import Database.Perdure.State +import Database.Perdure.Persistent +import Cgm.Control.Monad.State as M +import Cgm.Data.Typeable +import Control.Monad hiding (sequence) +import Control.Monad.Trans +import Control.Monad.Reader hiding (sequence) +import Control.Applicative +import Cgm.Control.Concurrent.MVar +import Cgm.Data.Super +import Data.Word + +-- | Wraps a ReplicatedFile with cache of a given size (number of dereferenced DRefs) +newCachedFile :: Integer -> ReplicatedFile -> IO CachedFile +newCachedFile sz f = CachedFile f <$> newMVar (emptyCache sz) + +-- | At the moment this is the only way to create a rootLocation. +-- The root of the database will be located in one of two reserved locations at the start of the specified files. +defaultRootLocation :: CachedFile -> RootLocation +defaultRootLocation f = RootLocation f [RootAddress 0, RootAddress $ apply super rootAllocSize] + +-- | Represents a persisted database. Contains a (ram-only) lock to sequence multithreaded operations, +-- so only one 'PVar' must be created per 'RootLocation'. +newtype PVar s = PVar (MVar (PState s)) + +-- | Creates a PVar with the specified initial state. Writes at the specified location, using the given maximum usable space (in bytes). +createPVar :: (Typeable s, Persistent s) => s -> Word64 -> RootLocation -> IO (PVar s) +createPVar s sz l = initState l (addSpan (sortedPair roots sz') emptySpace) s >>= fmap PVar . newMVar where + roots = 2 * apply super (getLen rootAllocSize) + sz' = + if sz <= roots + then error $ "createPVar needs a max size of at least " ++ show roots ++ " bytes" + else getLen (coarsenLen (unsafeLen (sz - roots) :: Len Word8 Word64) :: Len Word64 Word64) + +-- | Attempts to open a PVar by reading at the given 'RootLocation'. Do not open the same location multiple times, share +-- the PVar instead. +openPVar :: (Typeable s, Persistent s) => RootLocation -> IO (Maybe (PVar s)) +openPVar l = readState l >>= sequence . fmap (fmap PVar . newMVar) + +-- | Persist a state change +updatePVar :: (Typeable s, Persistent s) => PVar s -> M.StateT s IO a -> IO a +updatePVar (PVar v) t = stateTModifyMVar v $ toStandardState $ updateState t + +-- | This function allows read access to the bookkeeping structures of the database. The 'PState' type is subject to change. +updateInspectPVar :: (Typeable s, Persistent s) => PVar s -> M.StateT s (ReaderT (PState s) IO) a -> IO a +updateInspectPVar (PVar v) t = stateTModifyMVar v $ toStandardState $ updateStateRead t diff --git a/src/Database/Perdure/AllocCopy.hs b/src/Database/Perdure/AllocCopy.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/AllocCopy.hs @@ -0,0 +1,49 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE TypeFamilies #-} + +module Database.Perdure.AllocCopy ( + AllocCopy(..), + allocCopyBits, + module Database.Perdure.WriteBits + ) where + +import Prelude () +import Cgm.Prelude +import Cgm.Data.Word +import Cgm.Data.Len +import Database.Perdure.WriteBits +import Cgm.System.Endian + +class Endian w => AllocCopy w where + allocCopyBitsSkip :: (BitSrc d, SrcDestState d ~ RealWorld) => Len w Word -> d -> d -> ST RealWorld (STPrimArray RealWorld Pinned w) + +allocCopyBits :: (BitSrc d, SrcDestState d ~ RealWorld, AllocCopy w) => d -> d -> IO (PrimArray Pinned w) +allocCopyBits start end = stToIO $ allocCopyBitsSkip 0 start end >>= unsafeFreezeSTPrimArray + +instance AllocCopy Word32 where + allocCopyBitsSkip skip start end = onWordConv + (apply wordConv1 <$> allocCopyBitsSkip (retract wordLenB skip) start end) + (error "allocCopyBitsSkip for Word32 not implemented") +instance AllocCopy Word64 where + allocCopyBitsSkip skip start end = onWordConv + (error "allocCopyBitsSkip for Word64 not implemented") + (apply wordConv1 <$> allocCopyBitsSkip (retract wordLenB skip) start end) + +instance AllocCopy Word where + -- Starts writing after the specified length 'skip', which can later be used to write a header. + allocCopyBitsSkip skip start end = do + wBuf <- mkArray $ coarsenLen (addedBits end start) + skip + copyBits end start (aligned $ CWordSeq wBuf skip) >>= padIncompleteWord + return wBuf diff --git a/src/Database/Perdure/Allocator.hs b/src/Database/Perdure/Allocator.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/Allocator.hs @@ -0,0 +1,44 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE TypeFamilies, FlexibleContexts #-} + +module Database.Perdure.Allocator ( + Allocator(..), + allocWrite, + module Database.Perdure.StoreFile, + module Database.Perdure.LocalStoreFile, + module Database.Perdure.SingleStoreFile, + module Database.Perdure.ReplicatedFile + ) where + +import Prelude () +import Cgm.Prelude +import Data.Word +import Database.Perdure.StoreFile +import Database.Perdure.LocalStoreFile +import Database.Perdure.SingleStoreFile +import Database.Perdure.ReplicatedFile +import Cgm.Data.Len +import Cgm.Data.Array +import Cgm.Data.Super +import Cgm.System.Endian + +class Allocator l where + alloc :: l -> Len Word64 Word64 -> IO (Len Word64 Word64) -- take required size, and returns the address + allocatorStoreFile :: l -> ReplicatedFile + +allocWrite :: (Allocator l, LgMultiple Word64 w, Endian w) => l -> Endianness -> [PrimArray Pinned w] -> IO (StoreRef ReplicatedFile w) +allocWrite l e as = do + addr <- alloc l $ apply super (coarsenLen $ sum $ arrayLen <$> as :: Len Word64 Word) + storeFileWrite (allocatorStoreFile l) addr e as diff --git a/src/Database/Perdure/ArrayRef.hs b/src/Database/Perdure/ArrayRef.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/ArrayRef.hs @@ -0,0 +1,28 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE TypeFamilies #-} + +module Database.Perdure.ArrayRef ( + ArrayRef(..), + module Database.Perdure.Allocator + ) where + +import Database.Perdure.Allocator + +class ArrayRef (r :: (* -> *) -> *) where + type ArrayRefElem r + writeArrayRef :: (Allocator l) => l -> PrimArray Pinned (ArrayRefElem r) -> IO (r (StoreRef ReplicatedFile)) + derefArrayRef :: (StoreFile f, Allocation fr) => f -> r (StoreRef f) -> IO (Maybe (ArrayRange (PrimArray fr (ArrayRefElem r)))) + arrayRefAddr :: r BasicRef -> Len Word64 Word64 + diff --git a/src/Database/Perdure/CDeserializer.hs b/src/Database/Perdure/CDeserializer.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/CDeserializer.hs @@ -0,0 +1,144 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs, TypeFamilies, RankNTypes, DeriveFunctor, FlexibleContexts, ScopedTypeVariables #-} + +module Database.Perdure.CDeserializer ( + cDeser, + deserializeFromArray, + deserializeFromFullArray, + unsafeSeqDeserializer, + Deserializer(..), + Deserializable(..), + DeserOut(..), + module Database.Perdure.Persistent, + module Database.Perdure.CRef + ) where + +import Prelude () +import Cgm.Prelude +import Data.Functor.Compose +import Control.Concurrent +import Database.Perdure.Persistent +import Database.Perdure.CRef +import Cgm.Data.Functor +import Cgm.Data.Array +import Cgm.Data.Word +import Cgm.Data.Len +import Data.Bits +import Foreign.Ptr +import Database.Perdure.ReplicatedFile +import System.IO.Unsafe + +-- TODO figure out why the Deserializer's Allocator df is free to differ from f. Why is it a type argument of Deserializer at all if it can be anything? + +-- TODO consider reimplementing as in CSerializer (no Serializer layer, and possibly with continuations) and check performance + +deserializeFromArray :: (Allocation f, Allocation df, Deserializable w) => Deserializer df a -> ArrayRange (PrimArray f w) -> DeserOut a +deserializeFromArray d = (\(ArrayRange arr start _) -> deserialize d (refineLen start) arr) . deserInput + +deserializeFromFullArray :: forall f df w a. (Allocation f, Allocation df, Deserializable w, LgMultiple w Bool, Prim w) => + Deserializer df a -> ArrayRange (PrimArray f w) -> a +deserializeFromFullArray d arr = case deserializeFromArray d arr of + DeserOut a end -> bool (error $ "Inconsistent deserialized size: " ++ show (end, refineLen $ arrayLen arr :: Len Bool Word)) a $ + (coarsenLen end :: Len w Word) == arrayLen arr + +-- | The passed persister must have no references +unsafeSeqDeserializer :: Persister a -> Deserializer Free a +unsafeSeqDeserializer p = cDeser p (DeserializerContext (error "seqDeserializer has no file" :: ReplicatedFile) (error "seqDeserializer has no cache")) + +cDeser :: Persister a -> DeserializerContext -> Deserializer Free a +cDeser p = case p of + PartialWordPersister n -> const $ partialWordDeserializer n + PairPersister pa pb -> liftA2 (liftA2 (,)) (cDeser pa) (cDeser pb) + EitherPersister pa pb -> \dc -> cDeser persister dc >>= bool (Left <$> cDeser pa dc) (Right <$> cDeser pb dc) + ViewPersister i pb -> flip functorIacomap i . cDeser pb + SummationPersister pi d _ -> \dc -> cDeser pi dc >>= d (\pb ba -> fmap ba $ cDeser pb dc) + DRefPersister' -> \dc -> DRef persister dc <$> cDeser persister dc + CRefPersister' _ pra -> fmap Refed . cDeser pra + +instance InjectionACofunctor (Deserializer f) where + {-# INLINE iacomap #-} + iacomap = functorIacomap + +bitDeserializer :: Deserializer f Word +bitDeserializer = Deserializer $ \bit arr -> DeserOut (let (wIx, bIx) = coarseRem bit in (indexArray arr wIx `partialShiftRL` getLen bIx) .&. 1) (bit + 1) + +-- 0 <= n <= wordBits +partialWordDeserializer :: Len Bool Word -> Deserializer f Word +partialWordDeserializer n + | n == 0 = pure 0 + | n == 1 = bitDeserializer + | otherwise = + Deserializer $ \bit arr -> + DeserOut ( + let (wIx, bIx) = coarseRem bit + avail = wordBits - bIx + overflow = n - avail + n' = wordBits - n + in bool (indexArray arr wIx `partialShiftL` getLen (n' - bIx) `partialShiftRL` getLen n') + ((indexArray arr wIx `partialShiftRL` getLen bIx) + (indexArray arr (wIx + 1) `partialShiftL` getLen (wordBits - overflow) `partialShiftRL` getLen n')) $ + (signed $* getLen overflow) > 0) + (bit + n) + +--------------------------------------------------------------------------- + +class Deserializable a where deserInput :: (Allocation f, Allocation f') => ArrayRange (PrimArray f a) -> ArrayRange (PrimArray f' Word) + +instance Deserializable Word where deserInput = primArrayMatchAllocation +instance Deserializable Word32 where + deserInput a = onWordConv + (primArrayMatchAllocation $ retract wordConvArrayRange a) + (fullArrayRange $ mkArrayWith (coarsenLen $ arrayLen a) $ + (\i -> retract wordConv $ retract splitWord64LE + (indexArray a i, if i + 1 < arrayLen a then indexArray a (i + 1) else 0)) . refineLen) -- TODO: test +instance Deserializable Word64 where + deserInput a = onWordConv + (fullArrayRange $ mkArrayWith (refineLen $ arrayLen a) $ + (\(i, r) -> retract wordConv $ bool fst snd (r == 0) $ apply splitWord64LE $ indexArray a i) . coarseRem) -- TODO test + (primArrayMatchAllocation $ retract wordConvArrayRange a) + +--------------------------------------------------------------------------- + +-- Deserialization is strict so once DeserOut is forced, we no longer retain the input array. +-- The strict annotation in DeserOut is not quite sufficient to enfoce that, we also have to make sure we do not put in +-- there a structure with interal thunks pointing to the array. But inspecting this file should show no such Deserializer. +data DeserOut a = DeserOut { + deserValue :: !a, + deserPos :: {-# UNPACK #-} !(Len Bool Word)} deriving Functor + +-- If deserialization was lazy, the lifetime of the array would be unpredictable, so to avoid fragmentation of pinned arrays, we would prefer f = Free +-- But now deserialization is strict and the array is not retained so either Free or Pinned will do. +newtype Deserializer f a = Deserializer {deserialize :: Len Bool Word -> PrimArray f Word -> DeserOut a} +instance Functor (Deserializer f) where + {-# INLINE fmap #-} + fmap g = Deserializer . ((fmap g <$>) <$>) . deserialize +--instance Pointed (Deserializer c) where +-- point x = ... inlined into pure +instance Applicative (Deserializer f) where + {-# INLINE pure #-} + pure x = Deserializer $ \bit _ -> DeserOut x bit + {-# INLINE (<*>) #-} + g <*> x = Deserializer $ \bit ptr -> case deserialize g bit ptr of DeserOut g' bit' -> deserialize (g' <$> x) bit' ptr + -- we could define <*> = ap, but we would like to see if we could use <*> in the definition of join instead, see reflexion below +instance Monad (Deserializer f) where + {-# INLINE return #-} + return = pure + {-# INLINE (>>=) #-} + (>>=) = fmap join . flip fmap where + {-# INLINE join #-} + join :: Deserializer f (Deserializer f a) -> Deserializer f a + join d2 = Deserializer $ \bit ptr -> case deserialize d2 bit ptr of DeserOut d bit' -> deserialize d bit' ptr + +getBitDeserializer :: Deserializer f (Len Bool Word) +getBitDeserializer = Deserializer $ \bit _ -> DeserOut bit bit diff --git a/src/Database/Perdure/CRef.hs b/src/Database/Perdure/CRef.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/CRef.hs @@ -0,0 +1,37 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE FlexibleContexts, TupleSections, RankNTypes, ScopedTypeVariables, DeriveDataTypeable #-} + +module Database.Perdure.CRef ( + CRef(..), + onCRef + ) where + +import Control.Concurrent +import Control.Applicative +import System.IO.Unsafe +import Cgm.Control.Combinators +import Data.Dynamic +import Cgm.Data.Typeable +import Database.Perdure.Package + + +data CRef r a = Refed !(r a) | ToRef !a +instance (Typeable1 r, Typeable a) => Typeable (CRef r a) where + typeOf _ = mkTyCon3 perdurePackage "Database.Perdure.CRef" "CRef" `mkTyConApp` [typeOf1 (undefined :: r ()), typeOf (undefined :: a)] + + +{-# INLINE onCRef #-} +onCRef :: (r a -> b) -> (a -> b) -> CRef r a -> b +onCRef refed toRef st = case st of {Refed ss -> refed ss; ToRef a -> toRef a} diff --git a/src/Database/Perdure/CSerializer.hs b/src/Database/Perdure/CSerializer.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/CSerializer.hs @@ -0,0 +1,146 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving, RankNTypes, FlexibleInstances, TupleSections, ScopedTypeVariables, MagicHash, UnboxedTuples, BangPatterns, GADTs #-} + +module Database.Perdure.CSerializer ( + SerializerContext, + cSer, + serializeToArray, + Address, + module Database.Perdure.CDeserializer, + module Cgm.Control.Concurrent.NotificationCount + ) where + +import Prelude () +import Cgm.Prelude + +import Data.Functor.Compose +import Control.Concurrent +import Control.Monad.State +import GHC.Base hiding ((.), id) +import GHC.IO hiding (liftIO) +import GHC.Exts +import Cgm.Data.Functor.Sum +import Cgm.Data.Either +import Cgm.Data.Word +import Cgm.Data.Len +import Cgm.Control.Concurrent.NotificationCount +import Cgm.Control.Combinators +import Database.Perdure.CDeserializer +import Database.Perdure.Count +import Cgm.Data.Multiset as MS +import Data.IORef +import System.IO.Unsafe +import Database.Perdure.AllocCopy +import Foreign.Ptr +import Cgm.Data.Maybe +import Database.Perdure.ReplicatedFile +import Database.Perdure.Allocator +import Database.Perdure.ArrayRef +import Database.Perdure.WordArrayRef +import Database.Perdure.WordNArrayRef +import Database.Perdure.Persistent +import Cgm.Data.MapMultiset +import qualified Data.Cache.LRU as LRU +import Data.Dynamic +import Debug.Trace + + +-- Important : We must not read (deref) a ref that has just been written in the current writeState. +-- Since reodering of operations is allowed except across the storeFileFullBarrier (performed at the end of +-- write State), this ensures that we do not read data which has not yet been fully written. + +-- TODO make sure just written ref's can be inserted in the cache, since that data is likely to be accessed again + +type CountDest c = Maybe (MVar (c Address)) +addCount :: Multiset c => Address -> CountDest c -> IO () +addCount a = maybe (return ()) $ flip modifyMVar_ $ return . MS.insert a +type SerializerContext l c = (MVar Cache, l, CountDest c) -- TODO create type with strict fields + +-- TODO: consider testing whether returning a CSer (Maybe a) might be more performant, where Nothing represent the input a + +type Dest = ABitSeq RealWorld + +cSer :: (Multiset c, Allocator l) => Persister a -> SerializerContext l c -> (a -> Dest -> IO z) -> a -> Dest -> IO z +cSer !p !sc !k !a !d = case p of + PartialWordPersister n + | n == wordBits -> stToIO (addWord a d) >>= k a + | n == 0 -> k a d + | otherwise -> stToIO (addBits n a d) >>= k a + PairPersister pb pc -> case a of (b, c) -> cSer pb sc (\b' -> cSer pc sc (\c' -> k (b', c')) c) b d + EitherPersister pb pc -> either (\b -> stToIO (addBit 0 d) >>= cSer pb sc (k . Left) b) (\c -> stToIO (addBit 1 d) >>= cSer pc sc (k . Right) c) a + ViewPersister i pb -> cSer pb sc (k . fromJust . unapply i) (apply i a) d + SummationPersister pi _ s -> s (\i pb ba b -> cSer pi sc (const $ cSer pb sc (k . ba) b) i d) a -- i' is ignored, i type should not contain CRefs + DRefPersister' -> case a of (DRef _ _ w) -> + case sc of (_, _, c) -> addCount (arrayRefAddr w) c >> + cSer persister sc (const $ k a) w d -- TODO verify if call to persister is wastful + CRefPersister' rp prb -> onCRef (\rb -> cSer prb sc (const $ k a) rb d) (\b -> cSerRef rp sc (k . Refed) b d) a + +-- Creates the ref and serializes it +cSerRef :: (Multiset c, Allocator l, Persistent a, Typeable a) => RefPersister r -> SerializerContext l c -> (r a -> Dest -> IO z) -> a -> Dest -> IO z +cSerRef !rp !sc !k !a !d = case rp of + Ref0Persister -> cSer persister sc (k . Ref0) a d + RefView rbra pb -> cSerRef pb sc (k . rbra) a d + SizeRefPersister maxSize -> + let p = persister -- TODO verify if call to persister is wastful + start = d + asDRef (Ref0 a') dStart dEnd = do + --readIORef writeCount >>= putStr . (++ ",") . show + --readIORef writeCount >>= writeIORef writeCount . (+ 1) + --empty <- stToIO $ mkABitSeq + --putStrLn $ ("CSerializer: Popped size = " ++) $ showLen $ addedBits dEnd dStart + --putStrLn $ ("CSerializer: Stack size = " ++) $ showLen $ addedBits dStart empty + dRef <- mkDRef sc p (Just a') dStart dEnd + afterTrue <- stToIO $ addBit 1 start + cSer DRefPersister' (noCount sc) (k . Sum . Right) dRef afterTrue -- Doesn't pass CountDest. We don't count first references. + in + stToIO (addBit 0 start) >>= \afterFalse -> + cSerRef Ref0Persister sc + (\r0 end0 -> bool (k (Sum $ Left r0) end0) (asDRef r0 afterFalse end0) (addedBits end0 afterFalse > maxSize)) a afterFalse + CRefPersister _ -> error "CRef of CRef not yet implemented" -- TODO write + DRefPersister -> + let p = persister in -- TODO verify if call to persister is wastful + stToIO mkABitSeq >>= \start -> cSer p sc (\a' end -> mkDRef sc p (Just a') start end >>= \dRef -> cSer DRefPersister' (noCount sc) k dRef d) a start + -- Doesn't pass CountDest. We don't count first references.q + -- TODO optimization : if the WordSeq fits in a single chunk, we should be able to writeDRef directly from it, since it is already aligned + IRefPersister pb -> cSerRef pb sc (k . IRef) a d + +noCount :: SerializerContext l c -> SerializerContext l c +noCount (cache, l, c) = (cache, l, Nothing) + +mkDRef :: (Allocator l, BitSrc s, SrcDestState s ~ RealWorld, Typeable a) => + SerializerContext l c -> Persister a -> Maybe a -> s -> s -> IO (DRef a) +mkDRef sc@(cache, l, _) p ma = writeDRef p ma (DeserializerContext (allocatorStoreFile l) cache) l + +writeDRef :: (Allocator l, BitSrc s, SrcDestState s ~ RealWorld, Typeable a) => + Persister a -> Maybe a -> DeserializerContext -> l -> s -> s -> IO (DRef a) +writeDRef p ma dc@(DeserializerContext _ c) l start end = + DRef p dc <$> maybe id (\a -> (>>= \w -> w <$ addToCache a w)) ma (allocCopyBits start end >>= writeArrayRef l) where + addToCache a w = let addr = arrayRefAddr w in modifyMVar_ c $ + return . {-(trace ("writing/adding to cache at" ++ show addr) $ -}LRU.insert addr (toDyn a) + +-- | The passed Persister must hace no references +{-# NOINLINE serializeToArray #-} +serializeToArray :: AllocCopy w => Persister a -> a -> PrimArray Pinned w +serializeToArray p a = unsafePerformIO $ do + start <- stToIO mkABitSeq + noCache <- newMVar $ LRU.fromList Nothing [] + cSer p (noCache, NoAllocator, Nothing :: CountDest MapMultiset) (const $ allocCopyBits start) a start + +data NoAllocator = NoAllocator +instance Allocator NoAllocator where + alloc = error "NoAllocator" + allocatorStoreFile = error "NoAllocator" + + diff --git a/src/Database/Perdure/Count.hs b/src/Database/Perdure/Count.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/Count.hs @@ -0,0 +1,23 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +module Database.Perdure.Count ( + Address + ) where + +import Prelude() +import Cgm.Prelude +import Data.Word +import Cgm.Data.Len + +type Address = Len Word64 Word64 diff --git a/src/Database/Perdure/DRef.hs b/src/Database/Perdure/DRef.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/DRef.hs @@ -0,0 +1,25 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +module Database.Perdure.DRef ( + module Database.Perdure.Deref, + module Database.Perdure.StoreFile, + module Database.Perdure.WordArrayRef, + module Database.Perdure.WordNArrayRef + ) where + +import Database.Perdure.WordArrayRef +import Database.Perdure.WordNArrayRef +import Database.Perdure.Deref +import Database.Perdure.StoreFile + diff --git a/src/Database/Perdure/Data/Map.hs b/src/Database/Perdure/Data/Map.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/Data/Map.hs @@ -0,0 +1,308 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE DeriveFunctor, ScopedTypeVariables, TemplateHaskell, DeriveDataTypeable, KindSignatures, TypeFamilies, FlexibleContexts #-} + +module Database.Perdure.Data.Map( + Map, + updateM, + empty, + null, + lookup, + insert, + insertWith, + delete, + foldlWithKey, + foldrWithKey, + fromList, + toList, + assocs, + elems, + maxKey, + scan, + Database.Perdure.Data.Map.mapLens + ) where + +import Prelude hiding (null, lookup) +import Cgm.Control.Monad.State +import Database.Perdure.Persistent +import Database.Perdure.SizeRef +import Control.Arrow +import Control.Monad +import Data.Tuple +import Data.Functor +import Data.List(foldl') +import Data.Lens +import Cgm.Data.Nat +import Database.Perdure.Ref +import Cgm.Data.Maybe +import Control.Comonad.Trans.Store +import Data.Dynamic +import Database.Perdure.Package +import Cgm.Data.Typeable + +type R = CRef (SizeRef D9) + +moduleName :: String +moduleName = "Database.Perdure.Data.Map" + +-- | Unlike Data.Map, this Map does not support constant time size computation +data Map k a = Empty | NonEmpty !(Tree Leaf k a) deriving (Functor, Typeable) +instance (Show k, Show a) => Show (Map k a) where show = show . toList + +newtype Reference t k a = Reference (R (t k a)) deriving Functor +instance Typeable2 t => Typeable2 (Reference t) where + typeOf2 _ = mkTyCon3 perdurePackage moduleName "Reference" `mkTyConApp` [typeOf2 (undefined :: t () ())] +dereference :: Reference t k a -> t k a +dereference (Reference t) = deref t +reference :: t k a -> Reference t k a +reference = Reference . ref +newtype Leaf k a = Leaf a deriving (Functor, Typeable) -- TODO consider using data would allow's map's values to be thunks, as in Data.Map +data Empt k a = Empt + +data Tree t k a = LastLevel !(Upper t k a) | NextLevel !(Tree (Reference (Node t)) k a) deriving (Functor) + +-- The k's are the maximum elements of the preceeding 'c'. The maximum element of the last 'c' is not stored but is passed from the context. +data Node t k a = + Node2 {-# UNPACK #-} !(Upper t k a) !(t k a) | + Node3 {-# UNPACK #-} !(Upper t k a) {-# UNPACK #-} !(Upper t k a) !(t k a) deriving (Functor) +instance Typeable2 t => Typeable2 (Node t) where + typeOf2 _ = mkTyCon3 perdurePackage moduleName "Node" `mkTyConApp` [typeOf2 (undefined :: t () ())] + +data Upper t k a = Upper !k !(t k a) deriving (Functor) -- The k is the largest key in (t k a) +mapUpper :: (ta k a -> tb k b) -> Upper ta k a -> Upper tb k b +mapUpper f (Upper k tka) = Upper k $ f tka +within :: Ord k => Upper t k a -> k -> Bool +within (Upper k0 _) k = k <= k0 + +node2 :: Upper t k a -> Upper t k a -> Upper (Node t) k a +node2 uc0 (Upper u1 c1) = Upper u1 $ Node2 uc0 c1 +node3 :: Upper t k a -> Upper t k a -> Upper t k a -> Upper (Node t) k a +node3 uc0 uc1 (Upper u2 c2) = Upper u2 $ Node3 uc0 uc1 c2 +onNode :: (Upper t k a -> Upper t k a -> z) -> (Upper t k a -> Upper t k a -> Upper t k a -> z) -> Upper (Node t) k a -> z +onNode z2 z3 (Upper u n) = case n of + Node2 uc0 c1 -> z2 uc0 $ Upper u c1 + Node3 uc0 uc1 c2 -> z3 uc0 uc1 $ Upper u c2 + +data Out g c = + Merge g | + Single c | + Split c c + +appState :: Monad m => a -> (a -> b) -> StateT a m z -> StateT b m z +appState a ab = viewState (const a, ab) + +-- | General update/lookup at a single key. The State monad used supports +-- non-modification. Nothing denotes the absence of a value. +updateM :: forall k a b. Ord k => k -> State (Maybe a) b -> State (Map k a) b +updateM k s = get >>= \p -> case p of + Empty -> appState Nothing (maybe Empty $ NonEmpty . LastLevel . Upper k . Leaf) s + r@(NonEmpty t) -> (\(c, b) -> onModify (return b) ((b <$) . put) c) $ case t of + LastLevel ua -> first (fmap $ either NonEmpty (\Empt -> Empty)) $ trans' k s ua + NextLevel t -> first (fmap $ NonEmpty . either NextLevel id) $ updateT t where + updateT :: Tr t => Tree (Reference (Node t)) k a -> (Modify (Either (Tree (Reference (Node t)) k a) (Tree t k a)), b) + updateT (LastLevel ua) = first (fmap $ either Left (Right . LastLevel)) $ trans' k s ua + updateT (NextLevel t) = first (fmap $ Left . either NextLevel id) $ updateT t + +trans' :: (Tr t, Ord k) => k -> State (Maybe a) b -> Upper t k a -> (Modify (Either (Tree t k a) (G t k a)), b) +trans' k s a = first (fmap $ \o -> case o of + Merge a -> Right a + Single a -> Left $ LastLevel a + Split a0 a1 -> Left $ NextLevel $ LastLevel $ mapUpper reference $ node2 a0 a1 + ) $ trans k s a + +data Modify a = Leave | Change !a deriving Functor +onModify :: z -> (a -> z) -> Modify a -> z +onModify l _ Leave = l +onModify _ c (Change a) = c a + +class Tr (t :: * -> * -> *) where + type G t :: * -> * -> * + trans :: Ord k => k -> State (Maybe a) b -> Upper t k a -> (Modify (Out (G t k a) (Upper t k a)), b) + mergeLeft :: G t k a -> Upper t k a -> Either (Upper t k a) (Upper t k a, Upper t k a) + mergeRight :: Upper t k a -> G t k a -> Either (Upper t k a) (Upper t k a, Upper t k a) + foldlK :: (z -> k -> a -> z) -> z -> Upper t k a -> z + foldrK :: (k -> a -> z -> z) -> z -> Upper t k a -> z +instance Tr Leaf where + type G Leaf = Empt + trans k f a@(Upper k0 (Leaf v0)) = + if k == k0 + then first (maybe Leave $ Change . maybe (Merge Empt) (Single . Upper k0 . Leaf)) $ swap $ runState f (Just v0) + else first (maybe Leave $ maybe Leave $ \v -> Change $ (if k > k0 then id else flip) Split a (Upper k $ Leaf v)) $ swap $ runState f Nothing + mergeLeft Empt = Left + mergeRight ua Empt = Left ua + foldlK f z (Upper k (Leaf a)) = f z k a + foldrK f z (Upper k (Leaf a)) = f k a z +instance Tr t => Tr (Reference t) where + type G (Reference t) = G t + trans k f = first (fmap $ \o -> case o of + Merge a -> Merge a + Single a -> Single $ mapUpper reference a + Split a0 a1 -> Split (mapUpper reference a0) (mapUpper reference a1) + ) . trans k f . mapUpper dereference + mergeLeft g = (mapUpper reference +++ mapUpper reference *** mapUpper reference) . mergeLeft g . mapUpper dereference + mergeRight a g = (mapUpper reference +++ mapUpper reference *** mapUpper reference) $ flip mergeRight g $ mapUpper dereference a + foldlK f z = foldlK f z . mapUpper dereference + foldrK f z = foldrK f z . mapUpper dereference +instance Tr t => Tr (Node t) where + type G (Node t) = Upper t + trans k f = onNode + (\c0 c1 -> if within c0 k + then first (fmap $ \v -> case v of + Merge l -> either Merge (Single . uncurry node2) $ mergeLeft l c1 + Single c0' -> Single $ node2 c0' c1 + Split c00 c01 -> Single $ node3 c00 c01 c1 + ) $ trans k f c0 + else first (fmap $ \v -> case v of + Merge l -> either Merge (Single . uncurry node2) $ mergeRight c0 l + Single c1' -> Single $ node2 c0 c1' + Split c10 c11 -> Single $ node3 c0 c10 c11 + ) $ trans k f c1 + ) + (\c0 c1 c2 -> if within c0 k + then first (fmap $ \v -> case v of + Merge l -> Single $ either (`node2` c2) (\(c0', c1') -> node3 c0' c1' c2) $ mergeLeft l c1 + Single c0' -> Single $ node3 c0' c1 c2 + Split c00 c01 -> Split (node2 c00 c01) (node2 c1 c2) + ) $ trans k f c0 + else if within c1 k + then first (fmap $ \v -> case v of + Merge l -> Single $ either (node2 c0) (uncurry $ node3 c0) $ mergeLeft l c2 + Single c1' -> Single $ node3 c0 c1' c2 + Split c10 c11 -> Split (node2 c0 c10) (node2 c11 c2) + ) $ trans k f c1 + else first (fmap $ \v -> case v of + Merge l -> Single $ either (node2 c0) (uncurry $ node3 c0) $ mergeRight c1 l + Single c2' -> Single $ node3 c0 c1 c2' + Split c20 c21 -> Split (node2 c0 c1) (node2 c20 c21) + ) $ trans k f c2) + mergeLeft c = onNode + (\c0 c1 -> Left $ node3 c c0 c1) + (\c0 c1 c2 -> Right (node2 c c0, node2 c1 c2)) + mergeRight n c = ($ n) $ onNode + (\c0 c1 -> Left $ node3 c0 c1 c) + (\c0 c1 c2 -> Right (node2 c0 c1, node2 c2 c)) + foldlK f z = onNode (\n0 n1 -> foldlK f (foldlK f z n0) n1) (\n0 n1 n2-> foldlK f (foldlK f (foldlK f z n0) n1) n2) + foldrK f z = onNode (\n0 n1 -> foldrK f (foldrK f z n1) n0) (\n0 n1 n2-> foldrK f (foldrK f (foldrK f z n2) n1) n0) + +-- Here we implemented the function without creating Tr methods. Perhaps we should have done the same for foldlK, foldrK. +-- We could even define them in terms of scan now. +scan :: forall k a z. (k -> a -> z) -> (k -> z -> z -> z) -> Map k a -> Maybe z +scan kaz kzzz m = case m of + Empty -> Nothing + NonEmpty tr -> Just $ s1 tr $ \(Upper k (Leaf a)) -> kaz k a where + s1 :: Tree t k a -> (Upper t k a -> z) -> z + s1 tr utz = case tr of + LastLevel ut -> utz ut + NextLevel tr' -> s1 tr' $ \ut -> onNode + (\u0@(Upper k0 _) u1 -> kzzz k0 (utz u0) (utz u1)) + (\u0@(Upper k0 _) u1@(Upper k1 _) u2 -> kzzz k0 (utz u0) $ kzzz k1 (utz u1) (utz u2)) $ + mapUpper dereference ut + +empty :: Map k a +empty = Empty + +null :: Map k a -> Bool +null Empty = True +null _ = False + +lookup :: Ord k => k -> Map k a -> Maybe a +lookup k = fst . runState (updateM k get) + +insert :: Ord k => k -> a -> Map k a -> Map k a +insert k a m = fromMaybe m $ snd $ runState (updateM k $ put $ Just a) m + +insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a +insertWith f k a m = fromMaybe m $ snd $ runState (updateM k $ get >>= put . Just . maybe a (f a)) m + +delete :: Ord k => k -> Map k a -> Map k a +delete k m = fromMaybe m $ snd $ runState (updateM k $ get >>= maybe (return ()) (const $ put Nothing)) m + +foldlWithKey :: forall z k a. (z -> k -> a -> z) -> z -> Map k a -> z +foldlWithKey f z m = case m of + Empty -> z + NonEmpty t -> foldlf z t where + foldlf :: Tr t => z -> Tree t k a -> z + foldlf z (LastLevel t) = foldlK f z t + foldlf z (NextLevel t) = foldlf z t + +foldrWithKey :: forall z k a. (k -> a -> z -> z) -> z -> Map k a -> z +foldrWithKey f z m = case m of + Empty -> z + NonEmpty t -> foldrf z t where + foldrf :: Tr t => z -> Tree t k a -> z + foldrf z (LastLevel t) = foldrK f z t + foldrf z (NextLevel t) = foldrf z t + +fromList :: Ord k => [(k, a)] -> Map k a +fromList = foldl' (\z (k, a) -> insert k a z) empty + +toList :: Map k a -> [(k ,a)] +toList = assocs + +assocs :: Map k a -> [(k ,a)] +assocs = foldrWithKey (\k a l -> (k, a) : l) [] + +elems :: Map k a -> [a] +elems = fmap snd . assocs + +mapLens :: Ord k => k -> Lens (Map k a) (Maybe a) +mapLens k = Lens $ \m -> store (\mv -> case mv of + Nothing -> delete k m + Just v' -> insert k v' m + ) (lookup k m) + +instance (Eq k, Eq a) => Eq (Map k a) where + a == b = toList a == toList b + +maxKey :: Map k a -> Maybe k +maxKey Empty = Nothing +maxKey (NonEmpty t) = Just $ maxKeyT t where + maxKeyT :: Tree t k a -> k + maxKeyT (NextLevel t) = maxKeyT t + maxKeyT (LastLevel (Upper k _)) = k + + +{- + +data Map k a = Empty | NonEmpty (Tree k (Leaf k a)) + +-- A balanced non-empty tree. There is an arbitrary number or Node nestings, but after ever 4 a CDRef wraps the tree. +-- This means we get nodes in persistent storage that have between 2^4=16 and 3^4=81 children (perhaps on average 2*3*2*3 = 36). +-- A random tree of 10^6 elements would mean 3.86 such persistent storage levels (we simplify by just assming that the probability +-- of Node2 and Node3 is equal). +-- The user can use Tree k a, or Tree k (CDRef a) depending on the size of a. +-- Note that a 10 level tree would be represented as L4 (... L4 (... L2 (... ))), yet the L2 represents the top most, or outer, layers +data Tree k c = + L0 !(Upper k c) | + L1 !(Upper k (Node k c)) | + L2 !(Upper k (Node k (Node k c))) | + L3 !(Upper k (Node k (Node k (Node k c)))) | + L4 !(Tree k (CDRef (Node k (Node k (Node k (Node k c)))))) + + +-} + +instance (Persistent a, Persistent k, Typeable k, Typeable a) => Persistent (Map k a) where persister = structureMap persister +instance (Persistent k, Persistent (t k a), Typeable2 t, Typeable k, Typeable a) => Persistent (Tree t k a) where persister = structureMap persister +instance Persistent a => Persistent (Leaf k a) where persister = structureMap persister +instance (Persistent k, Persistent (t k a)) => Persistent (Node t k a) where persister = structureMap persister +instance (Persistent (t k a), Typeable (t k a)) => Persistent (Reference t k a) where persister = structureMap persister +instance (Persistent k, Persistent (t k a)) => Persistent (Upper t k a) where persister = structureMap persister + +deriveStructured ''Map +deriveStructured ''Tree +deriveStructured ''Leaf +deriveStructured ''Node +deriveStructured ''Reference +deriveStructured ''Upper diff --git a/src/Database/Perdure/Data/MapMultiset.hs b/src/Database/Perdure/Data/MapMultiset.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/Data/MapMultiset.hs @@ -0,0 +1,44 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE TypeFamilies, TemplateHaskell, DeriveDataTypeable #-} + +module Database.Perdure.Data.MapMultiset( + MapMultiset(mapMultisetMap), + module Cgm.Data.Multiset + ) where + +import Prelude() +import Cgm.Prelude +import Cgm.Data.Maybe +import Cgm.Data.Multiset +import Database.Perdure.Persistent +import Cgm.Control.Monad.State +import Database.Perdure.Data.Map(Map) +import qualified Database.Perdure.Data.Map as Map +import Data.Dynamic +import Cgm.Data.Typeable +import Database.Perdure.Package + +newtype MapMultiset a = MapMultiset {mapMultisetMap :: Map a Integer} deriving Typeable + +instance Multiset MapMultiset where + emptySet = MapMultiset Map.empty + insert e (MapMultiset a) = MapMultiset $ Map.insertWith (+) e 1 a -- TODO implement and use insertWith' (strict application of combining function) + delete e (MapMultiset a) = fmap MapMultiset $ snd $ flip runState a $ Map.updateM e $ + get >>= maybe (return ()) (\c -> if c == 1 then put Nothing else put $ Just $ c - 1) + +instance (Typeable a, Persistent a) => Persistent (MapMultiset a) where persister = structureMap persister + +deriveStructured ''MapMultiset + diff --git a/src/Database/Perdure/Decrementer.hs b/src/Database/Perdure/Decrementer.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/Decrementer.hs @@ -0,0 +1,62 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, Rank2Types, FlexibleContexts, ScopedTypeVariables, BangPatterns, GADTs #-} + +module Database.Perdure.Decrementer ( + decr + ) where + +import Prelude () +import Cgm.Prelude +import Cgm.Data.Structured +import Control.Monad.State +import Database.Perdure.Persistent +import Database.Perdure.Space +import Database.Perdure.Count +import Database.Perdure.CSerializer(Address) +import Cgm.Data.Monoid +import Cgm.Data.Multiset as MS +import Database.Perdure.SpaceBook +import Database.Perdure.Ref +import qualified Data.Cache.LRU as LRU +import Data.Dynamic +import Database.Perdure.ArrayRef +import Control.Concurrent.MVar +import System.IO.Unsafe +import Debug.Trace + +-- TODO consider addding a (lazy) bool into persisters that says if StoreRefs are present in descendents, and checking it to prune parts of the traversal + +-- | Has effects through unsafePerformIO on the caches stored in the DRefs (removes any cache entries for the deallocated allocations). +decr :: Persister a -> a -> SpaceBook -> SpaceBook +decr !p !a !s = case p of + PartialWordPersister n -> s + PairPersister pb pc -> case a of (b, c) -> decr pc c $ decr pb b s + EitherPersister pb pc -> either (decr pb) (decr pc) a s + ViewPersister i pb -> decr pb (apply i a) s + SummationPersister pi _ f -> f (\i pb _ b -> decr pb b $ decr pi i s) a + DRefPersister' -> case a of (DRef _ (DeserializerContext _ cache) warr) -> + let referenced = decr persister $ let da = deref a in da `seq` unsafeClearCache cache (arrayRefAddr warr) `seq` da + in either (\(WordNArrayRef _ r _) -> decrRef r referenced) (\(WordNArrayRef _ r _) -> decrRef r referenced) (unwrap warr) s + CRefPersister' _ pra -> onCRef (decr pra) (decr persister) a s + +{-# NOINLINE unsafeClearCache #-} +unsafeClearCache :: MVar Cache -> Len Word64 Word64 -> () +unsafeClearCache c addr = unsafePerformIO $ modifyMVar_ c $ return . fst . LRU.delete addr + +decrRef :: forall w. LgMultiple Word64 w => + BasicRef w -> (SpaceBook -> SpaceBook) -> SpaceBook -> SpaceBook +decrRef r onDealloc sb@(SpaceBook c s) = + maybe ((\(SpaceBook c s') -> SpaceBook c ({-trace ("freeing span " ++ show (refSpan r)) $-} addSpan (refSpan r) s')) $ onDealloc sb) + (flip SpaceBook s) $ MS.delete (refStart r) c diff --git a/src/Database/Perdure/Deref.hs b/src/Database/Perdure/Deref.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/Deref.hs @@ -0,0 +1,74 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE GADTs #-} + + +module Database.Perdure.Deref ( + Deref(..), + deref, + derefEq + ) where + +import System.IO.Unsafe +import Cgm.Data.Functor.Sum +import Cgm.Data.Maybe +import Cgm.Control.Combinators +import Database.Perdure.Persistent +import Database.Perdure.CDeserializer +import Database.Perdure.WordArrayRef +import Database.Perdure.WordNArrayRef +import Control.Applicative +import Data.Word +import Control.Concurrent.MVar +import Control.Exception.Base +import qualified Data.Cache.LRU as LRU +import Data.Dynamic +import Debug.Trace + +class Deref r where + derefIO :: r a -> IO a + +{-# NOINLINE deref #-} +deref :: Deref r => r a -> a +deref = unsafePerformIO . derefIO + +derefEq :: (Deref r, Eq a) => r a -> r a -> Bool +derefEq = (==) `dot2i` deref + +instance Deref DRef where + derefIO (DRef p dc@(DeserializerContext f cv) aRef) = + let addr = arrayRefAddr aRef + r = {-(trace ("(looking up cache at" ++ show addr ++ " wanting an " ++ show (typeOf r))-} modifyMVar cv (return . LRU.lookup addr) >>= + maybe + ((>>= \a -> evaluate a >> (a <$ modifyMVar_ cv (return . {-(trace ("adding to cache at" ++ show addr) $-} LRU.insert addr (toDyn a)))) $ + fmap (maybe (error "Read error") $ deserializeFromFullArray (cDeser p dc) . (id :: Id (ArrayRange (PrimArray Free Word)))) $ + derefArrayRef f aRef) + (return . fromMaybe (error $ "Wrong type in cache cell " ++ show addr) . fromDynamic) + in r + +instance Show a => Show (DRef a) where show = show . deref +instance Eq a => Eq (DRef a) where (==) = derefEq + +instance (Deref ra, Deref rb) => Deref (Sum ra rb) where derefIO = either derefIO derefIO . getSum + +instance Deref r => Deref (IRef r) where derefIO = derefIO . getIRef +instance (Deref r, Eq t) => Eq (IRef r t) where (==) = (==) `dot2i` deref +instance (Deref r, Show t) => Show (IRef r t) where show = show . deref . getIRef + +instance Deref Ref0 where derefIO (Ref0 a) = return a +instance Show a => Show (Ref0 a) where show = show . deref + +instance Deref r => Deref (CRef r) where derefIO = onCRef derefIO return +instance (Deref r, Show a) => Show (CRef r a) where show = show . deref +instance (Deref r, Eq a) => Eq (CRef r a) where (==) = derefEq diff --git a/src/Database/Perdure/Digest.hs b/src/Database/Perdure/Digest.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/Digest.hs @@ -0,0 +1,77 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE TypeFamilies, FlexibleInstances, GeneralizedNewtypeDeriving, FlexibleContexts, ScopedTypeVariables, TupleSections, TemplateHaskell #-} + +module Database.Perdure.Digest ( + Digest(..), + Skein512Digest, + MD5Digest, + module Cgm.Data.LongWord + ) where + +import Prelude () +import Cgm.Prelude +import Cgm.Data.Word +import Cgm.Data.LongWord +import Cgm.Data.Array +import Cgm.System.Endian +import System.IO.Unsafe +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as Lazy +import qualified Crypto.Hash.MD5 as MD5 +import qualified Crypto.Hash.Skein512 as Skein512 +import Cgm.Data.Structured + +-- Recovers a hash function on words from a hash function on a specific byte encoding the words +-- Word type (size, endianness) must match that of the underlying algorithm. +-- Output size must be an integer number of words +unsafeBSToWordHash :: (Allocation f, PinnedArray r, Prim (ArrayElem r)) => (B.ByteString -> B.ByteString) -> r -> PrimArray f (ArrayElem r) +unsafeBSToWordHash f input = unsafePrimArrayCast $ arrayFromByteString $ unsafePerformIO $ unsafeWithCastArrayByteString (evaluate . f) input + +-- Word size and specified endianness must match that of the underlying algorithm. +-- Output size must be an integer number of words +-- There will be no need for this method once we remove the byteswapping layer of the underlying algorithm, and we +-- have an underlying algorithm that assumes the input is in the platform endianness, instead of a fixed endianness. +unsafeFixedEndianToWordHash :: forall r. (PinnedArray r, ImmArray r, Endian (ArrayElem r), Prim (ArrayElem r)) => + Endianness -> (B.ByteString -> B.ByteString) -> r -> PrimArray Free (ArrayElem r) +unsafeFixedEndianToWordHash e f = + if platformWordEndianness == e + then unsafeBSToWordHash f + else mapImmArray unswapBytes . (id :: Id (PrimArray Free (ByteSwapped w))) . + unsafeBSToWordHash f . (id :: Id (PrimArray Pinned (ByteSwapped (ArrayElem r)))) . + mapImmArray swapBytes + +word128FromArray32LE :: PrimArray f Word32 -> Word128 +word128FromArray32LE a = word128BE (retract splitWord64LE (indexArray a 2, indexArray a 3)) (retract splitWord64LE (indexArray a 0, indexArray a 1)) + +word128FromArray64LE :: PrimArray f Word64 -> Word128 +word128FromArray64LE a = word128BE (indexArray a 1) (indexArray a 0) + +newtype Skein512Digest h = Skein512Digest h deriving (Eq, Show) +newtype MD5Digest = MD5Digest Word128 deriving (Eq, Show) + +class Eq d => Digest d where + type DigestWord d + digest :: (ImmArray r, PinnedArray r, ArrayElem r ~ DigestWord d) => r -> d + +instance Digest (Skein512Digest Word128) where + type DigestWord (Skein512Digest Word128) = Word64 + digest = {-# SCC "digestSkein" #-} (Skein512Digest . word128FromArray64LE . unsafeFixedEndianToWordHash LittleEndian (Skein512.hash 128)) + +instance Digest MD5Digest where + type DigestWord MD5Digest = Word32 + digest = {-# SCC "digestMD5" #-} (MD5Digest . word128FromArray32LE . unsafeFixedEndianToWordHash LittleEndian MD5.hash) + +deriveStructured ''MD5Digest +deriveStructured ''Skein512Digest diff --git a/src/Database/Perdure/History.hs b/src/Database/Perdure/History.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/History.hs @@ -0,0 +1,96 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveDataTypeable #-} + +module Database.Perdure.History ( + History(..), + initial, + current, + insert, + updateHistory, + updateHistoryM + ) where + +import Data.Bits +import Database.Perdure.Persistent +import Control.Arrow +import Control.Applicative +import qualified Control.Monad.State as Std +import Cgm.Control.Monad.State +import Control.Monad +import Database.Perdure.Ref +import Data.Dynamic + + +-- The History type is used as the state type so as to keep some snapshots of the past, in case data is lost due to a programming error +-- by the application developer. It is an homogenous collection so the argument type has to take care of versionning. +-- To avoid needless reserialization of the samples the argument type should be a Ref type. + +-- We keep the last maxQueueLength samples inserted, then maxQueueLength samples keeping one out of every two, +-- then maxQueueLength samples keeping one out of every four... +-- The history is never empty, so it is safe to get the current sample. + +-- For example: +-- *Database.Perdure.History> foldr insert empty [0..999] -- with maxQueueLenth == 8 +-- History 1000 [Queue [0,1,2,3,4,5,6,7],Queue [9,11,13,15,17,19,21,23],Queue [27,31,35,39,43,47,51,55],Queue [63,71,79,87,95,103,111 +-- ,119],Queue [127,143,159,175,191,207,223,239],Queue [255,287,319,351,383,415,447,479],Queue [543,607,671,735,799,863,927,991]] + +-- If the sampling interval is 1 second, and maxQueueLength is 8, +-- we get roughly 8 * log3(running-time/k) +-- For 3 years that's roughly 8*17 = 136 snapshots + +newtype Queue a = Queue (CDRef [a]) deriving (Show, Typeable) +singletonQueue :: a -> Queue a +singletonQueue a = Queue $ ref [a] + +queueInsert :: a -> Queue a -> (Queue a, Maybe a) +queueInsert a (Queue as) = first (Queue . ref) $ trim (a : deref as) where + trim l = + if length l <= maxQueueLength + then (l, Nothing) + else case reverse $ take (maxQueueLength + 1) l of -- the 'take' drop elements when we decide to reduce maxQueueLength + (o : r) -> (reverse r, Just o) + +maxQueueLength :: Int +maxQueueLength = 2 +-- maxQueueLength temporarily reduce from 8 to 2 to + +data History a = History Integer [Queue a] deriving (Show, Typeable) + +initial :: a -> History a +initial = History 1 . pure . singletonQueue + +updateHistory :: Monad m => Std.StateT a m b -> Std.StateT (History a) m b +updateHistory = Std.StateT . (\u h -> liftM (second $ flip insert h) (u $ current h) ) . Std.runStateT + +updateHistoryM :: Monad m => StateT a m b -> StateT (History a) m b +updateHistoryM = StateT . (\u h -> liftM (second $ fmap $ flip insert h) (u $ current h) ) . runStateT + +current :: History a -> a +current (History _ (Queue q : _)) = head $ deref q + +--Used when we want to flush the history +--insert :: a -> History a -> History a +--insert a _ = initial a + +insert :: a -> History a -> History a +insert a (History n qs) = History (n+1) $ ins a qs n where + ins o [] m = [singletonQueue o] + ins o (q:qr) m = let (q', mo') = queueInsert o q in q' : maybe qr (\o' -> if testBit m 0 then qr else ins o' qr (m `shiftR` 1)) mo' + -- we could use a probability instead of this alternating pattern, but this is easier to implement + +instance (Typeable a, Persistent a) => Persistent (History a) where persister = structureMap persister +instance (Typeable a, Persistent a) => Persistent (Queue a) where persister = structureMap persister +deriveStructured ''History +deriveStructured ''Queue diff --git a/src/Database/Perdure/Incrementer.hs b/src/Database/Perdure/Incrementer.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/Incrementer.hs @@ -0,0 +1,56 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, Rank2Types, FlexibleContexts, ScopedTypeVariables, BangPatterns, GADTs #-} + +module Database.Perdure.Incrementer ( + incr + ) where + +import Prelude () +import Cgm.Prelude +import Cgm.Data.Structured +import Control.Monad.State +import Database.Perdure.Persistent +import Database.Perdure.Space +import Database.Perdure.Count +import Database.Perdure.CSerializer(Address) +import Cgm.Data.Monoid +import Database.Perdure.ReplicatedFile +import Cgm.Data.Multiset as MS +import Debug.Trace +import Database.Perdure.SpaceBook +import Database.Perdure.Ref + +-- While Decrementer should be used on allocated values (not in s, and may have a count in c), Incrementer is used +-- on values which have already been written, but we use older values of s and c for which the value to increment +-- was not yet allocated. So most often it is s, and not in c. + +incr :: Persister a -> a -> SpaceBook -> SpaceBook +incr !p !a !s = case p of + PartialWordPersister n -> s + PairPersister pb pc -> case a of (b, c) -> incr pc c $ incr pb b s + EitherPersister pb pc -> either (incr pb) (incr pc) a s + ViewPersister i pb -> incr pb (apply i a) s + SummationPersister pi _ f -> f (\i pb _ b -> incr pb b $ incr pi i s) a + DRefPersister' -> case a of (DRef _ _ warr) -> + let referenced = incr persister $ deref a + in either (\(WordNArrayRef _ r _) -> incrRef r referenced) (\(WordNArrayRef _ r _) -> incrRef r referenced) (unwrap warr) s + CRefPersister' _ pra -> onCRef (incr pra) (incr persister) a s + +incrRef :: forall w. LgMultiple Word64 w => + BasicRef w -> (SpaceBook -> SpaceBook) -> SpaceBook -> SpaceBook +incrRef r children cs@(SpaceBook c s) = let rs = refStart r in + if isFreeSpace (getLen rs) s + then (\(SpaceBook c' s') -> SpaceBook c' $ removeSpan (refSpan r) s') $ children cs + else SpaceBook (MS.insert rs c) s diff --git a/src/Database/Perdure/LocalStoreFile.hs b/src/Database/Perdure/LocalStoreFile.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/LocalStoreFile.hs @@ -0,0 +1,335 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE TemplateHaskell, TypeFamilies, Rank2Types, GADTs, TupleSections, DeriveDataTypeable, GeneralizedNewtypeDeriving, ScopedTypeVariables, FlexibleContexts #-} + +module Database.Perdure.LocalStoreFile ( + RawStoreFile(..), + storeFileWriteWords, + storeFileReadWords, + LocalStoreFile, + withFileStoreFile, + withRawDeviceStoreFile, + withRawDeviceStoreFiles, + module Database.Perdure.StoreFile, + narrowBufsLen, + storeFileWrite1, + storeFileRead1 +) where + + +import Prelude () +import Cgm.Prelude +import Data.Typeable +import qualified Data.ByteString as B +import Control.Exception +import Control.Concurrent +import Control.Concurrent.STM +import GHC.Conc +import Data.Word +import qualified Data.Map as Map +import Data.Ord +import System.FilePath +import Data.Monoid +import Foreign.Ptr +import Foreign.Marshal.Array +import Cgm.Data.Word +import Cgm.Data.Super +import Cgm.Data.Len +import Cgm.Data.List +import Cgm.Data.Maybe +import Cgm.Data.Functor +import Cgm.Data.Monoid +import Cgm.Data.NEList +import Cgm.Data.Either +import Cgm.System.Endian +import Cgm.Control.Concurrent.TThread +import Cgm.Control.Concurrent.Await +import Cgm.System.Mem.Alloc +import Database.Perdure.Validator +import System.IO +import System.Posix.Files +import System.Posix.IO +import System.Posix.Types +import Data.Bits +import Control.Monad.Error hiding (sequence_) +import Database.Perdure.StoreFile(SyncableStoreFile(..)) +import Debug.Trace +import Control.DeepSeq +--import System.Posix.Fsync -- not needed with raw devices + +class SyncableStoreFile f => RawStoreFile f where + storeFileWriteRaw :: f -> Len Word8 Word64 -> [ArrayRange (PrimArray Pinned Word8)] -> Async Bool () + storeFileReadRaw :: f -> Len Word8 Word64 -> ArrayRange (STPrimArray RealWorld Pinned Word8) -> Async Bool () + +-- The passed endianness is the desired endianness of the words on the media. Here when the endianness does not +-- match the platform endianness, we do a copy. This case is not very optimized since we anticipate always writing in the +-- platform endianness. +storeFileWriteWords :: (Endian w, RawStoreFile f) => f -> Len Word8 Word64 -> Endianness -> [PrimArray Pinned w] -> Async Bool () +storeFileWriteWords f addr e bufs = storeFileWriteRaw f addr $ fmap fullArrayRange $ fromWords bufs where + fromWords = bool (fmap $ unsafePrimArrayCast . mapImmArray swapBytes) (fmap unsafePrimArrayCast) (e == platformWordEndianness) + +-- The passed endianness must be the endianness of the words on the media +storeFileReadWords :: (LgMultiple w Word8, Endian w, RawStoreFile f) => + f -> Len Word8 Word64 -> Endianness -> Len w Word32 -> Async (Maybe (PrimArray Pinned w)) () +storeFileReadWords f addr e l k = do + buf <- stToIO $ mkArray $ refineLen $ apply super <$> l + ($ k) $ mapAsync (bool (return Nothing) $ Just <$> processBuf buf) $ storeFileReadRaw f addr (fullArrayRange buf) where + processBuf buf = stToIO (toWords <$> unsafeFreezeSTPrimArray buf) -- TODO optimize by swapping bytes in-place then freezing + toWords = bool (mapImmArray unswapBytes . unsafePrimArrayCast) unsafePrimArrayCast (e == platformWordEndianness) + +--------------------------------------------------------------------------- + +newtype LocalStoreFile = LocalStoreFile (MVar DevOp) +-- TODO: review to see if this queue is acceptable +type ByteAddr = Len Word8 Word64 + +data PosOp = PosOp ByteAddr RWOp deriving Show +data NonPosOp = Sync (IO ()) | FullBarrier +instance Show NonPosOp where + show (Sync _) = "Sync" + show FullBarrier = "FullBarrier" + +type DevOp = Either PosOp NonPosOp + +data RWOp = + WriteOp [ArrayRange (PrimArray Pinned Word8)] (Bool -> IO ()) | + ReadOp (ArrayRange (STPrimArray RealWorld Pinned Word8)) (Bool -> IO ()) +instance Show RWOp where + show (WriteOp as _) = "WriteOp " ◊ show (sum $ fmap arrayLen as) + show (ReadOp a _) = "ReadOp " ◊ show (arrayLen a) + +-- TODO investigate why if we do not at force the ByteAddr in PosOp, testStatesDag ends with STM error +-- Forcing the rest is not necessary for this bug but makes sense here. We do not want the file thread to do work +-- that should have been done by the client threads. NFData is tricky to use here so we put together this +-- custom method. +forceDevOp :: DevOp -> () +forceDevOp = either + (\(PosOp b r) -> (b `seq`) $ + case r of + WriteOp as _ -> sum (fmap arrayLen as) `seq` () + ReadOp a _ -> arrayLen a `seq` ()) + (\n -> case n of + Sync _ -> () + FullBarrier -> ()) + +instance RawStoreFile LocalStoreFile where + storeFileWriteRaw f seek bufs k = queue f $ Left $ PosOp seek $ WriteOp bufs k + storeFileReadRaw f seek buf k = queue f $ Left $ PosOp seek $ ReadOp buf k + +instance SyncableStoreFile LocalStoreFile where + storeFileSync f k = queue f $ Right $ Sync k + storeFileFullBarrier f = queue f $ Right FullBarrier + +queue :: LocalStoreFile -> DevOp -> IO () +queue (LocalStoreFile c) op = evaluate (forceDevOp op) >> putMVar c op {- >> putStrLn ("Queued " ++ show op) -} + +-- TODO rework sync mechanism. It was fine when we assumed that all completed write tasks completed successfully, but if some are +-- to remote files that time out, we want to know when all write completed successfully. + + +narrowBufsLen :: Endian w => [PrimArray Pinned w] -> Len w Word32 +narrowBufsLen = (fromMaybe (error "Array length cannot be expressed as a Word32") . unapply super <$>) . sum . fmap arrayLen + +storeFileWrite1 :: (RawStoreFile f, Endian w) => f -> Len Word64 Word64 -> Endianness -> [PrimArray Pinned w] -> IO () +storeFileWrite1 f addr e bufs = + storeFileWriteWords f (refineLen addr) e bufs $ bool (error "storeFileWrite failed") $ return () -- TODO pass a meaningful k + +storeFileRead1 :: (RawStoreFile f, Validator v, ValidatedElem v ~ w, Endian w, LgMultiple w Word8) => + f -> Len Word64 Word64 -> Len w Word32 -> Endianness -> v -> Async (Maybe (ArrayRange (PrimArray Pinned w))) () +storeFileRead1 f addr size e v k = + ($ k) $ mapAsync (return . (>>= {-logWhenBad .-} validate v . fullArrayRange)) $ storeFileReadWords f (refineLen addr) e size {-where + logWhenBad Nothing = trace "Validation failed" Nothing + logWhenBad (Just x) = Just x-} + +-- After inspection of GHC.IO.FD, it seems that hFlush only flushes to the OS +-- Call chain: +-- hFlush calls flushWriteBuffer (See http://www.haskell.org/ghc//docs/6.12.2/html/libraries/base-4.2.0.1/src/GHC-IO-Handle.html) +-- which calls writeBuf (See http://darcs.haskell.org/packages/base/GHC/IO/FD.hs) +-- which calls RawIO's write (See http://www.haskell.org/ghc/docs/6.12.3/html/libraries/base-4.2.0.2/src/GHC-IO-BufferedIO.html#flushWriteBuffer0) + +-- Some links on the subject +-- http://www.scribd.com/doc/19537350/A-Wander-Through-GHCs-New-IO-Library +-- http://lwn.net/Articles/270891/ +-- http://ldn.linuxfoundation.org/article/filesystems-data-preservation-fsync-and-benchmarks-pt-1 +-- http://www.linux-archive.org/device-mapper-development/422441-block-fs-replace-hardbarrier-flush-fua-take-2-a.html +-- FSync FFI is available here: http://hackage.haskell.org/packages/archive/cautious-file/0.1.5/doc/html/src/System-Posix-Fsync.html + + +-- + +class Show a => Schedule a where + emptySchedule :: a + insertOp :: PosOp -> a -> a + nextOp :: a -> Maybe (PosOp, a) + +-- Multimap through a Map of NEList +minViewWithKeyNE :: Ord k => Map.Map k (NEList v) -> Maybe ((k, v), Map.Map k (NEList v)) +minViewWithKeyNE = (getSingle <$>) . Map.minViewWithKey where + getSingle ((k, ne), m) = flip onNEList ne $ \single ne' -> ((k, single), maybe id (Map.insert k) ne' m) + +data CLook = CLook ByteAddr (Map.Map ByteAddr (NEList PosOp)) (Map.Map ByteAddr (NEList PosOp)) deriving Show +updateLow u (CLook c low high) = CLook c (u low) high +updateHigh u (CLook c low high) = CLook c low (u high) +instance Schedule CLook where + emptySchedule = CLook 0 Map.empty Map.empty + insertOp op@(PosOp seek _) s@(CLook c _ _) = {- (\s' -> trace ("insertOp on " ++ show s) s') $ -} bool updateLow updateHigh (seek >= c) (Map.insertWith neAppend seek (neSingleton op)) s + nextOp s@(CLook _ low high) = {- trace ("nextOp on " ++ show s) $ -} useHighMin `firstJust` useLowMin where + useLowMin = (\((pos, op), low') -> (op, CLook pos low' high)) <$> minViewWithKeyNE low + useHighMin = (\((pos, op), high') -> (op, CLook pos low high')) <$> minViewWithKeyNE high + +-- + +instance Error () where + noMsg = () + strMsg _ = () + +class Show f => RawFile f where + fileWriteRaw :: f -> Len Word8 Word64 -> [ArrayRange (PrimArray Pinned Word8)] -> ErrorT () IO () + fileReadRaw :: f -> Len Word8 Word64 -> ArrayRange (STPrimArray RealWorld Pinned Word8) -> ErrorT () IO () + fileFlush :: f -> IO () + +instance RawFile Handle where + fileWriteRaw h seek bufs = lift $ hSeekX h seek >> sequence_ (withArrayPtr (hPutBufLen h) <$> bufs) -- TODO fix error handling + fileReadRaw h seek buf = ErrorT $ fmap (boolEither () () . (== arrayLen buf)) $ hSeekX h seek >> withArrayPtr (hGetBufLen h) buf + fileFlush = hFlush -- todo fsync or fdatasync on FD so we flush to the drive (and the platter?, see comment below) + +performAll :: (Schedule s, RawFile f) => f -> s -> IO () +performAll f s = maybe (return ()) (\(op, s') -> perform f op >> performAll f s') $ nextOp s + +perform :: RawFile f => f -> PosOp -> IO () +perform f p@(PosOp seek rw) = {- putStrLn ("about to perform " ++ show p) >> -} case rw of + WriteOp bufs k -> runErrorT (fileWriteRaw f seek bufs) >>= (log >>) . either (const $ k False) (const $ k True) where + --log = putStrLn ("Wrote " ++ showLen (sum $ fmap arrayLen bufs) ++ " at " ++ showLen seek ++ " on " ++ show f {- ++ ": " ++ show bufs -}) + log = return () + --log = putStr "w" + ReadOp buf k -> runErrorT (fileReadRaw f seek buf) >>= (log >>) . either (const $ k False) (const $ k True) where + --log = putStrLn ("Read " ++ showLen (arrayLen buf) ++ " at " ++ showLen seek ++ " from " ++ show f) + log = return () + +process :: (Schedule s, RawFile f) => MVar DevOp -> f -> s -> IO () +process c f s = {- (putStrLn ("Process on " ++ show s) >>) $ -} maybe + (takeMVar c >>= incoming) + (\(op, s') -> tryTakeMVar c >>= maybe (perform f op >> process c f s') incoming) $ + nextOp s where + incoming :: DevOp -> IO () + incoming = (>>= process c f) . either + (return . flip insertOp s) + (\op -> emptySchedule <$ + (performAll f s >> case op of + Sync k -> fileFlush f >> k + FullBarrier -> fileFlush f + ) + ) {- . (\op -> trace ("incoming") op) -} + +-- Seeks to the given position, expanding the file as necessary +hSeekX :: Handle -> ByteAddr -> IO () +hSeekX h seek = do + size <- fromIntegral <$> hFileSize h + when (size <= seek) $ do + hSeek h AbsoluteSeek (fromIntegral size) + hWriteZeros h $ seek - size + hSeek h AbsoluteSeek (fromIntegral seek) + +hWriteZeros :: Handle -> ByteAddr -> IO () +hWriteZeros h numZeros = when (numZeros > 0) $ do + let batch = min numZeros (16*1024*1024) + B.hPut h (B.replicate (fromIntegral batch) 0) + hWriteZeros h (numZeros - batch) + +newtype ChildException = ChildException SomeException deriving (Typeable, Show) +instance Exception ChildException + +-- Do not make concurrent calls on the same file, place concurrency in the passed function 'user' +withFileStoreFile :: FilePath -> (LocalStoreFile -> IO a) -> ErrorT String IO a +withFileStoreFile path user = lift $ withBinaryFile path ReadWriteMode $ \h -> hSetBuffering h NoBuffering >> withRawFile h user + +withRawDeviceStoreFile :: FilePath -> (LocalStoreFile -> IO a) -> ErrorT String IO a +withRawDeviceStoreFile path user = + ErrorT $ bracket (openFd path ReadWrite Nothing $ defaultFileFlags {exclusive = True, append = True}) closeFd $ + \fd -> runErrorT $ + do fs <- lift $ getFdStatus fd + bool (throwError "Not a raw device") (lift $ withRawFile (RawDevice fd fs 9) user) $ isCharacterDevice fs + +-- Could be generalized to allow mixing rawDevices and files. We will need to do that eventually to support remote replicas +withRawDeviceStoreFiles :: [FilePath] -> ([LocalStoreFile] -> IO a) -> ErrorT String IO a +withRawDeviceStoreFiles ps user = foldr (\p u fs -> (>>= ErrorT . pure) $ withRawDeviceStoreFile p $ \f -> runErrorT $ u $ fs ◊ [f]) (lift . user) ps [] + +toFileOffset :: Integral n => Len Word8 n -> FileOffset +toFileOffset = fromIntegral . getLen + +toByteCount :: Integral n => Len Word8 n -> ByteCount +toByteCount = fromIntegral . getLen + +fdSeekLen :: Fd -> ByteAddr -> IO () +fdSeekLen fd seek = () <$ fdSeek fd AbsoluteSeek (toFileOffset seek) + +-- TODO: consider adding support for a 'STPrimArray RealWorld Pinned Block', and a matching address type, that would enfoce the above requirements +-- However we would have to cast/view it as an array of Word8 later on. +-- | Array's size and start must be aligned on the block size, and the ByteAddr too. +fdReadArray :: Fd -> ByteAddr -> ArrayRange (STPrimArray RealWorld Pinned Word8) -> ErrorT () IO () +fdReadArray fd start a = ErrorT $ fmap (boolEither () () . (==) (toByteCount $ arrayLen a)) $ + fdSeekLen fd start >> withArrayPtr (\ptr len -> fdReadBuf fd ptr $ toByteCount len) a + +fdWriteArray :: Fd -> ByteAddr -> ArrayRange (STPrimArray RealWorld Pinned Word8) -> ErrorT () IO () +fdWriteArray fd start a = ErrorT $ fmap (boolEither () () . (==) (toByteCount $ arrayLen a)) $ + fdSeekLen fd start >> withArrayPtr (\ptr len -> fdWriteBuf fd ptr $ toByteCount len) a + +-- A bit of info on raw devices that i did not find easily elsewhere: http://www.win.tue.nl/~aeb/linux/lk/lk-11.html#ss11.4 + +data RawDevice = RawDevice Fd FileStatus Int +rawDeviceBlockBytes :: RawDevice -> Len Word8 Word +rawDeviceBlockBytes (RawDevice _ _ lg) = unsafeLen $ 1 `shiftL` lg +instance Show RawDevice where show (RawDevice fd fs _) = show $ specialDeviceID fs +-- TODO merge consecutive writes to improve performance (avoids many needless reads to preserve data that will be overwritten) +instance RawFile RawDevice where + fileWriteRaw r@(RawDevice fd _ blockBytes) start bufs = + let len = up $ sum $ arrayLen <$> bufs in + withBlockArray r start len $ ((. fullArrayRange) .) $ \tStart t -> + do + let bb = rawDeviceBlockBytes r + let tLen = arrayLen t + let tEnd = tStart + up tLen + when (tStart < start) $ fdReadArray fd tStart $ headArrayRange bb t + when (start + len < tEnd) $ fdReadArray fd (tEnd - up bb) $ skipArrayRange (tLen - bb) t + let dest = skipArrayRange (fromJust $ unapply super $ start - tStart) t + lift $ stToIO $ foldlM (\d b -> skipArrayRange (arrayLen b) d <$ mapMArrayCopyImm return b d) dest bufs + fdWriteArray fd tStart t + fileReadRaw r@(RawDevice fd _ _) start buf = + withBlockArray r start (up $ arrayLen buf) $ ((. fullArrayRange) .) $ \tStart t -> + do + -- liftIO $ putStrLn $ "Before fdReadArray " ++ show start + fdReadArray fd tStart t + let rangeToCopy = skipArrayRange (fromJust $ unapply super $ start - tStart) t + lift $ stToIO (mapMArrayCopy return rangeToCopy buf) + fileFlush _ = return () + +-- Takes start and length, and passes rounded start and an aligned buffer +withBlockArray :: MonadIO m => RawDevice -> ByteAddr -> ByteAddr -> (ByteAddr -> STPrimArray RealWorld Pinned Word8 -> m a) -> m a +withBlockArray r@(RawDevice fd _ lgBlockBytes) seek len f = + let blockBytes = rawDeviceBlockBytes r + seek' = getLen seek + len' = getLen len + start = (seek' `shiftR` lgBlockBytes) `shiftL` lgBlockBytes + end = ((seek' + len' + up (getLen blockBytes) - 1) `shiftR` lgBlockBytes) `shiftL` lgBlockBytes + in liftIO (stToIO $ newAlignedPinnedWord8Array blockBytes $ unsafeLen $ fromJust $ unapply super $ end - start) >>= + \r -> f (unsafeLen start) + -- $ trace ("withBlockArray blockBytes=" ++ show blockBytes ++ " start=" ++ show (unsafeLen start) ++ " size=" ++ (show $ arrayLen r)) + r + +withRawFile :: (RawFile f, Show f) => f -> (LocalStoreFile -> IO a) -> IO a +withRawFile f user = do + chan <- newEmptyMVar + runWithDeamon + ("User of " ++ show f, user $ LocalStoreFile chan) + ("Server for " ++ show f, bracket_ (return ()) (return (){-putStrLn $ "Server for " ++ show f ++ " ended"-}) $ process chan f (emptySchedule :: CLook)) diff --git a/src/Database/Perdure/Package.hs b/src/Database/Perdure/Package.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/Package.hs @@ -0,0 +1,19 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +module Database.Perdure.Package( + perdurePackage + ) where + +perdurePackage :: String +perdurePackage = "perdure-0.1.0" diff --git a/src/Database/Perdure/Persistent.hs b/src/Database/Perdure/Persistent.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/Persistent.hs @@ -0,0 +1,329 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE ScopedTypeVariables, + MultiParamTypeClasses, + FlexibleInstances, + FlexibleContexts, + TupleSections, + TypeOperators, + FunctionalDependencies, + GADTs, + GeneralizedNewtypeDeriving, + RankNTypes, + KindSignatures, + TemplateHaskell, + TypeFamilies, + UndecidableInstances, + DeriveFunctor, + DeriveDataTypeable #-} + +module Database.Perdure.Persistent ( + Persister(..), + Persistent(..), + Persistent1(..), + Persistent1_(..), + LgPersistent1_(..), + RefPersister(..), + RefPersistent(..), + (&.), + (|.), + lenPersister, + summationPersister, + ratioPersister, + wordPersister, + maybePersister, + shortcutPersister, + (>.), + listPersister, + ReplicatedFile, + module Database.Perdure.CRef, + DeserializerContext(..), + DRef(..), --FIXME, we want to export constructor only to implementors + WordArrayRef(..), + WordNArrayRef(..), + WArrayRef, + IRef(..), + Ref0(..), + CDRef, + Cache, + module Database.Perdure.StoreFile, + module Database.Perdure.LocalStoreFile, + module Cgm.Data.Structured +) where + +import Prelude () +import Cgm.Prelude +import Data.Word +import Data.Int +import System.IO.Unsafe +import Cgm.Data.WordN +import Cgm.Data.Word +import Cgm.Data.Len +import Cgm.Data.Structured +import Cgm.Data.Functor.Sum +import Database.Perdure.LocalStoreFile +--import Database.Perdure.SoftRef +import Data.Ratio +import Data.Lens +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Time.Calendar +import Data.Time.Clock +import Database.Perdure.Digest +import Database.Perdure.Validator +import Database.Perdure.WValidator +import Database.Perdure.StoreFile +import Database.Perdure.ReplicatedFile +import Database.Perdure.Allocator +import Cgm.System.Endian +import Data.Ord +import Data.Char +import Data.Binary.IEEE754 +import Cgm.Data.List +import Data.Ratio +import Data.Bits +import Database.Perdure.CRef +import Data.Cache.LRU +import Data.Dynamic +import Control.Concurrent.MVar +import Cgm.Data.Typeable + +data WordNArrayRef v (r :: * -> *) = WordNArrayRef !v !(r (ValidatedElem v)) !Endianness + +data WordArrayRef r32 r64 (r :: * -> *) = Word32ArrayRef !(r32 r) | Word64ArrayRef !(r64 r) + +type WArrayRef = WordArrayRef (WordNArrayRef W32Validator) (WordNArrayRef W64Validator) + +type Cache = LRU (Len Word64 Word64) Dynamic + +data DeserializerContext = forall f. (StoreFile f, StoreRef f ~ BasicRef) => DeserializerContext {dcFile :: f, dcCache :: MVar Cache} + +data DRef a where + DRef :: Typeable a => !(Persister a) -> !DeserializerContext -> !(WArrayRef BasicRef) -> DRef a deriving Typeable + +class LgPersistent1_ (r :: * -> *) where lgPersister1_ :: (LgMultiple Word64 w) => Persister (r w) + +data Persister a where + PartialWordPersister :: !(Len Bool Word) -> Persister Word -- Do not export to user + PairPersister :: !(Persister a) -> !(Persister b) -> Persister (a, b) + EitherPersister :: !(Persister a) -> !(Persister b) -> Persister (Either a b) + ViewPersister :: !(InjectionA' a b) -> Persister b -> Persister a -- Not strict in Persister b because here we want to allow cycles + SummationPersister :: !(Persister i) -> + !(forall z. (forall b. Persister b -> (b -> a) -> z) -> i -> z) -> + !(forall z. (forall b. i -> Persister b -> (b -> a) -> b -> z) -> a -> z) -> Persister a + -- The index persister above should not contain refs because CSerializer uses the (b -> a), which ignores any storage changes to the i. + -- The i is not stored as is in memory. + DRefPersister' :: (Typeable a, Persistent a) => Persister (DRef a) + -- Persistent a instead of Persister a, multiple DRefs can point to the same location, so they must share the + -- same persister for a. Unless we were to support persistence of persisters, in which case the persister could + -- be encoded at the start of the referenced data (might be wasteful to always do this though). Persistence of + -- persisters means restricting ViewPersister to persistable views however (possibly only Structure), and + -- then we would also need to persist data with cycles. + CRefPersister' :: (Typeable a, Persistent a) => !(RefPersister r) -> !(Persister (r a)) -> Persister (CRef r a) + +instance InjectionACofunctor Persister where iacomap pb i = ViewPersister (injectionA' i) pb + +infixr 7 &. +(&.) :: Persister a -> Persister b -> Persister (a, b) +(&.) = PairPersister + +infixr 6 |. +(|.) :: Persister a -> Persister b -> Persister (Either a b) +(|.) = EitherPersister + +summationPersister :: (Persister i) -> + (forall z. (forall b. Persister b -> (b -> a) -> z) -> i -> z) -> + (forall z. (forall b. i -> Persister b -> (b -> a) -> b -> z) -> a -> z) -> Persister a +summationPersister = SummationPersister + +data RefPersister r where + Ref0Persister :: RefPersister Ref0 + RefView :: (forall a. rb a -> ra a) -> RefPersister rb -> RefPersister ra + SizeRefPersister :: Len Bool Word -> RefPersister (Sum Ref0 DRef) + CRefPersister :: RefPersister r -> RefPersister (CRef r) + DRefPersister :: RefPersister DRef + IRefPersister :: RefPersister r -> RefPersister (IRef r) + +class RefPersistent r where refPersister :: RefPersister r + +instance RefPersistent Ref0 where refPersister = Ref0Persister +instance RefPersistent r => RefPersistent (CRef r) where refPersister = CRefPersister refPersister +instance RefPersistent DRef where refPersister = DRefPersister +instance RefPersistent r => RefPersistent (IRef r) where refPersister = IRefPersister refPersister + +class Persistent1_ (r :: * -> *) where persister1_ :: Persister (r a) + +class Persistent2_ (r :: * -> * -> *) where persister2_ :: Persistent f => Persister (r f a) + +class Persistent1 r where persister1 :: (Typeable a, Persistent a) => Persister (r a) +instance Persistent1 Ref0 where persister1 = structureMap persister +instance Persistent1 DRef where persister1 = DRefPersister' +instance Persistent1 r => Persistent1 (IRef r) where persister1 = structureMap persister1 +instance (RefPersistent r, Persistent1 r) => Persistent1 (CRef r) where persister1 = CRefPersister' refPersister persister1 +instance (Persistent1 ra, Persistent1 rb) => Persistent1 (Sum ra rb) where persister1 = structureMap $ persister1 |. persister1 + +-- Persistent + +class Persistent a where persister :: Persister a + +instance Persistent () where + {-# INLINE persister #-} + persister = PartialWordPersister 0 `iacomap` uncheckedInjectionA (\() -> 0) (const $ Just ()) +instance Persistent Bool where + {-# INLINE persister #-} + persister = persister `iacomap` boolAsWord +instance Persistent Char where + {-# INLINE persister #-} + persister = persister `iacomap` (uncheckedBijection (fromIntegral . ord) (chr . fromIntegral) :: Bijection' Char (RWord Word32 D21)) +instance (Persistent a, Persistent b) => Persistent (Either a b) where + {-# INLINE persister #-} + persister = persister |. persister +instance (Persistent a1, Persistent a2) => Persistent (a1, a2) where + {-# INLINE persister #-} + persister = persister &. persister +instance (Persistent a1, Persistent a2, Persistent a3) => Persistent (a1,a2,a3) where persister = structureMap persister +instance (Persistent a1, Persistent a2, Persistent a3, Persistent a4) => Persistent (a1,a2,a3,a4) where persister = structureMap persister +instance (Persistent a1, Persistent a2, Persistent a3, Persistent a4, Persistent a5) => Persistent (a1,a2,a3,a4,a5) where + persister = structureMap persister +instance (Persistent a1, Persistent a2, Persistent a3, Persistent a4, Persistent a5, Persistent a6) => Persistent (a1,a2,a3,a4,a5,a6) where + persister = structureMap persister +instance Persistent Ordering where persister = structureMap persister +instance Persistent Word where + {-# INLINE persister #-} + persister = wordPersister +instance Persistent Word8 where + {-# INLINE persister #-} + persister = unsafeBitsPersister +instance Persistent Word16 where + {-# INLINE persister #-} + persister = unsafeBitsPersister +instance Persistent Word32 where + {-# INLINE persister #-} + persister = onWordConv (wordPersister `iacomap` inv wordConv) unsafeBitsPersister +instance Persistent Word64 where + {-# INLINE persister #-} + persister = onWordConv (persister `iacomap` splitWord64LE) (wordPersister `iacomap` inv wordConv) +instance Persistent Int where persister = persister `iacomap` unsigned +instance Persistent Int8 where persister = persister `iacomap` unsigned +instance Persistent Int16 where persister = persister `iacomap` unsigned +instance Persistent Int32 where persister = persister `iacomap` unsigned +instance Persistent Int64 where persister = persister `iacomap` unsigned +instance Persistent Float where persister = persister `iacomap` uncheckedBijection floatToWord wordToFloat +instance Persistent Double where persister = persister `iacomap` uncheckedBijection doubleToWord wordToDouble +instance Persistent Integer where persister = persister `iacomap` integerWords +instance (Integral a, Persistent a) => Persistent (Ratio a) where persister = ratioPersister persister +instance RWordC Word8 n => Persistent (RWord Word8 n) where persister = unsafeBitsPersister +instance RWordC Word16 n => Persistent (RWord Word16 n) where persister = unsafeBitsPersister +instance RWordC Word32 n => Persistent (RWord Word32 n) where persister = unsafeBitsPersister +instance RWordC Word64 n => Persistent (RWord Word64 n) where + persister = bool (onWordConv r64on32 unsafeBitsPersister) (PartialWordPersister n' `iacomap` unsafeIntegralAsWord) $ n' <= 32 where + n' = (at :: At (RWord Word64 n)) bitSizeLen + r64on32 = (persister &. partialWord32Persister) `iacomap` (injectionA' splitWord64LE . injectionA' super) + partialWord32Persister = PartialWordPersister (n' - 32) `iacomap` unsafeIntegralAsWord + -- spliting into a (Word32, RWord32) would be cleaner, but would require addSub as below, + -- and there might be some performance problems with that +instance Persistent a => Persistent (Maybe a) where persister = maybePersister persister +instance Persistent a => Persistent [a] where persister = listPersister persister +instance Persistent a => Persistent (Ref0 a) where persister = structureMap persister +instance Persistent W32Validator where persister = structureMap persister +instance Persistent W64Validator where persister = structureMap persister +instance Persistent Word128 where persister = structureMap persister +instance Persistent MD5Digest where persister = structureMap persister +instance Persistent h => Persistent (Skein512Digest h) where persister = structureMap persister +instance (Persistent1 r, Typeable a, Persistent a) => Persistent (IRef r a) where persister = persister1 +instance (Persistent1 ra, Persistent1 rb, Typeable a, Persistent a) => Persistent ((Sum ra rb) a) where persister = structureMap $ persister1 |. persister1 +instance (RefPersistent r, Persistent1 r, Typeable a, Persistent a) => Persistent (CRef r a) where persister = persister1 +instance Persistent a => Persistent (Len u a) where persister = lenPersister persister +instance (Ord k, Persistent k, Persistent v) => Persistent (Map.Map k v) where persister = persister `iacomap` (uncheckedInjection Map.toList Map.fromList) +instance (Ord k, Persistent k) => Persistent (Set.Set k) where persister = persister `iacomap` (uncheckedInjection Set.toList Set.fromList) +instance Persistent Day where persister = structureMap persister +instance Persistent UTCTime where persister = structureMap persister +instance Persistent DiffTime where persister = persister `iacomap` (uncheckedInjection toRational fromRational) +instance Persistent c => Persistent (() -> c) where + persister = persister `iacomap` (uncheckedBijection ($ ()) const) +instance (Persistent (a -> c), Persistent (b -> c)) => Persistent (Either a b -> c) where + persister = persister `iacomap` (uncheckedBijection (\f -> (f . Left, f . Right)) (\(fa, fb) -> either fa fb)) + +instance (Typeable a, Persistent a) => Persistent (DRef a) where persister = persister1 +instance Persistent (BasicRef w) where persister = structureMap persister +instance LgPersistent1_ BasicRef where lgPersister1_ = persister +instance (Persistent v, LgPersistent1_ r, LgMultiple Word64 (ValidatedElem v)) => Persistent (WordNArrayRef v r) where + persister = structureMap $ persister &. lgPersister1_ &. (structureMap persister) +instance (Persistent (r32 r), Persistent (r64 r)) => Persistent (WordArrayRef r32 r64 r) where + persister = structureMap $ persister |. persister + +{-# INLINE listPersister #-} +listPersister :: List a => Persister (Listed a) -> Persister a +listPersister elemPersister = (maybePersister $ elemPersister &. listPersister elemPersister) `iacomap` listStructure + +-- Takes persisters for 2 types, and an injection from the smaller type 'a' to the larger type 'b', and gives a persister for the larger type which uses +-- the smaller type representation when possible, plus one bit to identify which representation is used. +shortcutPersister :: InjectionM i => i a b -> Persister b -> Persister a -> Persister b +shortcutPersister i b a = (b |. a) `iacomap` eitherI where + eitherI = uncheckedInjection (\x -> ($ x) $ maybe (Left x) Right . unapply i) (either id $ apply i) + +-- Specialization of shortcutPersister with the 'super' injection. +infixl 9 >. +(>.) :: Super a b => Persister b -> Persister a -> Persister b +(>.) = shortcutPersister super + +maybePersister :: Persister a -> Persister (Maybe a) +maybePersister elemPersister = structureMap $ persister |. elemPersister + +bitPersister :: Persister Word -- Do not export to user +bitPersister = PartialWordPersister 1 +wordPersister :: Persister Word +wordPersister = PartialWordPersister wordBits + +-- prefer wordPersister when writing a full word +-- unsafe because (bitSize a) size must not exceed Word size +unsafeBitsPersister :: forall a. (Bits a, Integral a) => Persister a +unsafeBitsPersister = PartialWordPersister ((at :: At a) bitSizeLen) `iacomap` unsafeIntegralAsWord + +-- unsafe because (bitSize a) size must not exceed Word size +unsafeIntegralAsWord :: Integral a => Injection' a Word +unsafeIntegralAsWord = uncheckedInjection fromIntegral fromIntegral + +lenPersister :: Persister a -> Persister (Len u a) +lenPersister = structureMap + +{-# INLINE ratioPersister #-} +ratioPersister :: Integral a => Persister a -> Persister (Ratio a) +ratioPersister elemPersister = + (elemPersister &. elemPersister) `iacomap` (uncheckedBijection (numerator &&& denominator) (uncurry (%))) + +integerWords :: Bijection' Integer (Int32, [Word32]) +integerWords = uncheckedBijection + (unfoldlE $ \i -> let o = fromIntegral i in if fromIntegral o == i then Left o else Right (i `shiftR` 32, fromIntegral i)) + (\(i, l) -> foldl (\x d -> (x `shiftL` 32) + fromIntegral d) (fromIntegral i) l) + + +-- IRef + +newtype IRef r t = IRef {getIRef :: r t} deriving (Functor, Applicative) + +-- Ref0 + +newtype Ref0 a = Ref0 a deriving (Functor, Eq) + +-- Temporary Aliases +type CDRef = CRef DRef + +deriveStructured ''Ref0 +deriveStructured ''IRef +deriveStructured ''Day +deriveStructured ''UTCTime +deriveStructured ''WordNArrayRef +deriveStructured ''WordArrayRef + diff --git a/src/Database/Perdure/RNF.hs b/src/Database/Perdure/RNF.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/RNF.hs @@ -0,0 +1,39 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE TypeOperators, GeneralizedNewtypeDeriving, ScopedTypeVariables, FlexibleContexts, GADTs #-} + +module Database.Perdure.RNF ( + prnf + ) where + +import Control.Applicative +import System.IO.Unsafe +import Cgm.Data.Word +import Cgm.Data.WordN +import Cgm.Control.InFunctor +import Cgm.Control.Combinators +import Database.Perdure.Persistent +--import Database.Perdure.SoftRef +--import Database.Perdure.WriteRef +import Database.Perdure.CRef + +prnf :: Persister a -> a -> () +prnf p = case p of + PartialWordPersister n -> (`seq` ()) + PairPersister pa pb -> \(a, b) -> prnf pa a `seq` prnf pb b + EitherPersister pa pb -> either (prnf pa) (prnf pb) + ViewPersister i pb -> prnf pb . apply i + SummationPersister pi _ s -> s (\i pb _ b -> prnf pi i `seq` prnf pb b) + DRefPersister' -> (`seq` ()) -- Do not load, the persisted reference is already fully evaluated + CRefPersister' _ pra -> onCRef (prnf pra) (prnf persister) diff --git a/src/Database/Perdure/Ref.hs b/src/Database/Perdure/Ref.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/Ref.hs @@ -0,0 +1,43 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + + +module Database.Perdure.Ref ( + Ref(..), + ref, + refLens, + module Database.Perdure.Deref, + ) where + +import System.IO.Unsafe +import Cgm.Data.Functor.Sum +import Cgm.Control.Combinators +import Database.Perdure.Deref +import Data.Lens +import Database.Perdure.Persistent +import Control.Applicative + +class Deref r => Ref r where + refIO :: a -> IO (r a) + +{-# NOINLINE ref #-} +ref :: Ref r => a -> r a +ref = unsafePerformIO . refIO + +refLens :: Ref r => Lens (r a) a +refLens = lens deref $ const . ref + +instance Ref r => Ref (IRef r) where refIO = (IRef <$>) . refIO +instance Ref Ref0 where refIO = return . Ref0 +instance Deref r => Ref (CRef r) where refIO = return . ToRef +instance Deref r => Functor (CRef r) where fmap f = ref . f . deref diff --git a/src/Database/Perdure/ReplicatedFile.hs b/src/Database/Perdure/ReplicatedFile.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/ReplicatedFile.hs @@ -0,0 +1,41 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE TypeFamilies #-} + +module Database.Perdure.ReplicatedFile ( + ReplicatedFile(..) + ) where + +import Control.Applicative +import Database.Perdure.StoreFile +import Database.Perdure.LocalStoreFile +import Cgm.Control.Concurrent.NotificationCount +import Cgm.Data.Word + +newtype ReplicatedFile = ReplicatedFile [LocalStoreFile] + +instance StoreFile ReplicatedFile where + type StoreRef ReplicatedFile = BasicRef + storeFileWrite (ReplicatedFile fs) addr e bufs = do + sequence_ $ fmap (\f -> storeFileWrite1 f addr e bufs) fs + return (BasicRef addr $ narrowBufsLen bufs) + storeFileRead (ReplicatedFile fs) (BasicRef addr size) e v k = + foldr (\f retry -> await1 (storeFileRead1 f addr size e v) >>= maybe retry (k . Just)) (k Nothing) fs + +instance SyncableStoreFile ReplicatedFile where + storeFileSync (ReplicatedFile fs) = withNotificationCount $ \n -> sequence_ $ (notifying n . storeFileSync) <$> fs + storeFileFullBarrier (ReplicatedFile fs) = sequence_ $ storeFileFullBarrier <$> fs + +-- TODO see if we can have the user threads perform the digest checks + diff --git a/src/Database/Perdure/Rev.hs b/src/Database/Perdure/Rev.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/Rev.hs @@ -0,0 +1,81 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE TypeFamilies, RankNTypes, EmptyDataDecls, DeriveDataTypeable, TypeOperators, FlexibleContexts, UndecidableInstances, ScopedTypeVariables #-} + +module Database.Perdure.Rev( + (:>)(..), + onRev, + NoRev, + onNoRev, + toCurrent, + toOnlyRev, + revPersister, + latestLens + ) where + +import Database.Perdure.Persistent +import Database.Perdure.Ref +import Cgm.Data.Tagged +import Data.Lens +import Data.Typeable + +infixr 1 :> +-- | A data type which is equivalent to Either, but which is persisted in an open manner which allows us to chain new +-- variants on the left. As more variants are added (going from NoRev to V1 :> NoRev and then to V2 :> V1 :> NoRev), the +-- persisted representation gets expanded without breaking the representation of previous variants. +-- We do not use Either because of the risk of persisting it in the standard manner and therefore losing upgradability. +data a :> b = Current a | Previous b deriving Typeable + +onRev :: (a -> z) -> (b -> z) -> (a :> b) -> z +onRev az bz r = case r of {Current a -> az a; Previous b -> bz b} + +-- | An uninhabited type used as the last (rightmost) type in chains of '(:>)' +data NoRev deriving Typeable +onNoRev :: NoRev -> z +onNoRev _ = undefined + +toOnlyRev :: (a :> NoRev) -> a +toOnlyRev = toCurrent onNoRev + +-- | Converts a chain of revisions to the 'Current' type, given a way to convert the 'Previous' type to the 'Current' type. +toCurrent :: (b -> a) -> (a :> b) -> a +toCurrent = onRev id + +class Rev a where lastRev :: Tagged a Integer +instance Rev NoRev where lastRev = tag (-1) +instance Rev b => Rev (a :> b) where lastRev = tag $ (at :: At b) lastRev + 1 + +class Rev a => PersistentRev a where + deserRev :: (forall b. Persister b -> (b -> a) -> z) -> Integer -> z + serRev :: (forall b. Integer -> Persister b -> (b -> a) -> b -> z) -> a -> z +instance PersistentRev NoRev where + deserRev _ _ = error "bad index when deserializing Rev" + serRev f = onNoRev +instance (Persistent b, PersistentRev r) => PersistentRev (b :> r) where + deserRev f i = if i == (at :: At (b :> r)) lastRev then f persister Current else deserRev ((. (Previous .)) . f) i + serRev f = onRev (f ((at :: At (b :> r)) lastRev) persister Current) (serRev $ ((. (Previous .)) .) . f) + +-- | The persister for '(:>)' first writes out the numeric index, from the right, in the chain of revisions. This way the chain of alternative +-- revisions can lengthen without changing the indices of past revisions. +revPersister :: PersistentRev a => Persister a +revPersister = summationPersister persister deserRev serRev + +instance Persistent NoRev where persister = revPersister +instance PersistentRev (b :> r) => Persistent (b :> r) where persister = revPersister + +-- | This is not a legal lens since it violates the law which says that setting back what you got must have no effect. +-- Here it is almost true since the only effect it has is to upgrade to the current representation, an idempotent change +-- for a semantically equivalent value. +latestLens :: (b -> a) -> Lens (a :> b) a +latestLens toLatest = lens (toCurrent toLatest) (const . Current) diff --git a/src/Database/Perdure/RootValidator.hs b/src/Database/Perdure/RootValidator.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/RootValidator.hs @@ -0,0 +1,70 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE TemplateHaskell, FlexibleContexts, TypeFamilies, TupleSections, ScopedTypeVariables, FlexibleInstances, UndecidableInstances #-} + +module Database.Perdure.RootValidator ( + RootValidator(..), + ValidationDigestWord(..), + module Database.Perdure.Validator + ) where + +import Data.Word +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Lazy as Lazy +import qualified Data.Binary as Binary +import Crypto.Hash.Tiger +import Foreign.Marshal.Alloc +import Foreign.Marshal.Array +import System.IO.Unsafe +import Database.Perdure.Digest +import Cgm.Data.Maybe +import Cgm.Data.Len +import Database.Perdure.Validator +import Database.Perdure.CSerializer +import Database.Perdure.CDeserializer +import Cgm.Control.Concurrent.Await +import Cgm.Control.Combinators +import Database.Perdure.AllocCopy + +-- ValidationDigest assiciates a particular digest method to each word type to digest (Word32 and Word64) +-- It must be a right inverse of DigestWord. +-- We'd need a superclass equality constraint here. +-- As a first wordaround attempt we place the equality constraint in instances +-- Users fail with an infinite type error. +-- Read a relevant post: http://www.haskell.org/pipermail/haskell-cafe/2009-January/053696.html +-- Actual workaround we used: removed Digest from superclass of ValidationDigestWord, added digest' method which delegates to digest +class (AllocCopy w, Deserializable w, LgMultiple w Bool, LgMultiple w Word8, LgMultiple Word64 w, Persistent (ValidationDigest w), + Eq (ValidationDigest w), Show (ValidationDigest w)) => ValidationDigestWord w where + type ValidationDigest w + digest' :: (ImmArray r, PinnedArray r, ArrayElem r ~ w) => r -> ValidationDigest w +instance ValidationDigestWord Word32 where + type ValidationDigest Word32 = MD5Digest + digest' = digest +instance ValidationDigestWord Word64 where + type ValidationDigest Word64 = Skein512Digest Word128 + digest' = digest + +data RootValidator w = RootValidator deriving (Eq, Show) +type Header w = (Len w Word, ValidationDigest w) +instance (ValidationDigestWord w, Show (ValidationDigest w)) => Validator (RootValidator w) where + type ValidatedElem (RootValidator w) = w + mkValidationInput b = (RootValidator, [serializeToArray persister ((arrayLen b, digest' b) :: Header w), b]) + validate RootValidator b = + let DeserOut ((len, h) :: Header w) u = deserializeFromArray (unsafeSeqDeserializer persister) b + payload = headArrayRange len $ skipArrayRange (coarsenLen u) b + in payload `justIf` (digest' payload == h) + +instance Persistent (RootValidator w) where persister = structureMap persister + +deriveStructured ''RootValidator diff --git a/src/Database/Perdure/SingleStoreFile.hs b/src/Database/Perdure/SingleStoreFile.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/SingleStoreFile.hs @@ -0,0 +1,30 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE TypeFamilies, Rank2Types, GADTs, TupleSections, DeriveDataTypeable, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} + +module Database.Perdure.SingleStoreFile ( + SingleStoreFile(..) + ) where + +import Database.Perdure.StoreFile +import Database.Perdure.LocalStoreFile +import Cgm.Data.Word + + +newtype SingleStoreFile a = SingleStoreFile a deriving SyncableStoreFile +instance RawStoreFile a => StoreFile (SingleStoreFile a) where + type StoreRef (SingleStoreFile a) = BasicRef + storeFileWrite (SingleStoreFile f) addr e bufs = storeFileWrite1 f addr e bufs >> return (BasicRef addr $ narrowBufsLen bufs) + storeFileRead (SingleStoreFile f) (BasicRef addr size) = storeFileRead1 f addr size + diff --git a/src/Database/Perdure/SizeRef.hs b/src/Database/Perdure/SizeRef.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/SizeRef.hs @@ -0,0 +1,48 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE TemplateHaskell, TypeFamilies, ScopedTypeVariables, FlexibleInstances, FlexibleContexts, DeriveDataTypeable, StandaloneDeriving #-} + +module Database.Perdure.SizeRef ( + SizeRef + ) where + +import Data.Bits +import Cgm.Data.Word +import Cgm.Data.Len +import Database.Perdure.Persistent +import Cgm.Data.Functor.Sum +import Database.Perdure.DRef +import Database.Perdure.Allocator +import Database.Perdure.StoreFile +import Cgm.Data.Nat +import Data.Dynamic + +-- | A reference type which automatically puts its referent is a separately loadable allocation when that +-- allocation's size is greater than 2^n bytes. +data SizeRef n a = TooSmallForRef !a | LargeEnoughForRef !(DRef a) deriving Typeable +deriving instance Show a => Show (SizeRef n a) + +instance Persistent1 (SizeRef n) where persister1 = structureMap $ persister |. persister1 +instance Nat n => RefPersistent (SizeRef n) where + refPersister = RefView (either (TooSmallForRef . deref) LargeEnoughForRef . getSum) $ + SizeRefPersister $ refineLen l where + l :: Len Word8 Word + l = unsafeLen $ 1 `shiftL` (at :: At n) intOfNat + -- The use of the SizeRef constructor above instead of struct is required because the Structure typeclass seems + -- only able to dispatch on monotypes + -- Also the type annotation is necessary, and it seems to be because we are using the InjectionA typeclass, with no functional dependencies between + -- the related types. +instance Deref (SizeRef n) where derefIO = either return derefIO . structure + +deriveStructured ''SizeRef diff --git a/src/Database/Perdure/Space.hs b/src/Database/Perdure/Space.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/Space.hs @@ -0,0 +1,36 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +module Database.Perdure.Space ( + Space(..), + Span, + module Cgm.Data.SortedPair, + module Data.Monoid + ) where + +import Prelude() +import Cgm.Prelude +import Data.Monoid +import Data.Word +import Cgm.Data.SortedPair + +type Span = SortedPair Word64 + +-- Users must ensure they do not add overlapping spans, or remove spans unless all of its contents has already been added (perhaps as seperate spans) +class Space a where + emptySpace :: a + removeSpan :: Span -> a -> a + addSpan :: Span -> a -> a + findSpan :: Word64 -> a -> [Span] + isFreeSpace :: Word64 -> a -> Bool + diff --git a/src/Database/Perdure/SpaceBook.hs b/src/Database/Perdure/SpaceBook.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/SpaceBook.hs @@ -0,0 +1,44 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE ScopedTypeVariables, TemplateHaskell, FlexibleContexts, UndecidableInstances, TypeFamilies, DeriveDataTypeable #-} + +module Database.Perdure.SpaceBook( + SpaceBook(..) + ) where + +import Prelude () +import Cgm.Prelude +import Cgm.Data.Structured +import Control.Monad.State +import Database.Perdure.Persistent +import Database.Perdure.Space +import Database.Perdure.SpaceTree +import Database.Perdure.Count +import Database.Perdure.Data.MapMultiset +import Database.Perdure.CSerializer(Address) +import Cgm.Data.Monoid +import Database.Perdure.ReplicatedFile +import Debug.Trace +import Cgm.Data.Super +import Database.Perdure.Package +import Cgm.Data.Typeable + +data SpaceBook = SpaceBook { + bookCount :: !(MapMultiset Address), + bookSpace :: !SpaceTree + } deriving Typeable + +instance Persistent SpaceBook where persister = structureMap persister + +deriveStructured ''SpaceBook diff --git a/src/Database/Perdure/SpaceTree.hs b/src/Database/Perdure/SpaceTree.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/SpaceTree.hs @@ -0,0 +1,64 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE TypeFamilies, TemplateHaskell, DeriveDataTypeable #-} + +module Database.Perdure.SpaceTree( + SpaceTree + ) where + +import Prelude() +import Cgm.Prelude +import Data.Word +import Cgm.Data.Maybe +import Cgm.Control.Monad.State +import Database.Perdure.Space +import Database.Perdure.Data.Map +import Database.Perdure.Persistent +import Debug.Trace +import Data.Typeable + +newtype SpaceTree = SpaceTree (Map Word64 Bool) deriving Typeable +instance Space SpaceTree where + emptySpace = SpaceTree Database.Perdure.Data.Map.empty + removeSpan = onSortedPair (\b e -> spaceTreeIncr e . spaceTreeDecr b) + addSpan = onSortedPair (\b e -> spaceTreeIncr b . spaceTreeDecr e) + findSpan sz (SpaceTree m) = filter (onSortedPair $ \start end -> end - start > sz) $ + let + start = 0 -- TODO pass that in as a parameter + mkSpans [] = [] + mkSpans (k : []) = error "bad SpaceTree" + mkSpans (k0 : k1 : ks) = unsafeSortedPair k0 k1 : mkSpans ks + in mkSpans $ + (\(b, ks) -> bool (start : ks) ks b) $ -- When bool is false, prepend 'start' (consider that the span possibly overlapping 'start' actually starts at 'start') + ($ (True, [])) $ + fromMaybe (const (True, [])) $ + scan (\k -> bool (\_ -> id) (\b (_, ks) -> (b, k : ks)) $ k > start) + (\k l r -> bool (l . r) r $ k <= start) m + -- scan's z is of type (Bool, [Address]) -> (Bool, [Address]) where the Bool is the value of the first key in the list (undefined when empty). + -- Only keys > a are kept. The function prepends address, and only checks the input Bool when it has nothing to prepend. + -- relies on the invariant where values alternate between True and False as scan keys in ascending or descending order + isFreeSpace a (SpaceTree m) = fromMaybe False $ fromMaybe Nothing $ + scan (\k -> bool (const Nothing) Just $ k <= a) (\k -> bool (\l r -> maybe l Just r) const $ k >= a) m + -- scan's z is of type Maybe Bool and is Just the value associated to the largest key <= a, or Nothing there is no such key, cool use of lazyness + +spaceTreeIncr :: Word64 -> SpaceTree -> SpaceTree +spaceTreeIncr a (SpaceTree m) = + SpaceTree $ fromMaybe m $ snd $ runState (updateM a $ get >>= maybe (put (Just True)) (bool (put Nothing) (error $ "spaceTreeIncr " ++ show a))) m +spaceTreeDecr :: Word64 -> SpaceTree -> SpaceTree +spaceTreeDecr a (SpaceTree m) = + SpaceTree $ fromMaybe m $ snd $ runState (updateM a $ get >>= maybe (put (Just False)) (bool (error $ "spaceTreeDecr " ++ show a) (put Nothing))) m + +instance Persistent SpaceTree where persister = structureMap persister + +deriveStructured ''SpaceTree diff --git a/src/Database/Perdure/State.hs b/src/Database/Perdure/State.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/State.hs @@ -0,0 +1,280 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE ScopedTypeVariables, TemplateHaskell, TupleSections, FlexibleContexts, FlexibleInstances, UndecidableInstances, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators #-} + +module Database.Perdure.State( + PState(stateLocation, stateSpace, stateRoot), + --initStateN, + Root(..), + RootValues(..), + rootAllocSize, + initState, + readState, + writeState, + --asyncWriteState, + updateState, + updateStateRead, + --asyncCollectState, + collectState, + collectStateM, + emptyCache, + module Database.Perdure.Space, + module Database.Perdure.Persistent, + CachedFile(..), + RootLocation(..), + RootAddress(..), + stateValue + ) where + +import Prelude() +import Cgm.Prelude +import Control.Concurrent +import qualified Cgm.Control.Monad.State as M +import Control.Monad.State hiding (sequence) +import Control.Monad.Reader hiding (sequence) +import Control.Applicative +import Foreign.Marshal.Alloc +import Foreign.Marshal.Array +import Data.Ord +import Data.Functor.Constant +import Data.Functor.Identity +import Cgm.System.Mem.Alloc +import Cgm.Data.Word +import Cgm.Data.Len +import Cgm.Data.List +import Database.Perdure.Persistent +import Database.Perdure.CSerializer +import Database.Perdure.Decrementer +import Database.Perdure.Incrementer +import Database.Perdure.RootValidator +import Database.Perdure.SizeRef +import Database.Perdure.Space +import Database.Perdure.SpaceTree +import Database.Perdure.Count +import Database.Perdure.Data.MapMultiset +import Cgm.System.Endian +import Cgm.Control.Combinators +import Cgm.Control.Concurrent.MVar +import Cgm.Control.Concurrent.Await +import Cgm.Data.Monoid +import Control.Arrow +import Cgm.Data.Multiset as MS +import Debug.Trace +import Database.Perdure.Ref +import Database.Perdure.SpaceBook +import Database.Perdure.Package +import Cgm.Data.Typeable +import qualified Data.Cache.LRU as LRU +import Cgm.Data.Maybe +import Database.Perdure.WriteBits +import Database.Perdure.AllocCopy +import Cgm.Data.Super +import Database.Perdure.Allocator +import Database.Perdure.Rev + +moduleName :: String +moduleName = "Database.Perdure.State" + +data CachedFile = CachedFile ReplicatedFile (MVar Cache) + +-- | The RootLocation specifies where roots are written, and provides a cache. +data RootLocation = RootLocation CachedFile [RootAddress] + +-- | A number which is incremented every time a state is written. +newtype StateId = StateId Word64 deriving (Ord, Eq, Show, Enum, Bounded, Persistent, Num, Real, Integral) + +newtype RootAddress = RootAddress {getRootAddress :: Address} deriving (Eq, Show) +rootRef :: LgMultiple Word64 w => RootAddress -> BasicRef w +rootRef (RootAddress a) = BasicRef a $ refineLen rootAllocSize + +-- | The PState represents the whole state of the database. It is needed to perform updates. +data PState a = PState { + stateLocation :: RootLocation, + stateSpace :: SpaceTree, + -- ^ stateSpace is always a subset of (or the same as) the true free space as determined by scanning rootScan from rootScan's s and c + -- This subset is maintained conservatively to speed up new allocations. + stateRoot :: RootVersions a -- ^ The persisted data consisting of bookkeeping data and user data. + } + +stateValue :: PState a -> a +stateValue = deref . rootValue . rootScan . toOnlyRev . stateRoot + +-- LATER For now a root occupies a constant space (an id and 4 DRefs). It would be preferable to +-- not use a CDRef of a but a SizeRef that would allow us to write more data in the root (keeping in mind though that we need room +-- for 2 such references, after we have deducted the space for the id and the other two DRefs). +-- | Root persisted data. The 'a' type parameter is the user persisted data type. +data Root a = Root { + rootId :: StateId, + rootDecr :: Maybe (RootValues a), + rootScan :: RootValues a + } + +type RootVersions a = Root a :> NoRev + +instance (Persistent a, Typeable a) => Persistent (Root a) where persister = structureMap persister + +data RootValues a = RootValues { + rootCS :: CDRef SpaceBook, + rootValue :: CDRef a + } + +instance (Persistent a, Typeable a) => Persistent (RootValues a) where + persister = structureMap persister + +-- | Writes an initial state (creates a new database). +-- Most often the passed 'a' will be a fresh unpersisted value. This is always safe. +-- However it is legal for parts of 'a' to be already persisted, but they must only use allocations within the passed SpaceTree. +-- To read the state of an existing database use readState. +initState :: (Persistent a, Typeable a) => RootLocation -> SpaceTree -> a -> IO (PState a) +initState = initStateN minBound + +-- | The persisted value 'a' must only use memory contained in 'SpaceTree'. +initStateN :: (Persistent a, Typeable a) => StateId -> RootLocation -> SpaceTree -> a -> IO (PState a) +initStateN i l s a = + let sb = SpaceBook MS.emptySet s + s' = bookSpace $ incr persister a sb -- Before we can write anything else, we need to know what memory is actually free. + in await0 $ writeRootSimple l s' $ Current $ Root i Nothing $ RootValues (ref sb) (ref a) + +-- | Reads the state of an existing database. It only reads the root, and the rest is lazy loaded. +-- The RootLocation must match the one use when writing. On failure it returns Nothing. +readState :: (Persistent a, Typeable a) => RootLocation -> IO (Maybe (PState a)) +readState l@(RootLocation f rootAddrs) = + fmap (\r -> let rs = rootScan $ toOnlyRev r in PState l (bookSpace $ incr persister rs $ deref $ rootCS rs) r) . + maybeMaximumBy (comparing $ rootId . toOnlyRev) . catMaybes <$> sequence (readRoot f <$> rootAddrs) + +-- | Create an empty cache of the specified size (number of dereferenced DRefs). +-- Note that eventually we would like a cache with a size measured in bytes, for a better prediction of memory consumption. +emptyCache :: Integer -> Cache +emptyCache sz = LRU.fromList (Just sz) [] + +-- | We reserve the option of growing roots to 1MB, so use this as a minimum distance between the various RootAddress in RootLocation +rootAllocSize :: Len Word64 Word32 +rootAllocSize = coarsenLen (unsafeLen (1024 * 1024) :: Len Word8 Word32) + +-- For now, asyncWriteState should be used synchronously (with await0) because we have no flow control on the StoreFile. +asyncWriteState :: (Persistent a, Typeable a) => a -> PState a -> IO () -> IO (PState a) +asyncWriteState a rs = + (if rootId (toOnlyRev $ stateRoot rs) `mod` collectFrequency == 0 then \w k -> collectState rs >>= ($ k) . w else ($ rs)) $ + \(PState l s rvers) -> case toOnlyRev rvers of (Root i d (RootValues rcs _)) -> + writeRootSimple l s $ Current $ Root (succ i) d $ RootValues rcs $ ref a + +collectFrequency :: StateId +collectFrequency = 1000 + +writeRootSimple :: forall a. (Persistent a, Typeable a) => RootLocation -> SpaceTree -> RootVersions a -> IO () -> IO (PState a) +writeRootSimple l@(RootLocation f _) s r done = + fmap (\(r', _ :: MapMultiset Address, s') -> PState l s' r') $ -- We may want to rewrite 'write' so it does not produce counts, and drop the Multiset c context + writeRoot (rootId $ toOnlyRev r) l done $ write f s r + +-- | Takes the current state and the new value to be written, and writes and returns a new state. Writing is strict so make sure you do +-- not have cycles in the value to be written. After writing, you should no longer use the value you passed in, but instead use the +-- equivalent value present in the in the returned state. That new equivalent value knows where it is stored and will be lazily loadable. +-- The value just written will be partially or totally in the cache. IMPORTANT: This call overwrites the value that was in the state +-- passed as input, so you should not use it after this call returns. However it is safe for this call to use it implicitly, because often +-- the new value will be a function of the old one, and the strict write process will force parts of the old value to be read. If +-- by accident you do use a value which was overwritten, its digests will be incorrect (with very high probability) and deref will return error. +-- This calls collectState implicity once every 1000 calls. We will make this optional in future revisions. +writeState :: (Persistent a, Typeable a) => a -> PState a -> IO (PState a) +writeState a r = await0 $ asyncWriteState a r + +-- | Writes a new state if the passed state change requires it. The StateT monad used here is like the usual StateT monad but +-- it has an additional 'unchanged' case which allow us to avoid needless writes. +updateState :: (Persistent a, Typeable a, MonadIO m) => M.StateT a m b -> M.StateT (PState a) m b +updateState = updateStateRead . M.mapStateT lift + +-- | Like updateState but the updater has access to the input PState throught an additional ReaderT +updateStateRead :: (Persistent a, Typeable a, MonadIO m) => M.StateT a (ReaderT (PState a) m) b -> M.StateT (PState a) m b +updateStateRead (M.StateT u) = + M.StateT $ \t -> runReaderT (u (deref $ rootValue $ rootScan $ toOnlyRev $ stateRoot t)) t + >>= \(b, ma') -> liftM (b,) $ maybe (return Nothing) (liftM Just . liftIO . flip writeState t) ma' + +-- collectState could overlap some of its work with normal writes. It could increment the latest state it sees when it starts, then decrement the old +-- state, and finally do an atomic update of the state, rereading it to integreate any new states which have been added in the mean time. But we +-- leave that for later. +asyncCollectState :: (Persistent a, Typeable a) => PState a -> IO () -> IO (PState a) +asyncCollectState (PState l _ rvers) done = -- we ignore s + let rcs'@(SpaceBook _ s') = incr persister d' $ deref rcs + (Root i md d'@(RootValues rcs ra)) = toOnlyRev rvers + in writeRootSimple l s' (Current $ Root (succ i) (Just d') $ RootValues (ref $ decr persister md rcs') ra) done + -- we write s'' but we do not use it, it will be used on next collectState + -- s'' contains memory we just freed. We cannot reuse it immediately in writing the new state in case we crash in the process. + +-- | Collects the garbage accumulated by the calls to writeState. Uses reference counting: first does an increment pass on +-- the current value, and then does a decrement pass on the value that was present at the last collection. Only new allocations are +-- scanned in the increment pass, not what was already allocated at the last collection. The decrement pass only traverses +-- the allocations that need to be deallocated. +collectState :: (Persistent a, Typeable a) => PState a -> IO (PState a) +collectState r = await0 $ asyncCollectState r + +collectStateM :: (Persistent a, Typeable a) => M.StateT (PState a) IO () +collectStateM = get >>= lift . collectState >>= put + +--------------- + +writeRoot :: StateId -> RootLocation -> IO () -> StateT (ABitSeq RealWorld) IO a -> IO a +writeRoot i (RootLocation (CachedFile f _) roots) done writer = do + start <- stToIO mkABitSeq + (result, end) <- runStateT writer start + {-# SCC "barrier" #-} storeFileFullBarrier f -- If the following write completes, we want to assume that all preceeding writes completed + arr <- allocCopyBits start end + onWordConv (writeRoot' (apply wordConv1 arr :: PrimArray Pinned Word32)) (writeRoot' (apply wordConv1 arr :: PrimArray Pinned Word64)) + -- We would like a full barrier here, to make sure reads do not move before matching writes, there is one just before, + -- and the precedeeing write is protected by the following sync (and will never be read) + {-# SCC "sync" #-} storeFileSync f done -- We need to know when the transaction has become durable + -- No barrier here, however that does not help much since we have a barrier before the preceeding write + return result where + writeRoot' :: forall w. (LgMultiple Word64 w, ValidationDigestWord w) => PrimArray Pinned w -> IO () + writeRoot' arr = {-# SCC "writeRoot" #-} do + let (RootValidator, bufs) = mkValidationInput arr + when (sum (arrayLen <$> bufs) > apply super (refineLen rootAllocSize :: Len w Word32)) $ error "Root too large." + () <$ storeFileWrite f (getRootAddress $ genericIndex roots $ mod i $ fromIntegral $ length roots) platformWordEndianness bufs + +-- No need for barrier after write root. If the root writing is delayed +-- past later writes which are starting to write the next state, we should already be garanteed that the new writes are not +-- overwriting the allocations of the previous state, otherwise the system would not be resumable after a crash. + +write :: (Multiset c, Persistent a', Space ls) => + CachedFile -> ls -> a' -> StateT (ABitSeq RealWorld) IO (a', c Address, ls) +write (CachedFile f c) ls a' = {-# SCC "serialize" #-} StateT $ \s -> do + cd <- newMVar emptySet + lv <- newMVar ls + cSer persister (c, StateAllocator f lv, Just cd) (\a'' s' -> readMVar lv >>= \ls' -> readMVar cd >>= \u -> return ((a'', u, ls'), s')) a' s + +readRoot :: forall a d f. (Persistent a, Typeable a) => CachedFile -> RootAddress -> IO (Maybe (RootVersions a)) +readRoot (CachedFile f c) rootAddr = + fmap (deserializeFromFullArray $ apply cDeser persister $ DeserializerContext f c) <$> + foldM (\result next -> maybe next (return . Just) result) Nothing readRootDataWE where + readRootData :: forall w. ValidationDigestWord w => Endianness -> Tagged w (IO (Maybe (ArrayRange (PrimArray Free Word)))) + readRootData e = tag $ fmap (fmap deserInput) $ await1 $ + storeFileRead f (rootRef rootAddr) e (RootValidator :: RootValidator w) + readRootDataW e = onWordConv id reverse [(at :: At Word32) $ readRootData e, (at :: At Word64) $ readRootData e] + readRootDataWE = concat $ transpose $ readRootDataW <$> [platformWordEndianness, reverseEndianness platformWordEndianness] + +--------------- + +data StateAllocator a = StateAllocator ReplicatedFile (MVar a) + +instance Space a => Allocator (StateAllocator a) where + allocatorStoreFile (StateAllocator f _) = f + alloc (StateAllocator _ var) len = modifyMVar var $ \a -> do + let span = requireSpan a + let a' = removeSpan span a + --putStrLn $ "Alloc " ++ show size ++ "@" ++ show (onSortedPair const span) ++ " => free: " ++ (show a') --findSpan 0 a' + return (a', onSortedPair (\start end -> unsafeLen start) span) where + requireSpan = onSortedPair (\start _ -> unsafeSortedPair start (start + getLen len)) . + fromMaybe (error "Out of storage space") . listHead . + findSpan (getLen len) + +deriveStructured ''Root +deriveStructured ''RootValues diff --git a/src/Database/Perdure/StoreFile.hs b/src/Database/Perdure/StoreFile.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/StoreFile.hs @@ -0,0 +1,64 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE ExistentialQuantification, TypeFamilies, FlexibleContexts, TemplateHaskell, ScopedTypeVariables #-} + +module Database.Perdure.StoreFile ( + StoreFile(..), + SyncableStoreFile(..), + await0, + await1, + refSpan, + Word64, + BasicRef(..), + module Foreign.Ptr, + module Cgm.Data.Len, + module Validator +) where + +import Prelude () +import Cgm.Prelude +import Data.Word +import Data.ByteString +import Foreign.Ptr +import Cgm.Data.Len +import Cgm.Data.Super +import Cgm.Control.Concurrent.Await +import Database.Perdure.Validator as Validator +import Cgm.System.Endian +import Cgm.Data.Structured +import Database.Perdure.Space + +class SyncableStoreFile f => StoreFile f where + type StoreRef f :: * -> * + -- | + storeFileWrite :: Endian w => f -> Len Word64 Word64 -> Endianness -> [PrimArray Pinned w] -> IO (StoreRef f w) + storeFileRead :: (Validator v, ValidatedElem v ~ w, Endian w, LgMultiple w Word8) => + f -> StoreRef f w -> Endianness -> v -> Async (Maybe (ArrayRange (PrimArray Pinned w))) () + +class SyncableStoreFile f where + -- | Notify when all preceeding writes have completed, implies no barrier + storeFileSync :: f -> IO () -> IO () + -- | Prevent the reordering of preceeding and subsequent read and write operations + storeFileFullBarrier :: f -> IO () + +--------------------------------------------------------------------------- + +data BasicRef w = BasicRef { + refStart :: {-# UNPACK #-} !(Len Word64 Word64), + refSize :: {-# UNPACK #-} !(Len w Word32)} + +refSpan :: forall w. LgMultiple Word64 w => BasicRef w -> Span +refSpan (BasicRef addr sz) = unsafeSortedPair (getLen addr) $ getLen $ (+ addr) $ coarsenLen (apply super sz :: Len w Word64) + +deriveStructured ''BasicRef diff --git a/src/Database/Perdure/Validator.hs b/src/Database/Perdure/Validator.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/Validator.hs @@ -0,0 +1,48 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies, TupleSections #-} + +module Database.Perdure.Validator ( + Validator(..), + Validator0(..), + module Cgm.Data.Array + ) where + +import Prelude () +import Cgm.Prelude +import Cgm.Data.Word +import Cgm.Data.Array + +-- Although most hash functions are defined on strings of byte as a convention, they often start by converting the plaintext to strings +-- of 32 or 64 bit words. They may do the reverse with the output. We will restrict ourselves to such hash functions (stripped of their +-- intial and final byte conversions) so that we may apply them with equal efficiency, and identical results, on either big-endian or +-- little-endian platforms. The buffers we hash are made up of 32bit or 64bit words. This also allows for a clean design where byte conversion +-- (when needed due to the interoperation of systems of different endianness) occurs after hashing when writing, and before +-- hashing when reading. We do not have readily available implementations of the hash functions with the byte conversion layer stripped, so +-- we will use a (64-bit) hash function with a little endian byte-conversion layer (such as tiger of skein-512 from +-- http://hackage.haskell.org/package/cryptohash-0.6.2), and add an additional byte-swap layers when we are on big-endian machines. +-- When we have time we can optimize big-endian machines by reworking the code of the library. For 32 bit platforms we will +-- use a 32 bit optimized hash algorithm, with a digest of the same size. When reading we will need to know both the endianness +-- in which the data was written, but also the word size (and thus the hash algorithm) of the written data. + +class Validator v where + type ValidatedElem v + mkValidationInput :: PrimArray Pinned (ValidatedElem v) -> (v, [PrimArray Pinned (ValidatedElem v)]) -- TODO generalize to ArrayRange + validate :: Prim (ValidatedElem v) => v -> ArrayRange (PrimArray Pinned (ValidatedElem v)) -> Maybe (ArrayRange (PrimArray Pinned (ValidatedElem v))) + +data Validator0 w = Validator0 +instance Validator (Validator0 w) where + type ValidatedElem (Validator0 w) = w + mkValidationInput = (Validator0, ) . pure + validate Validator0 = Just diff --git a/src/Database/Perdure/WValidator.hs b/src/Database/Perdure/WValidator.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/WValidator.hs @@ -0,0 +1,47 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE TemplateHaskell, FlexibleContexts, TypeFamilies, TupleSections, ScopedTypeVariables, FlexibleInstances #-} + +module Database.Perdure.WValidator ( + W32Validator, + W64Validator, + module Database.Perdure.Validator + ) where + +import Prelude () +import Cgm.Prelude +import Data.Word +import Cgm.Data.Word +import Cgm.Data.Len +import Database.Perdure.Digest +import Database.Perdure.Validator +import Cgm.System.Endian +import Cgm.Data.Maybe +import Cgm.Data.Structured + +data W32Validator = W32Validator {-# UNPACK #-} !MD5Digest deriving (Eq, Show) +data W64Validator = W64Validator {-# UNPACK #-} !(Skein512Digest Word128) deriving (Eq, Show) + +instance Validator W32Validator where + type ValidatedElem W32Validator = Word32 + mkValidationInput b = (W32Validator $ digest b, pure b) + validate (W32Validator h) b = b `justIf` (digest b == h) + +instance Validator W64Validator where + type ValidatedElem W64Validator = Word64 + mkValidationInput b = (W64Validator $ digest b, pure b) + validate (W64Validator h) b = b `justIf` (digest b == h) + +deriveStructured ''W32Validator +deriveStructured ''W64Validator diff --git a/src/Database/Perdure/WordArrayRef.hs b/src/Database/Perdure/WordArrayRef.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/WordArrayRef.hs @@ -0,0 +1,43 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE FlexibleContexts, TypeFamilies #-} + +module Database.Perdure.WordArrayRef ( + WordArrayRef(..) + ) where + +import Prelude() +import Cgm.Prelude +import Cgm.Data.Word +import Database.Perdure.ArrayRef +import Database.Perdure.CDeserializer +import Database.Perdure.Persistent + +-- | When we write Words and read them back on a platform with a different Word size, the array length changes, +-- and each Word64 is replaced by two consecutive Words32 (least-significant first), (the reverse substitution is applied +-- when going from Word32 to Word64, with an implicit 0 at the end when the size is odd) + +instance (ArrayRef r32, ArrayRef r64, ArrayRefElem r32 ~ Word32, ArrayRefElem r64 ~ Word64) => ArrayRef (WordArrayRef r32 r64) where + type ArrayRefElem (WordArrayRef r32 r64) = Word + writeArrayRef l b = onWordConv + (Word32ArrayRef <$> writeArrayRef l (apply wordConv1 b)) + (Word64ArrayRef <$> writeArrayRef l (apply wordConv1 b)) + derefArrayRef f (Word32ArrayRef r) = fmap deserInput <$> derefPinnedArrayRef f r + derefArrayRef f (Word64ArrayRef r) = fmap deserInput <$> derefPinnedArrayRef f r + arrayRefAddr (Word32ArrayRef r) = arrayRefAddr r + arrayRefAddr (Word64ArrayRef r) = arrayRefAddr r + +derefPinnedArrayRef :: (ArrayRef r, StoreFile f) => f -> r (StoreRef f) -> IO (Maybe (ArrayRange (PrimArray Pinned (ArrayRefElem r)))) +derefPinnedArrayRef = derefArrayRef + diff --git a/src/Database/Perdure/WordNArrayRef.hs b/src/Database/Perdure/WordNArrayRef.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/WordNArrayRef.hs @@ -0,0 +1,42 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE FlexibleContexts, TypeFamilies #-} + +module Database.Perdure.WordNArrayRef ( + WordNArrayRef(..), + WordNValidator, + module Database.Perdure.ArrayRef + ) where + +import Prelude() +import Cgm.Prelude +import Database.Perdure.ArrayRef +import Database.Perdure.Persistent +import Cgm.Data.Word +import Cgm.System.Endian +import Database.Perdure.WValidator + +class (Validator v, Persistent v, LgMultiple Word64 (ValidatedElem v), Endian (ValidatedElem v), LgMultiple (ValidatedElem v) Word8) => WordNValidator v +instance WordNValidator W32Validator +instance WordNValidator W64Validator + +instance WordNValidator v => ArrayRef (WordNArrayRef v) where + type ArrayRefElem (WordNArrayRef v) = ValidatedElem v + writeArrayRef l b = do + let (v, buf) = mkValidationInput b + r <- allocWrite l platformWordEndianness buf + return $ WordNArrayRef v r platformWordEndianness + derefArrayRef f (WordNArrayRef v r e) = fmap primArrayMatchAllocation <$> await1 (storeFileRead f r e v) + arrayRefAddr (WordNArrayRef _ r _) = refStart r + diff --git a/src/Database/Perdure/WriteBits.hs b/src/Database/Perdure/WriteBits.hs new file mode 100644 --- /dev/null +++ b/src/Database/Perdure/WriteBits.hs @@ -0,0 +1,221 @@ +{- +Copyright 2010-2012 Cognimeta Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in +compliance with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is +distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express +or implied. See the License for the specific language governing permissions and limitations under the License. +-} + +{-# LANGUAGE ScopedTypeVariables, UnboxedTuples, BangPatterns, MagicHash, FlexibleInstances, TupleSections, TypeFamilies, FlexibleContexts, UndecidableInstances #-} + +-- Command line used to see simplified Core (from /src dir) +-- ghc-7.0.1 -fforce-recomp --make -O2 Cgm/Persist/WriteBits.hs -ddump-simpl -dppr-user-length=130 > b.hcr +-- Notes on status: despite wordSeqAdd being inlined, the simplifier does not automatically create versions +-- of writeBits functions that take the real-world, and return the real world as an additional element in the +-- returned unboxed tuple. It still return an IO in the returned unboxed tuple. Will we need to do this manually ? +-- Will subsequent optimization take care of that? Probably not since the IO monad is lazy. + +module Database.Perdure.WriteBits ( + STSrcDest(..), + WordDest(..), + BitDest(..), + BitSrc(..), + WordSrc(..), + aligned, + padIncompleteWord, + WordSeq, + mkWordSeq, + CWordSeq(..), + BitAcc(..), + bitAccWordDest, + BSer, + ABitSeq, + mkABitSeq, + module Cgm.Data.Array + ) where + +import Debug.Trace +import Foreign.Ptr +import Data.Bits +import Control.Applicative +import Control.Monad +import Control.Monad.Identity +import Foreign.Storable +import Foreign.Marshal.Alloc +import Foreign.Marshal.Array +import Cgm.Data.Array +import Cgm.Data.Word +import Cgm.Data.Len +import Cgm.Data.WordN +import Cgm.System.Mem.Alloc +import Cgm.Control.Combinators + + +------------------------- classes WordDest, BitDest, BitSrc and WordSrc ------------------------- + +class STSrcDest d where + type SrcDestState d +type SrcDestST d = ST (SrcDestState d) + +class STSrcDest d => WordDest d where + addWord :: Word -> d -> SrcDestST d d + +class WordDest d => BitDest d where + addBit :: Word -> d -> SrcDestST d d -- 0 <= w <= 1 + addBits :: Len Bool Word -> Word -> d -> SrcDestST d d -- 0 <= n <= wordBits, w < 2^n + +class STSrcDest d => BitSrc d where + addedBits :: d -> d -> Len Bool Word + copyBits :: (BitDest d', SrcDestST d ~ SrcDestST d') => d -> d -> d' -> SrcDestST d d' + -- ^ Copies all bits between an end and a start (of type d) to a destination + +class BitSrc d => WordSrc d where + addedWords :: d -> d -> Len Word Word + copyWords :: (WordDest d', SrcDestST d ~ SrcDestST d') => d -> d -> d' -> SrcDestST d d' + -- ^ Copies all words between an end and a start (of type d) to a destination + copyWordsPartial :: (BitDest d', SrcDestST d ~ SrcDestST d') => d -> d -> Len Bool Word -> d' -> SrcDestST d d' + -- ^ Like copyWords, but excludes some lower bits [0, wordSize[ from the first Word + +------------------------- Ptr ------------------------- + +instance STSrcDest (Ptr Word) where type SrcDestState (Ptr Word) = RealWorld +instance WordDest (Ptr Word) where + {-# INLINE addWord #-} + addWord w ptr = ioToST $ advancePtr ptr 1 <$ poke ptr w +instance BitSrc (Ptr Word) where + addedBits = refineLen ./ addedWords + copyBits = copyWords +instance WordSrc (Ptr Word) where + addedWords = (apply unsigned <$>) ./ minusPtrLen + copyWords end start d = if end == start then return d else ioToST (peek start) >>= \w -> addWord w d >>= copyWords end (start `advancePtrLen` 1) + copyWordsPartial end start dropLow = + let len = addedWords end start + in if len == 0 + then undefined + else (\d -> ioToST (peek start) >>= \w -> + addBits (refineLen word - dropLow) (w `partialShiftRL` getLen dropLow) d) >=> copyWords end (start `advancePtrLen` 1) + +------------------------- WordSeq ------------------------- + +-- With WordSeq we allocate memory as we go, so we do not need a size bound ahead of time. +-- Here the least significant bits of the words are bits that were added before. +-- 0 <= index < chunkSize +data WordSeq s f = WordSeq !(Len Word Word, [STPrimArray s f Word]) {-# UNPACK #-} !(CWordSeq s f) + +chunkSize :: Len Word Word +chunkSize = unsafeLen 2048 + +{-# INLINE pushAnyFullChunk #-} +pushAnyFullChunk :: STMkArray (STPrimArray s f Word) => WordSeq s f -> ST s (WordSeq s f) +pushAnyFullChunk s@(WordSeq (l, r) (CWordSeq a ix)) = + if ix < chunkSize then return s else WordSeq (l + chunkSize, a : r) . (`CWordSeq` 0) <$> mkArray chunkSize + +mkWordSeq :: STMkArray (STPrimArray s f Word) => ST s (WordSeq s f) +mkWordSeq = WordSeq (0, []) . (`CWordSeq` 0) <$> mkArray chunkSize + +instance STSrcDest (WordSeq s f) where type SrcDestState (WordSeq s f) = s +instance STMkArray (STPrimArray s f Word) => WordDest (WordSeq s f) where + {-# INLINE addWord #-} + addWord w (WordSeq r c) = (WordSeq r <$> addWord w c) >>= pushAnyFullChunk +instance BitSrc (WordSeq s f) where + addedBits = refineLen ./ addedWords + copyBits = copyWords +instance WordSrc (WordSeq s f) where + addedWords (WordSeq (s1, _) c1) (WordSeq (s0, _) c0) = addedWords c1 c0 + (s1 - s0) + copyWords (WordSeq (s1, r1) c1) start@(WordSeq (s0, _) c0) = + if s1 == s0 + then copyWords c1 c0 + else copyWords (WordSeq (s1 - chunkSize, tail r1) $ chunkEnd (head r1)) start >=> copyWords c1 (chunkStart c1) + copyWordsPartial (WordSeq (s1, r1) c1) start@(WordSeq (s0, _) c0) = + if s1 == s0 + then copyWordsPartial c1 c0 + else \drop -> copyWordsPartial (WordSeq (s1 - chunkSize, tail r1) $ chunkEnd (head r1)) start drop >=> copyWords c1 (chunkStart c1) + +chunkStart (CWordSeq a i) = CWordSeq a 0 +chunkEnd a = CWordSeq a chunkSize + +------------------------- CWordSeq ------------------------- + +-- Like WordSeq, but all words are contiguous, so the sequence cannot grow. No boundary check is performed. The initial allocation must be sufficient. +data CWordSeq s f = CWordSeq {-# UNPACK #-} !(STPrimArray s f Word) {-# UNPACK #-} !(Len Word Word) + +instance STSrcDest (CWordSeq s f) where type SrcDestState (CWordSeq s f) = s +instance WordDest (CWordSeq s f) where + {-# INLINE addWord #-} + addWord w (CWordSeq arr ix) = CWordSeq arr (ix + 1) <$ writeArray arr ix w +instance BitSrc (CWordSeq s f) where + addedBits = refineLen ./ addedWords + copyBits = copyWords +instance WordSrc (CWordSeq s f) where + addedWords (CWordSeq _ n1) (CWordSeq _ n0) = n1 - n0 + copyWords end@(CWordSeq a i1) (CWordSeq _ i0) d = + if i1 == i0 then return d else readArray a i0 >>= flip addWord d >>= copyWords end (CWordSeq a $ i0 + 1) + copyWordsPartial end@(CWordSeq a i1) (CWordSeq _ i0) dropLow d = + if i1 == i0 then undefined + else do + w <- readArray a i0 + addBits (refineLen word - dropLow) (w `partialShiftRL` getLen dropLow) d >>= copyWords end (CWordSeq a $ i0 + 1) + +------------------------- BitAcc ------------------------- + +-- Invariant : 0 <= b < wordBits, w < 2^b +data BitAcc d = BitAcc {-# UNPACK #-} !Word {-# UNPACK #-} !Word d + +type BSer d = BitAcc d -> SrcDestST (BitAcc d) (BitAcc d) + +{-# INLINE onAlignment #-} +onAlignment :: (d -> z) -> (BitAcc d -> z) -> BitAcc d -> z +onAlignment a u bd@(BitAcc b _ d) = if b == 0 then a d else u bd + +aligned :: d -> BitAcc d +aligned = BitAcc 0 0 + +bitAccWordDest :: BitAcc d -> d +bitAccWordDest (BitAcc _ _ d) = d + +padIncompleteWord :: WordDest d => BitAcc d -> SrcDestST d d +padIncompleteWord = onAlignment return (\(BitAcc _ acc d) -> addWord acc d) + +instance STSrcDest d => STSrcDest (BitAcc d) where type SrcDestState (BitAcc d) = SrcDestState d +instance WordDest d => WordDest (BitAcc d) where + {-# SPECIALIZE INLINE addWord :: Word -> BSer (WordSeq RealWorld Free) #-} + {-# SPECIALIZE INLINE addWord :: Word -> BSer (Ptr Word) #-} + addWord !w (BitAcc b acc d) = BitAcc b (if b == 0 then 0 else partialShiftRL w (wordBits - b)) <$> addWord (acc + partialShiftL w b) d + +instance WordDest d => BitDest (BitAcc d) where + {-# SPECIALIZE INLINE addBits :: Len Bool Word -> Word -> BSer (WordSeq s Free) #-} + {-# SPECIALIZE INLINE addBits :: Len Bool Word -> Word -> BSer (Ptr Word) #-} + addBits n !w (BitAcc b acc d) = let + !acc' = acc + partialShiftL w b + b' = b + getLen n + b'' = b' - wordBits + in if (signed $* b'') < 0 + then return $ BitAcc b' acc' d + else let + !fullShift = getLen n == wordBits && b == 0 + in if fullShift then aligned <$> addWord acc' d else BitAcc b'' (partialShiftRL w (getLen n - b'')) <$> addWord acc' d + {-# SPECIALIZE INLINE addBit :: Word -> BSer (WordSeq s Free) #-} + {-# SPECIALIZE INLINE addBit :: Word -> BSer (Ptr Word) #-} + addBit !w (BitAcc b acc d) = let + acc' = acc + partialShiftL w b + b' = b + 1 + b'' = b' - wordBits + in if (signed $* b'') < 0 + then return $ BitAcc b' acc' d + else aligned <$> addWord acc' d +instance WordSrc d => BitSrc (BitAcc d) where + copyBits (BitAcc endB endAcc end) (BitAcc startB _ start) = + if addedWords end start == 0 + then addBits (unsafeLen $ endB - startB) (endAcc `partialShiftRL` startB) + else copyWordsPartial end start (unsafeLen startB) >=> addBits (unsafeLen endB) endAcc + addedBits (BitAcc b1 _ d1) (BitAcc b0 _ d0) = refineLen (addedWords d1 d0) + unsafeLen (b1 - b0) + + +type ABitSeq s = BitAcc (WordSeq s Free) +mkABitSeq :: ST s (ABitSeq s) +mkABitSeq = aligned <$> mkWordSeq