diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Patrick Maier, Rob Stewart, 2012 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the names of the copyright holders nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,32 @@ +The Explicit Closures of Haskell Distributed Parallel Haskell +============================================================= + +**Haskell distributed parallel Haskell (HdpH)** is a Haskell DSL for +parallel computation on distributed-memory architectures. HdpH is +implemented entirely in Haskell but does make use of a few GHC extensions, +most notably TemplateHaskell. + +HpdH uses _explicit closures_ to communicate serialised thunks across +the network. +This package exports the fully polymorphic explicit closure representation +of HdpH, for use by HdpH or other packages. + +HdpH, including the explicit closure representation, is described in some detail in the paper [Implementing a High-level Distributed-Memory Parallel Haskell in Haskell](http://www.macs.hw.ac.uk/~pm175/papers/Maier_Trinder_IFL2011_XT.pdf). + +This release is considered alpha stage. + + +Building HdpH explicit closure support +-------------------------------------- + +Should be straightforward from the cabalised package `hdph-closure`. + + +References +---------- + +1. Patrick Maier, Phil Trinder. + [Implementing a High-level Distributed-Memory Parallel Haskell in Haskell](http://www.macs.hw.ac.uk/~pm175/papers/Maier_Trinder_IFL2011_XT.pdf). + Proc. 2011 Symposium on Implementation and Application of Functional Languages (IFL 2011), Springer LNCS 7257, pp. 35-50. + +2. [HdpH development repository](https://github.com/PatrickMaier/HdpH) on github. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/TODO.md b/TODO.md new file mode 100644 --- /dev/null +++ b/TODO.md @@ -0,0 +1,23 @@ +The Explicit Closures of Haskell Distributed Parallel Haskell +============================================================= + +To Do List +---------- + +* Clean up build. + + * Add `-Wall` switch to cabal file. + +* Improve documentation. + + * Make documentation self-contained; omitting references to package `hdph`. + * Add self-contained example programs. + +* Generate instance declarations for classes like 'ToClosure' via Template + Haskell. This would avoid the risk of programmers accidentally specifying + recusive instances. + +* Support serialisation via `Data.Binary` in addition (or instead of?) + `Data.Serialize`. + +* Finally: Implement proper compiler support for `Static`. diff --git a/hdph-closure.cabal b/hdph-closure.cabal new file mode 100644 --- /dev/null +++ b/hdph-closure.cabal @@ -0,0 +1,33 @@ +name: hdph-closure +version: 0.0.1 +synopsis: Explicit closures in Haskell distributed parallel Haskell +description: Explicit closures are serialisable representations of thunks. + This package exports the fully polymorphic explicit closures + of HdpH (Haskell distributed parallel Haskell), for use + by HdpH or other packages. +homepage: https://github.com/PatrickMaier/HdpH +license: BSD3 +license-file: LICENSE +author: Patrick Maier +maintainer: Patrick Maier +stability: experimental +category: Control, Distributed Computing +tested-with: GHC == 7.4.1 || == 7.6.2 +build-type: Simple +cabal-version: >= 1.8 + +Library + exposed-modules: Control.Parallel.HdpH.Closure + other-modules: Control.Parallel.HdpH.Closure.Internal, + Control.Parallel.HdpH.Closure.Static, + Control.Parallel.HdpH.Closure.Static.State, + Control.Parallel.HdpH.Closure.Static.Type + build-depends: template-haskell, + array >= 0.1 && < 0.5, + base >= 4 && < 5, + cereal >= 0.3.3 && < 0.4, + bytestring == 0.10.*, + containers >= 0.1 && < 0.6, + deepseq >= 1.1 && < 2 + hs-source-dirs: src + ghc-options: diff --git a/src/Control/Parallel/HdpH/Closure.hs b/src/Control/Parallel/HdpH/Closure.hs new file mode 100644 --- /dev/null +++ b/src/Control/Parallel/HdpH/Closure.hs @@ -0,0 +1,642 @@ +-- This module implements /explicit closures/ as described in [2] below. +-- It makes extensive use of Template Haskell, and due to TH's stage +-- restrictions, internals like the actual closure representation are +-- delegated to module 'Control.Parallel.HdpH.Closure.Internal'. +-- +-- Author: Patrick Maier +----------------------------------------------------------------------------- + +-- | Explicit Closures, inspired by [1] and refined by [2]. +-- +-- References: +-- +-- (1) Epstein, Black, Peyton-Jones. /Towards Haskell in the Cloud/. +-- Haskell Symposium 2011. +-- +-- (2) Maier, Trinder. /Implementing a High-level Distributed-Memory/ +-- /Parallel Haskell in Haskell/. IFL 2011. +-- + +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Control.Parallel.HdpH.Closure + ( -- * Explicit Closures + -- ** Key facts + -- $KeyFacts + + -- ** The Closure type constructor + Closure, + + -- ** Caveat: Deserialisation is not type safe + -- $Deserialisation + + -- ** Closure elimination + unClosure, + + -- ** Forcing Closures + forceClosure, + + -- ** Categorical operations on function Closures + -- | A /function Closure/ is a Closure of type @'Closure' (a -> b)@. + idC, + termC, + compC, + apC, + + -- ** Construction of value Closures + -- | A /value Closure/ is a Closure, which when eliminated (from its + -- serialisable representation, at least) yields an evaluated value + -- (rather than an unevaluated thunk). + toClosure, + ToClosure( + locToClosure + ), + StaticToClosure, + staticToClosure, + + -- ** Safe Closure construction + mkClosure, + mkClosureLoc, + LocT, + here, + + -- ** Unsafe Closure construction + unsafeMkClosure, + + -- * Static terms + -- | A term @t@ is called /static/ if it could be declared at the toplevel. + -- That is, @t@ is static if all free variables occuring in @t@ are + -- toplevel. + + -- ** The Static type constructor + Static, + + -- ** Static declaration and registration + StaticDecl, + declare, + register, + showStaticTable, + + -- ** Static deserialisers + -- | A @'Static'@ /environment deserialiser/ is a term of type + -- @'Static' ('Env' -> a)@, for some type @a@, and is part + -- of the serialisable representation of an explicit Closure. + static, + static_, + staticLoc, + staticLoc_, + + -- * Serialised environment + -- | A /serialised enviroment/ is part of the serialisable representation + -- of an explicit Closure. + Env, + encodeEnv, + decodeEnv, + + -- * This module's Static declaration + declareStatic + + -- * Tutorial on safe Closure construction + -- $Tutorial + ) where + +import Prelude +import Control.DeepSeq (NFData, deepseq) +import Data.Monoid (mconcat) +import Data.Serialize (Serialize) + +import Control.Parallel.HdpH.Closure.Internal -- re-export whole module +import Control.Parallel.HdpH.Closure.Static + (Static, StaticDecl, declare, register, showStaticTable) + + +----------------------------------------------------------------------------- +-- $KeyFacts +-- +-- An /explicit Closure/ is a term of type @Closure t@, wrapping a thunk +-- of type @t@. Henceforth, we will write /Closure/ (capitalised) to mean +-- an explicit Closure, and /closure/ (in lower case) to mean an ordinary +-- Haskell closure (ie. a thunk). +-- +-- The @'Closure'@ type constructor is abstract (see reference [2] or +-- module 'Control.Parallel.HdpH.Closure.Internal' for its internal /dual/ +-- representation). +-- +-- The function @'unClosure'@ returns the thunk wrapped in a Closure. +-- +-- The function @'unsafeMkClosure'@ constructs Closures but is considered +-- /unsafe/ because it exposes the internal dual representation, and +-- relies on the programmer to guarantee consistency. +-- +-- Article [2] proposes a /safe/ Closure construction @$(mkClosure [|...|])@ +-- where the @...@ is an arbitrary thunk. Due to current limitations of the +-- GHC (namely missing support for the @'Static'@ type constructor), +-- this module provides only limited variants of @$(mkClosure [|...|])@. +-- The restrictions on the the thunk @...@ are +-- +-- * either @...@ is a toplevel variable (also called a /static closure/), +-- +-- * or @...@ is a toplevel variable (also called a /closure abstraction/) +-- applied to a tuple of local variables. +-- +-- As a matter of nomenclature, functions operating on Closures will either +-- contain the string @Closure@ (like @'unClosure'@ and @'mkClosure'@) or will +-- end in the suffix @C@ (like the categorical operations @'idC'@ and +-- @'compC'@). +-- +-- Some identities involving Closures: +-- +-- (1) @unClosure $ unsafeMkClosure x fun env = x@ +-- +-- (2) @unClosure $ toClosure x = x@ +-- +-- (3) @unClosure $(mkClosure [| stat_clo |]) = stat_clo@ +-- +-- (4) @unClosure $(mkClosure [| clo_abs free_vars |]) = clo_abs free_vars@ +-- + + +----------------------------------------------------------------------------- +-- $Deserialisation +-- +-- Deserialising a serialised value via the methods of class +-- @'Data.Binary.Binary'@ (or @'Data.Serialize.Serialize'@) is not type safe. +-- For instance, the compiler will happily assign type @Int -> Bool@ to +-- +-- > decodeBool . encodeInt where +-- > decodeBool = decode :: ByteString -> Bool +-- > encodeInt = encode :: Int -> ByteString +-- +-- This type coercion will only fail at runtime, when (and if) the decoder for +-- @Bool@ stumbles over unexepected input values. Hence deserialising can be +-- viewed as an assertion that the serialised byte string represents a value +-- of the type @decode@ expects to see. A well-written decoder will check +-- this assertion on deserialisation, and will abort with an error message +-- if the assertion fails. +-- +-- HdpH treats Closure deserialisation similarly as an assertion that the +-- serialised byte string represents a value of the expected Closure type. +-- However, HdpH does not check whether the assertion holds. Instead it +-- subverts the type system via @unsafeCoerce@, with potentially disastrous +-- consequences (like seg faults) in cases where the assertion fails. +-- +-- The up side of this design choice is a simpler Closure representation +-- without runtime type reflection. +-- The down side is that Closure deserialisation has to be treated with +-- /extreme care/. +-- HdpH, for instance, avoids the pitfalls of Closure deserialisation by +-- making sure only Closures of the fixed type @Closure (Par ())@ are +-- serialised and deserialised. + + +----------------------------------------------------------------------------- +-- $Tutorial +-- +-- This guide will demonstrate the safe construction of explicit Closures +-- in HdpH through a series of examples. +-- +-- +-- [Constructing plain Closures] +-- +-- The first example is the definition of the Closure transformation +-- @apC@. It is defined in [2] (where it is called @mapClosure@) by eliminating +-- the Closures of its arguments, and constructing a new Closure of the the +-- resulting application, as follows: +-- +-- > apC :: Closure (a -> b) -> Closure a -> Closure b +-- > apC clo_f clo_x = +-- > $(mkClosure [|unClosure clo_f $ unClosure clo_x|]) +-- +-- If @'Static'@ were fully supported by GHC then @'mkClosure'@ would abstract +-- the free local variables (here @clo_f@ and @clo_x@) in its quoted argument, +-- serialise a tuple of these variables, and construct a suitable @'Static'@ +-- deserialiser. In short, expanding the above Template Haskell splice +-- would yield the following definition: +-- +-- > apC clo_f clo_x = +-- > let thk = unClosure clo_f $ unClosure clo_x +-- > env = encodeEnv (clo_f, clo_x) +-- > fun = static $ \ env -> let (clo_f, clo_x) = decodeEnv env +-- > in unClosure clo_f $ unClosure clo_x +-- > in unsafeMkClosure thk fun env +-- +-- However, the current implementation of @'mkClosure'@ cannot do this because +-- there is no term former @static@. Instead, the current implementation +-- of @'mkClosure'@ expects its quoted argument to be in a one of two special +-- forms: either it is a single /toplevel/ variable, or an application of a +-- /toplevel/ variable to a tuple of free variables. To distinguish the two +-- forms, Closures constructed from single toplevel variables will be called +-- /static/ (because like static terms they do not capture any variables). +-- +-- Here is the definition of @apC@ as an example of how to construct a +-- general, non-static Closure. +-- +-- > apC clo_f clo_x = +-- > $(mkClosure [|apC_abs (clo_f, clo_x)|]) +-- > +-- > apC_abs :: (Closure (a -> b), Closure a) -> b +-- > apC_abs (clo_f, clo_x) = unClosure clo_f $ unClosure clo_x +-- +-- First, the programmer must manually define a toplevel /closure abstraction/ +-- @apC_abs@ which abstracts a tuple @(clo_f, clo_x)@ of free local variables +-- occuring in the expression to be converted into a Closure. (Usually, the +-- programmer would want the closure abstraction @apC_abs@ to be inlined.) +-- +-- Second, the programmer constructs the explicit Closure via a Template +-- Haskell splice @$(mkClosure [|apC_abs (clo_f, clo_x)|])@, where the quoted +-- expression @apC_abs (clo_f, clo_x)@ is an application of the toplevel closure +-- abstraction to a tuple of free local variables. It is important +-- that this actual tuple of variables matches /exactly/ the formal tuple +-- in the definition of the closure abstraction. In fact, best practice is +-- for the quoted expression to textually match the left-hand side of the +-- definition of the closure abstraction. +-- +-- Finally, a @'Static'@ deserialiser corresponding to the toplevel closure +-- abstraction must be declared. To this end, this module exports a Template +-- Haskell function @'static'@ which converts the name of a toplevel closure +-- abstraction into a @'Static'@ deserialiser, and a function @'declare'@ which +-- turns the @'Static'@ deserialiser into a @'Static'@ declaration. These +-- should be used as follows; see also the definition of @declareStatic@ below. +-- +-- > declare $(static 'apC_abs) +-- +-- +-- The second example is the definition of the static Closure @idC@, which +-- lifts the identity function to a function Closure. +-- The definition is a follows; see also code towards the end of this file. +-- +-- > idC :: Closure (a -> a) +-- > idC = $(mkClosure [|id|]) +-- +-- The expression to be converted into a Closure, the variable @'id'@, does not +-- contain any free local variables, so there is no need to abstract a tuple +-- of free variables. In fact, the expression is already a toplevel variable, +-- so there is also no need to define a new toplevel closure abstraction either. +-- Thus, the programmer constructs the static Closure via the the Template +-- Haskell splice @$(mkClosure [|id|])@, where the quoted expression @'id'@ +-- is a toplevel variable. +-- +-- The programmer must also declare a @'Static'@ deserialiser corresponding to +-- the toplevel variable of which the static Closure was created. This is done +-- as follows; see also the definition of @declareStatic@ below. +-- +-- > declare $(static_ 'id) +-- +-- Note the use of @'static_'@ instead of @'static'@ to create a @'Static'@ +-- deserialiser for a /static/ Closure, ie. a @'Static'@ deserialiser that does +-- not actually deserialise any free variables. Accidentally mixing up +-- @'static'@ and @'static_'@ may lead to runtime errors! +-- +-- +-- [Constructing families of Closures] +-- +-- A problem arises with Closures whose type is not only polymorphic (as eg. +-- the type of @idC@ above) but also constrained by type classes. The problem +-- here is that the class constraint has to be resolved statically, as there +-- is no way of attaching implicit dictionaries to a Closure (because these +-- dictionaries would have to be serialised as well). However, there is a +-- way of safely constructing such constrained Closures. The idea is to +-- actually construct a family of Closures, indexed by source locations. +-- The indices are produced by certain type class instances, effectively +-- turning the location-based into a type-based indexing. We illustrate +-- this method on two examples. +-- +-- The first example is the function @toClosure@ which converts any suitable +-- value into a Closure, forcing the value upon serialisation. The /suitable/ +-- values are those whose type is an instance of class +-- @'Data.Serialize.Serialize'@, so one would expect @toClosure@ to have the +-- following implementation and @'Static'@ declaration: +-- +-- > toClosure :: (Serialize a) => a -> Closure a +-- > toClosure val = $(mkClosure [| id val |]) +-- > +-- > declare $(static 'id) +-- +-- However, this does not compile - the last line complains from an ambiguous +-- type variable @a@ in the constrait @Serialize a@. +-- +-- The solution is to define a new type class @ToClosure@ as a subclass of +-- the given @'Data.Serialize.Serialize'@ constraint, and use instances of +-- @ToClosure@ to index a family of Closures. The indexing is done by +-- @locToClosure@, the only member of class @ToClosure@, as follows. +-- +-- > class (Serialize a) => ToClosure a where +-- > locToClosure :: LocT a +-- > +-- > toClosure :: (ToClosure a) => a -> Closure a +-- > toClosure val = $(mkClosureLoc [| id val |]) locToClosure +-- +-- Note that the above splice @$(mkClosureLoc [|id val|])@ generates a family +-- of type @'LocT' a -> 'Closure' a@. Applying that family to the index +-- @locToClosure@ yields the actual Closure. On the face of it, indexing +-- appears to be location based, but actually the family generated by +-- @'mkClosureLoc'@ never evaluates the index; thanks to the phantom type +-- argument of @'LocT'@ the indexing is really done statically on the types. +-- (Though the location information is necessary to tag the associated +-- @'Static'@ deserialisers, and will be evaluated when constructing the +-- @'Static'@ table.) +-- +-- What this achieves is reducing the constraint on @toClosure@ from +-- @'Data.Serialize.Serialize'@ to @ToClosure@. Hence @toClosure@ is only +-- available for types for which the programmer explicitly instantiates +-- @ToClosure@. These instances are very simple, see the following two samples. +-- +-- > instance ToClosure Int where locToClosure = $(here) +-- > instance ToClosure (Closure a) where locToClosure = $(here) +-- +-- Note that the two instances are entirely identical, in fact all instances +-- of @ToClosure@ must be identical. In particular, instances must not +-- be recursive, so that the number of types instantiating @ToClosure@ +-- matches exactly the number of instance declarations in the source code. +-- All an instance does is record its location in the source code via +-- @locToClosure@, making @locToClosure@ a key for @ToClosure@ instances. +-- +-- The programmer must declare the @'Static'@ deserialisers associated with +-- the above family of Closures. More precisely, she must declare one +-- deserialiser per @ToClosure@ instance. This is done by defining a +-- family of @'Static'@ deserialisers, similar to the family of Closures. +-- +-- > type StaticToClosure a = Static (Env -> a) +-- > +-- > staticToClosure :: (ToClosure a) => StaticToClosure a +-- > staticToClosure = $(staticLoc 'id) locToClosure +-- +-- Note that the splice @$(staticLoc 'id)@ above generates a family of +-- type @'LocT' a -> 'Static' ('Env' -> a)@. Applying that family to the index +-- @locToClosure@ yields an actual @'Static'@ deserialiser. The type synomyn +-- @StaticToClosure@ is a mere convenience to improve readability, as will +-- become evident when actually declaring the @'Static'@ deserialisers +-- (particularly in the second example). +-- +-- It remains to actually declare the @'Static'@ deserialisers, one per instance +-- of @ToClosure@. Since @'Static'@ declarations form a monoid, the programmer +-- can simply concatenate all these declarations. So, given the above sample +-- @ToClosure@ instances, the programmer would declare the associated +-- deserialisers as follows. +-- +-- > Data.Monoid.mconcat +-- > [declare (staticToClosure :: StaticToClosure Int), +-- > declare (staticToClosure :: forall a . StaticToClosure (Closure a))] +-- +-- +-- The second example of families of Closures is @forceCC@, which wraps +-- @forceC@ into a Closure, where @forceC@ is defined as follows: +-- +-- > forceC :: (NFData a, ToClosure a) => Strategy (Closure a) +-- > forceC clo = return $! forceClosure clo +-- +-- Note that @forceC@ lifts @'forceClosure'@ to a /strategy/ in the @Par@ +-- monad; please see module @Control.Parallel.HdpH.Strategies@ for the +-- definition of the @Strategy@ type constructor. +-- +-- Ideally, @forceCC@ would be implemented simply like this: +-- +-- > forceCC :: (NFData a, ToClosure a) => Closure (Strategy (Closure a)) +-- > forceCC = $(mkClosure [|forceC|]) +-- +-- However, the type class constraint demands that @forceCC@ generate a family +-- of Closures; in fact, it must generate a family of /static/ Closures because +-- @forceC@, the expression quoted in the Template Haskell splice, is a single +-- toplevel variable. The actual implementation of @forceCC@ is as follows: +-- +-- > class (NFData a, ToClosure a) => ForceCC a where +-- > locForceCC :: LocT (Strategy (Closure a)) +-- > +-- > forceCC :: (ForceCC a) => Closure (Strategy (Closure a)) +-- > forceCC = $(mkClosureLoc [| forceC |]) locForceCC +-- +-- Above is the first part of the code, the definition of a new type class +-- @ForceCC@ and the defintion of @forceCC@ itself. Note the complex phantom +-- type argument of @locForceCC@; this is dictated by the splice +-- @$(mkClosureLoc [|forceC|])@ which is of type +-- @'LocT' (Strategy ('Closure' a)) -> 'Closure' (Strategy ('Closure' a))@. +-- Instances of class @ForceCC@ are very similar to instances of @ToClosure@, +-- cf. the following two samples. +-- +-- > instance ForceCC Int where locForceCC = $(here) +-- > instance ForceCC (Closure a) where locForceCC = $(here) +-- +-- Along with the family of Closures there is a family of @'Static'@ +-- deserialisers, defined as follows. Note the use of @'staticLoc_'@ because +-- @'forceCC'@ generates a family of /static/ Closures. +-- +-- > type StaticForceCC a = Static (Env -> Strategy (Closure a)) +-- > +-- > staticForceCC :: (ForceCC a) => StaticForceCC a +-- > staticForceCC = $(staticLoc_ 'forceC) locForceCC +-- +-- It remains to actually declare the @'Static'@ deserialisers, one per +-- @ForceCC@ instance. Again, this is very similar to declaring the +-- deserialisers linked to @ToClosure@ instances. But note how the type +-- synonym @StaticForceCC@ improves readability of the declaration - just try +-- expanding the last line of the following declaration. +-- +-- > Data.Monoid.mconcat +-- > [declare (staticForceCC :: StaticForceCC Int), +-- > declare (staticForceCC :: forall a . StaticForceCC (Closure a))] +-- +-- +-- [Registering @'Static'@ deserialisers] +-- +-- All @'Static'@ deserialisers need to be declared, as shown above. +-- By convention, each module must concatenate all such @'Static'@ declarations +-- (including declarations in imported modules) into a single @'Static'@ +-- declaration. The @Main@ module, finally, must /register/ its @'Static'@ +-- declaration (which by convention includes all declarations in imported +-- modules) at the beginning of the @main@ function, to create the @'Static'@ +-- table. This section shows how to concatenate and register @'Static'@ +-- declarations. +-- +-- First, concatenating @'Static'@ declarations. As shown above, a @'Static'@ +-- deserialiser can be turned into a @'Static'@ declaration (of type +-- @'StaticDecl'@) by applying @'declare'@. The type @'StaticDecl'@ is an +-- instance of class @'Data.Monoid.Monoid'@, so @'Static'@ declarations can be +-- concatenated via the @'mconcat'@ operation. In fact, @'StaticDecl'@ is not +-- just a monoid but a commutative and idempotent monoid, thanks to the +-- way @'Static'@ deserialisers are constructed. That means that @'Static'@ +-- declarations can be concatenated repeatedly and in any order without +-- changing the result. +-- +-- As a matter of convention, every module which constructs explicit Closures +-- must export a term @declareStatic :: StaticDecl@, a comprehensive declaration +-- of all the module's @'Static'@ deserialisers, including all @'Static'@ +-- deserialisers of imported modules. The latter is required because the module +-- may call imported functions which in turn depend on their modules' +-- @'Static'@ deserialisers. +-- +-- > declareStatic :: StaticDecl +-- > declareStatic = Data.Monoid.mconcat +-- > [declare $(static_ 'id), +-- > declare $(static_ 'constUnit), +-- > declare $(static 'compC_abs), +-- > declare $(static 'apC_abs), +-- > declare (staticToClosure :: forall a . StaticToClosure (Closure a))] +-- +-- Above is a simple example of such a comprehensive Static declaration, +-- the declaration of this module. Note that the order of the list argument +-- to @'mconcat'@ does not matter because because @'StaticDecl'@ is a +-- commutative monoid. Below is a more complex example, taken from a HdpH +-- program. +-- +-- > declareStatic :: StaticDecl +-- > declareStatic = Data.Monoid.mconcat +-- > [Control.Parallel.HdpH.declareStatic, +-- > Control.Parallel.HdpH.Strategies.declareStatic, +-- > declare (staticToClosure :: StaticToClosure Int), +-- > declare (staticToClosure :: StaticToClosure [Int]), +-- > declare (staticToClosure :: StaticToClosure Integer), +-- > declare (staticForceCC :: StaticForceCC Integer), +-- > declare $(static 'spark_sum_euler_abs), +-- > declare $(static_ 'sum_totient), +-- > declare $(static_ 'totient)] +-- +-- This declaration does concatenate the Static declarations of two imported +-- modules, @Control.Parllel.HdpH@ and @Control.Parallel.HdpH.Strategies@. +-- Actually, the latter also imports the former, so +-- @Control.Parallel.HdpH.Strategies.declareStatic@ already concatenates +-- @Control.Parallel.HdpH.declareStatic@, and so the above call to +-- @Control.Parallel.HdpH.declareStatic@ could be omitted. However, that +-- omission is only justified in the knowledge of implementation details of +-- @Control.Parallel.HdpH.Strategies@ (namely its import graph). The convention +-- that @'Static'@ declarations of /all/ imported modules must be concatenated, +-- regardless of whether they are transitively concatenated by other imported +-- modules, is more robust; the resulting @'Static'@ declaration is the same +-- anyway, thanks to @'StaticDecl'@ being an idempotent monoid. +-- +-- A general rule how to deal with imports and @'Static'@ declarations: +-- If module @M1@ imports another module @M2@, and +-- if @M2@ exports a variable @declareStatic :: StaticDecl@ +-- then @M1@ must export its own @declareStatic :: StaticDecl@, +-- which needs to concatenate @M2.declareStatic@ (amongst other declarations). +-- Note that the rule applies even if @M1@ ostensibly imports "nothing" +-- from @M2@, eg. @M1@ imports @M2@ with the clause @import M2 ()@. For +-- this clause may still import instance declarations from @M2@, and those +-- instances may depend on M2's @'Static'@ deserialisers. +-- +-- +-- Finally, registering a @'Static'@ declaration. This must be done exactly once +-- in the @Main@ module, right at the start of @main@, by calling the function +-- @'register'@ on the @Main@ module's comprehensive @'Static'@ declaration. +-- This is shown in sample code below, taken from a HdpH program. +-- Note that any actions executed prior to @'register'@ (ie. the @hSetBuffering@ +-- calls) must not involve explicit Closures. +-- +-- > main :: IO () +-- > main = do +-- > hSetBuffering stdout LineBuffering +-- > hSetBuffering stderr LineBuffering +-- > register declareStatic +-- > ... + + +----------------------------------------------------------------------------- +-- Static declaration + +-- 'ToClosure' instance for Closures, only recording indexing location; +-- all instances of 'ToClosure' look like this. +instance ToClosure (Closure a) where locToClosure = $(here) + +declareStatic :: StaticDecl +declareStatic = mconcat + [declare $(static_ 'id), + declare $(static_ 'constUnit), + declare $(static 'compC_abs), + declare $(static 'apC_abs), + declare (staticToClosure :: forall a . StaticToClosure (Closure a))] + -- Declaration of indexed Static deserialiser for 'toClosure'; + -- all declarations of 'staticToClosure' look like this. + + +----------------------------------------------------------------------------- +-- Value Closure construction + +-- | @toClosure x@ constructs a value Closure wrapping @x@, provided the +-- type of @x@ is an instance of class @'ToClosure'@. +-- Note that the serialised representation of the resulting Closure stores a +-- serialised representation (as per class @'Data.Serialize.Serialize'@) of +-- @x@, so serialising the resulting Closure will force @x@ (hence could be +-- costly). However, Closure construction itself is cheap. +toClosure :: (ToClosure a) => a -> Closure a +toClosure val = $(mkClosureLoc [| id val |]) locToClosure + +-- | Indexing class, recording types which support the @'toClosure'@ operation; +-- see the tutorial below for a more thorough explanation. +-- Note that @ToClosure@ is a subclass of @'Data.Serialize.Serialize'@. +class (Serialize a) => ToClosure a where + -- | Only method of class @ToClosure@, recording the source location + -- where an instance of @ToClosure@ is declared. + locToClosure :: LocT a + +-- | Type synonym for declaring the @'Static'@ deserialisers required by +-- @'ToClosure'@ instances; see the tutorial below for a more thorough +-- explanation. +type StaticToClosure a = Static (Env -> a) + +-- | @'Static'@ deserialiser required by a @'ToClosure'@ instance; +-- see the tutorial below for a more thorough explanation. +staticToClosure :: (ToClosure a) => StaticToClosure a +staticToClosure = $(staticLoc 'id) locToClosure + + +----------------------------------------------------------------------------- +-- fully forcing Closures + +-- | @forceClosure@ fully forces its argument, ie. fully normalises the thunk. +-- Importantly, @forceClosure@ also updates the serialisable closure +-- represention in order to keep it in sync with the normalised thunk. +-- Note that only the thunk of the resulting Closure is in normal form; +-- for the serialisable representation to also be in normal form, the resulting +-- Closure must be forced by @'deepseq'@. +-- +-- Note that @forceClosure clo@ does not have the same effect as +-- +-- * @'Control.DeepSeq.force' clo@ (because @forceClosure@ updates the closure +-- representation), or +-- +-- * @'Control.DeepSeq.force' $ toClosure $ unClosure clo@ (because +-- @forceClosure@ does not force the resulting Closure's serialisable +-- representation). +-- +forceClosure :: (NFData a, ToClosure a) => Closure a -> Closure a +forceClosure clo = x `deepseq` toClosure x where x = unClosure clo + +-- Note that it does not make sense to construct a variant of @forceClosure@ +-- that would evaluate the thunk inside a Closure head-strict only. The reason +-- is that serialising such a Closure would turn it into a fully forced one. + + +------------------------------------------------------------------------------ +-- Categorical operations on function Closures + +-- | Identity arrow wrapped in a Closure. +idC :: Closure (a -> a) +idC = $(mkClosure [| id |]) + + +-- | Terminal arrow wrapped in a Closure. +termC :: Closure (a -> ()) +termC = $(mkClosure [| constUnit |]) + +{-# INLINE constUnit #-} +constUnit :: a -> () +constUnit = const () + + +-- | Composition of function Closures. +compC :: Closure (b -> c) -> Closure (a -> b) -> Closure (a -> c) +compC clo_g clo_f = $(mkClosure [| compC_abs (clo_g, clo_f) |]) + +{-# INLINE compC_abs #-} +compC_abs :: (Closure (b -> c), Closure (a -> b)) -> (a -> c) +compC_abs (clo_g, clo_f) = unClosure clo_g . unClosure clo_f + + +-- | Application of a function Closure to another Closure. +-- Behaves like the @ap@ operation of an applicative functor. +apC :: Closure (a -> b) -> Closure a -> Closure b +apC clo_f clo_x = $(mkClosure [| apC_abs (clo_f, clo_x) |]) + +{-# INLINE apC_abs #-} +apC_abs :: (Closure (a -> b), Closure a) -> b +apC_abs (clo_f, clo_x) = unClosure clo_f $ unClosure clo_x diff --git a/src/Control/Parallel/HdpH/Closure/Internal.hs b/src/Control/Parallel/HdpH/Closure/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Control/Parallel/HdpH/Closure/Internal.hs @@ -0,0 +1,443 @@ +-- Closure representation, inspired by [1] and refined by [2]. +-- [1] Epstein et al. "Haskell for the cloud". Haskell Symposium 2011. +-- [2] Maier, Trinder. "Implementing a High-level Distributed-Memory +-- Parallel Haskell in Haskell". IFL 2011. +-- Internal module necessary to satisfy Template Haskell stage restrictions. +-- +-- Author: Patrick Maier +----------------------------------------------------------------------------- + +-- The module 'Control.Parallel.HdpH.Closure' implements /explicit closures/ +-- as described in [2]. Due to Template Haskell stage restrictions, the module +-- has to be split into two halves. This is the half that that defines internals +-- like the actual closure representation and Template Haskell macros on it. +-- The higher level stuff (including a tutorial on expclicit closures) is in +-- module 'Control.Parallel.HdpH.Closure'. + +{-# LANGUAGE TemplateHaskell #-} + +module Control.Parallel.HdpH.Closure.Internal + ( -- source locations with phantom type attached + LocT, -- instances: Eq, Ord, Show + here, -- :: ExpQ + + -- serialised environment + Env, -- instances: Eq, Ord, Show, NFData, Serialize + encodeEnv, -- :: (Serialize a) => a -> Env + decodeEnv, -- :: (Serialize a) => Env -> a + + -- Closure type constructor + Closure, -- instances: Show, NFData, Serialize + + -- introducing and eliminating Closures + unsafeMkClosure, -- :: a -> Static (Env -> a) -> Env -> Closure a + unClosure, -- :: Closure a -> a + + -- safe Closure construction + mkClosure, -- :: ExpQ -> ExpQ + mkClosureLoc, -- :: ExpQ -> ExpQ + + -- static deserializers + static, -- :: Name -> ExpQ + staticLoc, -- :: Name -> ExpQ + static_, -- :: Name -> ExpQ + staticLoc_ -- :: Name -> ExpQ + ) where + +import Prelude +import Control.DeepSeq (NFData(rnf)) +import Data.ByteString.Lazy (ByteString, unpack, foldl') +import Data.Functor ((<$>)) +import Data.Serialize (Serialize) +import qualified Data.Serialize (put, get, encodeLazy, decodeLazy) +import Language.Haskell.TH + (Exp(AppE, VarE, TupE, ConE), ExpQ, Lit, + appsE, lam1E, conE, varE, global, litE, varP, stringL, tupleDataName) +import qualified Language.Haskell.TH as TH (Loc(..), location) +import Language.Haskell.TH.Syntax + (Name(Name), NameFlavour(NameG, NameL), NameSpace(VarName, DataName), + newName, pkgString, modString, occString) + +import Control.Parallel.HdpH.Closure.Static (Static, unstatic, staticAs) + + +----------------------------------------------------------------------------- +-- source locations with phantom type attached + +-- | A value of type @'LocT a'@ is a representation of a Haskell source location +-- (or more precisely, the location of a Template Haskell slice, as produced by +-- @'here'@). Additionally, this location is annotated with a phantom type 'a', +-- which is used for mapping location indexing to type indexing. +newtype LocT a = LocT { unLocT :: String } deriving (Eq, Ord) + +instance Show (LocT a) where + show = unLocT + +-- | Template Haskell construct returning its own location when spliced. +here :: ExpQ +here = do + loc <- TH.location + appsE [conE 'LocT, litE $ stringL $ showLoc loc] + + +----------------------------------------------------------------------------- +-- serialised environments + +-- | Abstract type of serialised environments. +newtype Env = Env ByteString deriving (Eq, Ord) + +instance Show Env where + showsPrec _ (Env env) = shows env + +instance NFData Env where + rnf (Env env) = foldl' (\ _ -> rnf) () env + +instance Serialize Env where + put (Env env) = Data.Serialize.put env + get = Env <$> Data.Serialize.get + +-- | Creates a serialised environment from a given value of type @a@. +encodeEnv :: (Serialize a) => a -> Env +encodeEnv x = Env $ Data.Serialize.encodeLazy x + +-- | Deserialises a serialised environment producing a value of type @a@. +-- Note that the programmer asserts that the environment can be deserialised +-- at type @a@, a type mismatch may abort or crash the program. +decodeEnv :: (Serialize a) => Env -> a +decodeEnv (Env env) = + case Data.Serialize.decodeLazy env of + Right x -> x + Left msg -> error $ "Control.Parallel.HdpH.Closure.decodeEnv " ++ + showEnvPrefix 20 env ++ ": " ++ msg + + +----------------------------------------------------------------------------- +-- 'Closure' type constructor + +-- | An explicit Closure, ie. a term of type @Closure a@, maintains a dual +-- representation of an actual closure (ie. a thunk) of type @a@. +-- +-- (1) One half of that representation is the actual closure, the /thunk/ +-- of type @a@. +-- +-- (2) The other half is a serialisable representation of the thunk, +-- consisting of a @'Static'@ environment deserialiser, of type +-- @'Static' ('Env' -> a)@, plus a serialised environment of type @'Env'@. +-- +-- Representation (1) is used for computing with Closures while +-- representation (2) is used for serialising and communicating Closures +-- across the network. +-- +data Closure a = Closure + a -- actual thunk + (Static (Env -> a)) -- Static environment deserialiser + Env -- serialised environment + + +----------------------------------------------------------------------------- +-- Show/NFData/Serialize instances for 'Closure' +-- +-- Note that these instances are uniform for all 'Closure a' types since +-- they ignore the type argument 'a'. + +-- NOTE: These instances obey a contract between Serialize and NFData +-- * A type is an instance of NFData iff it is an instance of Serialize. +-- * A value is forced by 'rnf' to the same extent it is forced by +-- 'rnf . encode'. + +-- NOTE: Phil is unhappy with this contract. He argues that 'rnf' should +-- fully force the Closure (and thus evaluate further than 'rnf . encode' +-- would). His argument is essentially that 'rnf' should act on +-- explicit Closures as it acts on thunks. Which would mean +-- that 'NFData (Closure a)' can only be defined given a '(Serialize a)' +-- context. +-- +-- Here is the killer argument against Phil's proposal: Because of the +-- type of 'rnf', it can only evaluate its argument as a side effect; +-- it cannot actually change its representation. However, forcing an +-- explicit Closure must change its representation (at least if we +-- want to preserve the evaluation status across serialisation). + +instance NFData (Closure a) where + -- force the serialisable rep but not the actual thunk + rnf (Closure _ fun env) = rnf fun `seq` rnf env + + +instance Serialize (Closure a) where + -- serialise the serialisable rep but not the actual thunk + put (Closure _ fun env) = Data.Serialize.put fun >> + Data.Serialize.put env + + -- deserialise the serialisable rep and lazily re-instate the actual thunk + get = do fun <- Data.Serialize.get + env <- Data.Serialize.get + let thk = (unstatic fun) env + return $ Closure thk fun env + + +instance Show (Closure a) where -- for debugging only; show serialisable rep + showsPrec _ (Closure _ fun env) = showString "Closure(" . shows fun . + showString "," . shows env . showString ")" + + +----------------------------------------------------------------------------- +-- introducing and eliminating Closures + +-- | Eliminates a Closure by returning its thunk. +-- This operation is cheap. +{-# INLINE unClosure #-} +unClosure :: Closure a -> a +unClosure (Closure thk _ _) = thk + + +-- | @unsafeMkClosure thk fun env@ constructs a Closure that +-- +-- (1) wraps the thunk @thk@ and +-- +-- (2) whose serialised representation consists of the @'Static'@ deserialiser +-- @fun@ and the serialised environment @env@. +-- +-- This operation is cheap and does not require Template Haskell support, +-- but it is /unsafe/ because it relies on the programmer to ensure that +-- both closure representations evaluate to the same term. +{-# INLINE unsafeMkClosure #-} +unsafeMkClosure :: a -> Static (Env -> a) -> Env -> Closure a +unsafeMkClosure thk fun env = Closure thk fun env + + +----------------------------------------------------------------------------- +-- safely constructing Closures from closure abstractions + +-- | Template Haskell transformation constructing a Closure from a given thunk. +-- The thunk must either be a single toplevel closure (in which case the result +-- is a /static/ Closure), or an application of a toplevel closure +-- abstraction to a tuple of local variables. +-- See the tutorial below for how to use @mkClosure@. +mkClosure :: ExpQ -> ExpQ +mkClosure thkQ = do + thk <- thkQ + let funQ = case thk of + AppE (VarE clo_abs_name) _ -> static clo_abs_name + AppE (ConE clo_abs_name) _ -> static clo_abs_name + VarE clo_name -> static_ clo_name + ConE clo_name -> static_ clo_name + _ -> error "mkClosure: impossible case" + let envQ = case thk of + AppE _ free_vars -> appsE [global 'encodeEnv, return free_vars] + _ -> [| encodeEnv () |] + let cloQ = appsE [conE 'Closure, thkQ, funQ, envQ] + case thk of + AppE (VarE clo_abs_name) free_vars + | isGlobalVarName clo_abs_name && isLocalVars free_vars -> cloQ + AppE (ConE clo_abs_name) free_vars + | isGlobalDataName clo_abs_name && isLocalVars free_vars -> cloQ + VarE clo_name + | isGlobalVarName clo_name -> cloQ + ConE clo_name + | isGlobalDataName clo_name -> cloQ + _ -> fail $ "Control.Parallel.HdpH.Closure.mkClosure: " ++ + "argument not of the form 'globalVarOrCon' or " ++ + "'globalVarOrCon (localVar_1,...,localVar_n)'" + + +-- | Template Haskell transformation constructing a family of Closures from a +-- given thunk. The family is indexed by location (that's what the suffix @Loc@ +-- stands for). +-- The thunk must either be a single toplevel closure (in which case the result +-- is a family of /static/ Closures), or an application of a toplevel closure +-- abstraction to a tuple of local variables. +-- See the tutorial below for how to use @mkClosureLoc@. +mkClosureLoc :: ExpQ -> ExpQ +mkClosureLoc thkQ = do + thk <- thkQ + let funQ = case thk of + AppE (VarE clo_abs_name) _ -> staticLoc clo_abs_name + AppE (ConE clo_abs_name) _ -> staticLoc clo_abs_name + VarE clo_name -> staticLoc_ clo_name + ConE clo_name -> staticLoc_ clo_name + _ -> error "mkClosureLoc: impossible case" + let envQ = case thk of + AppE _ free_vars -> appsE [global 'encodeEnv, return free_vars] + _ -> [| encodeEnv () |] + loc <- newName "loc" + let cloQ = lam1E (varP loc) $ + appsE [conE 'Closure, thkQ, appsE [funQ, varE loc], envQ] + case thk of + AppE (VarE clo_abs_name) free_vars + | isGlobalVarName clo_abs_name && isLocalVars free_vars -> cloQ + AppE (ConE clo_abs_name) free_vars + | isGlobalDataName clo_abs_name && isLocalVars free_vars -> cloQ + VarE clo_name + | isGlobalVarName clo_name -> cloQ + ConE clo_name + | isGlobalDataName clo_name -> cloQ + _ -> fail $ "Control.Parallel.HdpH.Closure.mkClosureLoc: " ++ + "argument not of the form 'globalVarOrCon' or " ++ + "'globalVarOrCon (localVar_1,...,localVar_n)'" + + +----------------------------------------------------------------------------- +-- Static deserializers + +-- | Template Haskell transformation converting a toplevel closure abstraction +-- (given by its name) into a @'Static'@ deserialiser. +-- See the tutorial below for how to use @static@. +static :: Name -> ExpQ +static name = + case tryLabelClosureAbs name of + Just (clo_abs, label) -> appsE [global 'mkStatic, clo_abs, litE label] + Nothing -> fail $ "Control.Parallel.HdpH.Closure.static: " ++ + show name ++ " not a global variable or constructor name" + +-- Called by 'static'. +{-# INLINE mkStatic #-} +mkStatic :: (Serialize a) + => (a -> b) -> String -> Static (Env -> b) +mkStatic clo_abs label = + staticAs (clo_abs . decodeEnv) label + + +-- | Template Haskell transformation converting a static toplevel closure +-- (given by its name) into a @'Static'@ deserialiser. +-- Note that a static closure ignores its empty environment (which is +-- what the suffix @_@ is meant to signify). +-- See the tutorial below for how to use @static_@. +static_ :: Name -> ExpQ +static_ name = + case tryLabelClosureAbs name of + Just (clo, label) -> appsE [global 'mkStatic_, clo, litE label] + Nothing -> fail $ "Control.Parallel.HdpH.Closure.static_: " ++ + show name ++ " not a global variable or constructor name" + +-- Called by 'static_'. +{-# INLINE mkStatic_ #-} +mkStatic_ :: b -> String -> Static (Env -> b) +mkStatic_ clo label = + staticAs (const clo) $ "_/" ++ label + + +-- | Template Haskell transformation converting a toplevel closure abstraction +-- (given by its name) into a family of @'Static'@ deserialisers indexed by +-- location (that's what the suffix @Loc@ stands for). +-- See the tutorial below for how to use @staticLoc@. +staticLoc :: Name -> ExpQ +staticLoc name = + case tryLabelClosureAbs name of + Just (clo_abs, label) -> appsE [global 'mkStaticLoc, clo_abs, litE label] + Nothing -> fail $ "Control.Parallel.HdpH.Closure.staticLoc: " ++ + show name ++ " not a global variable or constructor name" + +-- Called by 'staticLoc'. +{-# INLINE mkStaticLoc #-} +mkStaticLoc :: (Serialize a) + => (a -> b) -> String -> (LocT b -> Static (Env -> b)) +mkStaticLoc clo_abs label = + \ loc -> staticAs (clo_abs . decodeEnv) $ + label ++ "{loc=" ++ show loc ++ "}" + + +-- | Template Haskell transformation converting a static toplevel closure +-- (given by its name) into a family of @'Static'@ deserialisers indexed by +-- location (that's what the suffix @Loc@ stands for). +-- Note that a static closure ignores its empty environment (which is +-- what the suffix @_@ is meant to signify). +-- See the tutorial below for how to use @staticLoc_@. +staticLoc_ :: Name -> ExpQ +staticLoc_ name = + case tryLabelClosureAbs name of + Just (clo, label) -> appsE [global 'mkStaticLoc_, clo, litE label] + Nothing -> fail $ "Control.Parallel.HdpH.Closure.staticLoc_: " ++ + show name ++ " not a global variable or constructor name" + +-- Called by 'staticLoc_'. +{-# INLINE mkStaticLoc_ #-} +mkStaticLoc_ :: b -> String -> (LocT b -> Static (Env -> b)) +mkStaticLoc_ clo label = + \ loc -> staticAs (const clo) $ + "_/" ++ label ++ "{loc=" ++ show loc ++ "}" + + +----------------------------------------------------------------------------- +-- auxiliary stuff: operations involving variable names + +-- Expects the argument to be a global variable or constructor name. +-- If so, returns a pair consisting of an expression (the closure abstraction +-- or static closure named by the argument) and a label representing the name; +-- otherwise returns Nothing. +{-# INLINE tryLabelClosureAbs #-} +tryLabelClosureAbs :: Name -> Maybe (ExpQ, Lit) +tryLabelClosureAbs name = + let mkLabel pkg' mod' occ' = stringL $ pkgString pkg' ++ "/" ++ + modString mod' ++ "." ++ + occString occ' + in case name of + Name occ' (NameG VarName pkg' mod') -> + Just (varE name, mkLabel pkg' mod' occ') + Name occ' (NameG DataName pkg' mod') -> + Just (conE name, mkLabel pkg' mod' occ') + _ -> Nothing + + +-- True iff the argument is a global variable name. +{-# INLINE isGlobalVarName #-} +isGlobalVarName :: Name -> Bool +isGlobalVarName (Name _ (NameG VarName _ _)) = True +isGlobalVarName _ = False + +-- True iff the argument is a data constructor name. +{-# INLINE isGlobalDataName #-} +isGlobalDataName :: Name -> Bool +isGlobalDataName (Name _ (NameG DataName _ _)) = True +isGlobalDataName _ = False + + +-- True iff the expression is a local variable. +{-# INLINE isLocalVar #-} +isLocalVar :: Exp -> Bool +isLocalVar (VarE (Name _ (NameL _))) = True +isLocalVar _ = False + +-- True iff the expression is a (possibly empty) tuple of local variables. +-- NOTE: Empty tuples are only properly recognized from GHC 7.4 onwards +-- (prior to 7.4 empty tuples were represented as unit values). +{-# INLINE isLocalVarTuple #-} +isLocalVarTuple :: Exp -> Bool +isLocalVarTuple (TupE exps) = all isLocalVar exps -- non-empty tuples +isLocalVarTuple (ConE name) = name == tupleDataName 0 -- empty tuple +isLocalVarTuple _ = False + +-- True iff the expression is a local variable or a tuple of local variables. +{-# INLINE isLocalVars #-} +isLocalVars :: Exp -> Bool +isLocalVars expr = isLocalVar expr || isLocalVarTuple expr + + +----------------------------------------------------------------------------- +-- auxiliary stuff: various show operations + +-- Show Template Haskell location. +-- Should be defined in module Language.Haskell.TH. +{-# INLINE showLoc #-} +showLoc :: TH.Loc -> String +showLoc loc = showsLoc loc "" + where + showsLoc loc' = showString (TH.loc_package loc') . showString "/" . + showString (TH.loc_module loc') . showString ":" . + showString (TH.loc_filename loc') . showString "@" . + shows (TH.loc_start loc') . showString "-" . + shows (TH.loc_end loc') + + +-- Show first 'n' bytes of 'env'. +showEnvPrefix :: Int -> ByteString -> String +showEnvPrefix n env = showListUpto n (unpack env) "" + + +-- Show first 'n' list elements +showListUpto :: (Show a) => Int -> [a] -> String -> String +showListUpto _ [] = showString "[]" +showListUpto n (x:xs) = showString "[" . shows x . go (n - 1) xs + where + go _ [] = showString "]" + go k (z:zs) | k > 0 = showString "," . shows z . go (k - 1) zs + | otherwise = showString ",...]" diff --git a/src/Control/Parallel/HdpH/Closure/Static.hs b/src/Control/Parallel/HdpH/Closure/Static.hs new file mode 100644 --- /dev/null +++ b/src/Control/Parallel/HdpH/Closure/Static.hs @@ -0,0 +1,391 @@ +-- 'Static' support, mimicking +-- [1] Epstein et al. "Haskell for the cloud". Haskell Symposium 2011. +-- +-- Author: Patrick Maier +----------------------------------------------------------------------------- + +-- The 'Static' type constructor as proposed in [1] is not yet supported +-- by GHC (as of version 7.4.1). This module provides a workaround that +-- necessarily differs in some aspects. However, the type constructor 'Static' +-- itself and its eliminator 'unstatic' work exactly as proposed in [1]. +-- +-- Differences between 'Control.Parallel.HdpH.Closure.Static' and a builtin +-- 'Static' are: +-- o Static values must be declared at toplevel +-- o Static terms must be explicitly named (via 'staticAs') +-- o Static terms must be explicitly declared and registered before use + +{-# OPTIONS_GHC -fno-warn-orphans #-} -- orphan instances unproblematic; types + -- affected either internal or abstract + +module Control.Parallel.HdpH.Closure.Static + ( -- * 'Static' type constructor + Static, -- instances: Eq, Ord, Show, NFData, Serialize + + -- * introducing 'Static' + staticAs, -- :: a -> String -> Static a + + -- * eliminating 'Static' + unstatic, -- :: Static a -> a + + -- * declaring Static terms + StaticDecl, -- instances: Monoid, Show + declare, -- :: Static a -> StaticDecl + + -- * registering a Static declaration in the global Static table + register, -- :: StaticDecl -> IO () + + -- * show contents of the global Static table + showStaticTable -- :: [String] + ) where + +import Prelude +import Control.DeepSeq (NFData(rnf)) +import Control.Exception (evaluate) +import Control.Monad (unless) +import Data.Array (listArray, (!), bounds, elems) +import Data.Bits (shiftL, xor) +import Data.Functor ((<$>)) +import Data.IORef (readIORef, atomicModifyIORef) +import Data.Int (Int32) +import Data.List (foldl') +import qualified Data.Map as Map (empty, singleton, union, unions, keys, elems) +import Data.Monoid (Monoid(mempty, mappend, mconcat)) +import Data.Serialize (Serialize) +import qualified Data.Serialize (put, get) +import System.IO.Unsafe (unsafePerformIO) +import Unsafe.Coerce (unsafeCoerce) + +import Control.Parallel.HdpH.Closure.Static.State (sTblRef) +import Control.Parallel.HdpH.Closure.Static.Type + (StaticLabel(StaticLabel), hash, name, + StaticIndex, + Static(Static), label, index, unstatic, + AnyStatic(Any), + StaticDecl(StaticDecl), unStaticDecl) + + +----------------------------------------------------------------------------- +-- Key facts about 'Static' +-- +-- o We say that a term 't' /captures/ a variable 'x' if 'x' occurs free +-- in 't' and 'x' is not declared at the top-level. (That is, this notion +-- of capture is sensitive to the context.) +-- +-- o We call a term 't' /static/ if it could be declared at the top-level, +-- that is if does not capture any variables. In contrast, we call a +-- term /Static/ if it is of type 'Static t' for some type 't'. +-- +-- o In principle, a term 'stat' of type 'Static t' acts as serialisable +-- reference to a static term of type 't'. However, here we realise +-- terms of type 'Static t' as a triple consisting of such a serialisable +-- reference (an index in the global Static table), a reference name +-- (a unique label of type String) and the refered-to static term itself. +-- +-- o Only the serialisable reference is actually serialised when a Static term +-- 'stat' is serialised. The link between that reference and the associated +-- Static term 'stat' is established by a registry, the /Static table/, +-- mapping indices to /registered/ Static terms. +-- +-- o There are two ways of obtaining a term 'stat :: Static t'. By introducing +-- it with the smart constructor 'staticAs', or by deserialising it. +-- The latter assumes that the Static table has been initialised before +-- and has been initialised identically across all nodes; failing this +-- requirement may result in horrible crashes. +-- +-- o Applications using this module (even indirectly) must go through two +-- distinct phases: +-- (1) Introduce and register all Static terms (of which, by their nature, +-- there can only be a statically bounded number) but do neither +-- serialise nor deserialise any Static terms. +-- (2) Serialise and Deserialise Static terms at will but do not attempt +--- to register any new Static terms. + + +----------------------------------------------------------------------------- +-- How to register Static terms +-- +-- Every module which introduces Static terms via 'staticAs' must export +-- a term 'declareStatic :: StaticDecl' for declaring these terms. The +-- main module must import all these 'declareStatic' terms, concat them +-- to form a global Static declaration, and register that declaration. +-- +-- To demonstrate the simplest example, suppose module 'M1' introduces two +-- Static terms (as top-level variables). +-- +-- > x_Static :: Static Int +-- > x_Static = staticAs 42 "Fully_Qualified_Name_Of_M1.x" +-- > +-- > f_Static :: Static ([a] -> Int) +-- > f_Static = staticAs f "Fully_Qualified_Name_Of_M1.f" +-- > where +-- > f [] = 0 +-- > f (_:xs) = 1 + f xs +-- +-- Then 'M1' ought to export +-- +-- > declareStatic :: StaticDecl +-- > declareStatic = Data.Monoid.mconcat +-- > [declare x_Static, +-- > declare f_Static] +-- +-- Now suppose module 'M3' imports 'M1'. It doesn't matter whether 'M3' +-- imports the Static terms of 'M1' directly; any function exported by +-- 'M1' may depend on its Static terms being registered, so 'M3' must +-- ensure that registration happens. Suppose further that 'M3' also imports +-- a module 'M2' which requires some other Static terms to be registered, +-- and that 'M3' itself introduces a term 'x_Static :: Static Bool' +-- (eg. by 'x_Static = staticAs True "Fully_Qualified_Name_Of_M3.x"). +-- In this case, 'M3' ought to export the following +-- +-- > declareStatic :: StaticDecl +-- > declareStatic = Data.Monoid.mconcat +-- > [M1.declareStatic, +-- > M2.declareStatic, +-- > declare x_Static] +-- +-- Note that 'M2' may import 'M1' and so the definition of 'M2.declareStatic' +-- may contain a call to 'M1.declareStatic', in which case the above 'mconcat' +-- would process the data in 'M1.declareStatic' twice. This is of no concern, +-- thanks to the defintion of 'mconcat', as long as the reference name +-- (the second argument of 'staticAs') of each Static term is unique. +-- +-- The 'Main' module must define a term 'declareStatic', similar to +-- 'M3.declareStatic' above. This term must then be passed to 'register' +-- right at the start of the 'main' action. +-- +-- > main :: IO () +-- > main = do +-- > register declareStatic +-- > ... +-- +-- The module 'Control.Parallel.HdpH.Closure' offers more convenient support +-- for declaring and registering Static terms linked to explicit closures. + + +----------------------------------------------------------------------------- +-- Static terms (abstract outwith this module) +-- +-- NOTE: Static labels are hyperstrict. +-- Static terms are strict in their label part. +-- Static terms are not strict in their index part, the evaluation +-- of which is delayed until the Static term is scrutinised, eg. by +-- comparisons or by serialisation. However, a Static term +-- produced by deserialisation is strict in its index part. + +-- Constructs a 'StaticLabel' out of a name 'nm' (which is usually a fully +-- qualified toplevel variable name). +-- This constructor ensures that the resulting 'StaticLabel' is hyperstrict; +-- this constructor is not to be exported. +-- NOTE: Hyperstrictness is guaranteed by the strictness flags in the data +-- declaration of 'StaticLabel'. For the 'hash' field this already +-- implies full normalisation, computing the hash also fully normalises +-- the 'name' field. +mkStaticLabel :: String -> StaticLabel +mkStaticLabel nm = StaticLabel { hash = hashString nm, name = nm } + + +-- Constructs a Static term referring to the given static value 'val' +-- and identified by the given reference name 'nm'. +-- NOTE: Strictness flag on 'label' forces that field to WHNF (which conincides +-- with NF due to hyperstrictness of 'StaticLabel'). +staticAs :: a -> String -> Static a +staticAs val nm = + Static { label = lbl, index = findIndex lbl, unstatic = val } + where + lbl = mkStaticLabel nm + + +----------------------------------------------------------------------------- +-- Eq/Ord/Show/NFData instances for 'StaticLabel' + +instance Eq StaticLabel where + lbl1 == lbl2 = hash lbl1 == hash lbl2 && -- compare 'hash' first + name lbl1 == name lbl2 + +instance Ord StaticLabel where + compare lbl1 lbl2 = + case compare (hash lbl1) (hash lbl2) of -- compare 'hash' 1st + LT -> LT + GT -> GT + EQ -> compare (name lbl1) (name lbl2) + +instance Show StaticLabel where + showsPrec _ lbl = showString (name lbl) -- show only reference name + +instance NFData StaticLabel -- default inst suffices (due to hyperstrictness) + + +----------------------------------------------------------------------------- +-- Eq/Ord/Show/NFData instances for 'Static'; +-- all of these instance force the 'index' part of a Static term but not the +-- refered-to static term; the 'label' part plays no role except for 'Show'. + +instance Eq (Static a) where + stat1 == stat2 = index stat1 == index stat2 + +instance Ord (Static a) where + stat1 <= stat2 = index stat1 <= index stat2 + +instance Show (Static a) where + showsPrec _ stat = + showString "Static[" . shows (index stat) . showString "]=" . + shows (label stat) + +instance NFData (Static a) where + rnf stat = index stat `seq` () -- forcing 'index' also forces strict 'label' + + +----------------------------------------------------------------------------- +-- Serialize instance for 'Static' + +instance Serialize (Static a) where + put = Data.Serialize.put . index + get = resolve <$> Data.Serialize.get + -- NOTES: + -- o Hyperstrictness is enforced by 'resolve' (and by construction + -- of the Static table). + -- o Serialisation crashes if the Static term is not yet registered. + -- o Deserialisation crashes if the index passed to 'resolve' is + -- out of bounds (but that can only happen when deserialising + -- a bytestring that wasn't generated from a registered Static term). + + +-- Resolves an index obtained from deserialisation into a Static term +-- by accessing the index in the global Static table; assumes that the +-- index is in bounds. +resolve :: StaticIndex -> Static a +resolve i = + case (unsafePerformIO $ readIORef sTblRef) ! i of + Any stat -> unsafeCoerce stat + +-- Why 'unsafeCoerce' in safe in 'resolve': +-- +-- o Static terms can only be introduced by the smart constructor 'staticAs'. +-- +-- o We assume that the 'label' part of a Static term (as constructed by +-- 'staticAs') is a /key/. That is, whenever terms 'stat1 :: Static t1' +-- and 'stat2 :: Static t2' are introduced by 'staticAs' such that +-- 'label stat1 == label stat2' then 'unstatic stat1 :: t1' is identical +-- to 'unstatic stat2 :: t2' (which also implies that the types 't1' and +-- 't2' are identical). This assumption is justified if labels are +-- derived from fully qualified top-level names. +-- +-- o Likewise, we assume that the 'index' part of a Static term is a /key/. +-- This follows from 'label' being a key and from the way the Static table +-- is constructed by 'register'. +-- +-- o Thus, we can safely super-impose (using 'unsafeCoerce') the return type +-- 'Static a' of 'resolve' on the returned Static term. This type will +-- have been dictated by the calling context of 'resolve', ie. by the +-- calling context of deserialisation. + + +----------------------------------------------------------------------------- +-- Operations on existential 'Static' wrapper + +instance Show AnyStatic where + showsPrec _ (Any stat) = shows stat + +instance NFData AnyStatic where + rnf (Any stat) = rnf stat + +getLabel :: AnyStatic -> StaticLabel +getLabel (Any stat) = label stat + +setIndex :: StaticIndex -> AnyStatic -> AnyStatic +setIndex i (Any stat) = Any $ stat { index = i } + + +----------------------------------------------------------------------------- +-- Static declarations (abstract outwith this module) + +-- Promotes the given Static term to a Static declaration (by mapping the +-- label to the Static term, existentially wrapped). +declare :: Static a -> StaticDecl +declare stat = StaticDecl $ Map.singleton (label stat) (Any stat) +-- ^ Promotes a given @'Static'@ reference to a @'Static'@ declaration +-- consisting exactly of the given @'Static'@ reference (and the static term +-- it refers to). +-- See the tutorial below for how to declare @'Static'@ references. + + +-- Static declarations form a monoid, at least if we assume that 'label' +-- is a /key/ for Static terms, ie. distinct Static terms will have +-- distinct labels. Note that this assumption is not checked: If it fails +-- then type safety of deserialisation can be compromised. The 'Static' +-- support in module 'HpdH.Closure', however, should guarantee the above +-- /key property/. +instance Monoid StaticDecl where + mempty = StaticDecl Map.empty + sd1 `mappend` sd2 = StaticDecl (unStaticDecl sd1 `Map.union` unStaticDecl sd2) + mconcat = StaticDecl . Map.unions . map unStaticDecl + + +-- Show instance only for debugging; only shows domain of 'StaticDecl' +instance Show StaticDecl where + showsPrec _ sd = showString "StaticDecl " . + shows (Map.keys $ unStaticDecl sd) + + +----------------------------------------------------------------------------- +-- Static table + +-- | Registers the given @'Static'@ declaration; that is, stores the +-- declaration in the global @'Static'@ /table/. Must be called exactly once, +-- before any operations involving @'Static'@ references (or explicit Closures). +-- See the tutorial below for how to register a @'Static'@ declaration. +register :: StaticDecl -> IO () +register sd = do + let stats = zipWith setIndex [1..] (Map.elems $ unStaticDecl sd) + let table = listArray (1, fromIntegral $ length stats) stats + evaluate (rnf table) -- force table to normal form + ok <- atomicModifyIORef sTblRef $ \ old_table -> + if snd (bounds old_table) < 1 + then (table, True) + else (old_table, False) + unless ok $ + error "Control.Parallel.HdpH.Closure.register: 2nd attempt" + + +-- Converts a Static label into a Static index by means of binary search; +-- not exported and to be called only after registration. +findIndex :: StaticLabel -> StaticIndex +findIndex lbl = search (bounds table) + where + table = unsafePerformIO $ readIORef sTblRef + search (lower, upper) + | lower > upper = error msg + | otherwise = case cmp of + EQ -> i + LT -> search (lower, i - 1) + GT -> search (i + 1, upper) + where + i = (lower + upper) `div` 2 + cmp = compare lbl (getLabel $ table ! i) + msg = "Control.Parallel.HdpH.Closure.Static.findIndex: " ++ + show lbl ++ " not found" + + +-- | Emits the contents of the global @'Static'@ table as a list of Strings, +-- one per entry. Useful for debugging; not to be called prior to registration. +showStaticTable :: [String] +showStaticTable = map show $ elems table + where + table = unsafePerformIO $ readIORef sTblRef + + +----------------------------------------------------------------------------- +-- auxiliary stuff: hashing strings; adapted from Data.Hashable. + +hashStringWithSalt :: Int32 -> String -> Int32 +hashStringWithSalt = foldl' (\ h ch -> h `combine` toEnum (fromEnum ch)) + where + combine :: Int32 -> Int32 -> Int32 + combine h1 h2 = (h1 + h1 `shiftL` 5) `xor` h2 + +-- NOTE: Hashing fully evaluates the String argument as a side effect. +hashString :: String -> Int32 +hashString = hashStringWithSalt defaultSalt + where + defaultSalt = 5381 diff --git a/src/Control/Parallel/HdpH/Closure/Static/State.hs b/src/Control/Parallel/HdpH/Closure/Static/State.hs new file mode 100644 --- /dev/null +++ b/src/Control/Parallel/HdpH/Closure/Static/State.hs @@ -0,0 +1,26 @@ +-- 'Static' support; state +-- +-- Author: Patrick Maier +----------------------------------------------------------------------------- + +{-# OPTIONS_GHC -fno-cse #-} -- to protect unsafePerformIO hack + +module Control.Parallel.HdpH.Closure.Static.State + ( -- * reference to 'Static' declaration + sTblRef -- :: IORef StaticTable + ) where + +import Prelude +import Data.Array (array) +import Data.IORef (IORef, newIORef) +import System.IO.Unsafe (unsafePerformIO) + +import Control.Parallel.HdpH.Closure.Static.Type (StaticTable) + + +----------------------------------------------------------------------------- +-- reference to global static table, initially empty + +sTblRef :: IORef StaticTable +sTblRef = unsafePerformIO $ newIORef $ array (1,0) [] +{-# NOINLINE sTblRef #-} -- required to protect unsafePerformIO hack diff --git a/src/Control/Parallel/HdpH/Closure/Static/Type.hs b/src/Control/Parallel/HdpH/Closure/Static/Type.hs new file mode 100644 --- /dev/null +++ b/src/Control/Parallel/HdpH/Closure/Static/Type.hs @@ -0,0 +1,78 @@ +-- 'Static' support; types +-- +-- Author: Patrick Maier +----------------------------------------------------------------------------- + +{-# LANGUAGE GADTs #-} + +module Control.Parallel.HdpH.Closure.Static.Type + ( -- * 'Static' things (and constituent parts) + Static(..), + StaticLabel(..), + StaticIndex, + + -- * 'Static' declarations and table + StaticDecl(..), + StaticTable, + AnyStatic(..) + ) where + +import Prelude +import Data.Array (Array) +import Data.Int (Int32) +import Data.Map (Map) +import Data.Word (Word32) + + +----------------------------------------------------------------------------- +-- Static things + +-- A Static label consists of a 'name'; additionally, there is 32-bit hash +-- value (for faster comparisons). Note that all fields are strict. +data StaticLabel = StaticLabel { hash :: !Int32, + name :: !String } + + +-- A Static index, that is an index into the global Static table. +type StaticIndex = Word32 + + +-- A term of type 'Static a' (ie. essentially referring to a term of type 'a' +-- not capturing any free variables) is represented as +-- * a Static label, acting as a key, +-- * an index into the global Static table (also acting as a key), and +-- * the referred-to term (in field 'unstatic'). +-- Note that the label is strict but the refereed-to term and the index are not; +-- the evaluation of the index is delayed until serialisation. +data Static a = Static { label :: !StaticLabel, + index :: StaticIndex, + unstatic :: a } +-- ^ A term of type @Static a@ is a serialisable reference to a /static/ term +-- of type @a@. + +-- Existential Static type (wrapper for 'Static t' in heterogenous maps) +data AnyStatic where + Any :: Static a -> AnyStatic + + +----------------------------------------------------------------------------- +-- Static declarations + +-- A Static declaration maps Static labels to Static terms containing +-- selfsame labels. +-- NOTE: Each image stored in 'StaticDecl' is actually of type 'Static a' +-- for some 'a'. However, to fit into the map, we wrap all these types +-- into the existential 'AnyStatic'. +newtype StaticDecl = StaticDecl { unStaticDecl :: Map StaticLabel AnyStatic } +-- ^ A @'Static'@ declaration is a collection of static terms together with +-- their serialisable @'Static'@ references. +-- @'Static'@ declarations form a monoid, and can be combined by methods of +-- class @'Data.Monoid.Monoid'@. + + +----------------------------------------------------------------------------- +-- Static table + +-- Global Static table, mapping static indices to existentially wrapped +-- Static terms. +type StaticTable = Array StaticIndex AnyStatic