diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,66 @@ +Copyright for portions of project prim-spoon are held by (c) 2009 Matt Morrow & Dan Peebles as part of project spoon. All other copyright for project are held by (c) 2016 Michael Klein. + +Copyright (c) 2015 Michael Klein +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 name of Matt Morrow or Dan Peebles 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. + + +Copyright (c) 2009 Matt Morrow & Dan Peebles +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 name of Matt Morrow or Dan Peebles 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,20 @@ +#Prim-Spoon + +[![Build Status](https://travis-ci.org/michaeljklein/prim-spoon.png)](https://travis-ci.org/michaeljklein/prim-spoon) + +This is a microproject for the sole purpose of having a high-performance +version of `teaspoon` from [Control.Spoon](http://hackage.haskell.org/package/spoon-0.3.1), using primops. +While it is unsafe, it is as safe as `catch#` and `seq#` from [GHC.Prim](https://hackage.haskell.org/package/ghc-prim-0.4.0.0/candidate/docs/GHC-Prim.html). +(I'd look into how safe those are, but they're hidden in GHC's source and that _really_ seems like overkill.) + +Current [benchmarks](https://rawgit.com/michaeljklein/prim-spoon/master/benchmarks.html) +suggest that `primspoon` takes about 3x as long as a function call on non-error +throwing values and about 5x as long to catch an error and return `Nothing`. +This is an improvment over `teaspoon`, which takes about 4x as long as a +function call on a non-error value and about 21x to catch an error. + +Why bother? Three reasons: + +1. This is my first experience with digging into primops in Haskell for performance, and it was a good exercise. +2. I had begun to roll my own solution before I found `Control.Spoon` and wanted to benchmark several different solutions (for example, `makeStableName`). +3. I was curious how `unsafePerformIO` affects performance. It turns out that it takes longer than I expected, but it makes some sense as it's not the best thing to spend time optimizing. 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/bench/Bench/Control/Spoon/Prim.hs b/bench/Bench/Control/Spoon/Prim.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/Control/Spoon/Prim.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} + +module Bench.Control.Spoon.Prim (benchControlSpoonPrim) where + + +import Criterion.Main +import Control.Spoon (teaspoon) +import GHC.Prim (RealWorld, State#, catch#, realWorld#, seq#) +import Control.Spoon.Prim +import System.IO.Unsafe (unsafeDupablePerformIO) +import System.Mem.StableName + +-- | Control mehod for benchmarking (appx. lower bound for a functional solution) +justToJust :: Maybe a -> Maybe (Maybe a) +justToJust y@(Just _) = Just y +justToJust Nothing = Nothing + +-- | Control method for benchmarking (appx. lower bound for output of a function) +catchMethod0 :: a -> Bool +catchMethod0 = const False + +unpackMaybe :: (# State# RealWorld, Maybe a #) -> Maybe a +unpackMaybe (# _, x #) = x + +-- | This, and the following methods, are used for comparison to ensure the +-- prim-spoon methods are high-performance +catchMethod1 :: a -> Maybe a +{-# INLINE catchMethod1 #-} +catchMethod1 x = let r = realWorld# in let (# _, v #) = catch# (\s -> let (# t, y #) = (seq# x) s in (# t, Just y #)) (\_ _ -> (# r, Nothing #)) r in v + +catchMethod2 :: a -> Maybe a +{-# INLINE catchMethod2 #-} +catchMethod2 x = unpackMaybe (catch# ((\f s -> (\(# t, y #) -> (# t, Just y #)) (f s)) (seq# x)) (\_ _ -> (# realWorld#, Nothing #)) realWorld#) + +catchMethod3 :: a -> Maybe a +{-# INLINE catchMethod3 #-} +catchMethod3 x = (\(# _, v #) -> v) (catch# ((\f s -> (\(# t, y #) -> (# t, Just y #)) (f s)) (seq# x)) (\_ _ -> (# realWorld#, Nothing #)) realWorld#) + +catchMethod4 :: a -> Maybe a +{-# INLINE catchMethod4 #-} +catchMethod4 x = let r = realWorld# in (\(# _, v #) -> v) (catch# ((\f s -> (\(# t, y #) -> (# t, Just y #)) (f s)) (seq# x)) (\_ _ -> (# r, Nothing #)) r) + +catchMethod5 :: a -> Maybe a +{-# INLINE catchMethod5 #-} +catchMethod5 x = (\(# _, v #) -> v) (catch# ((\f s -> (\(# t, y #) -> (# t, Just y #)) (f s)) (seq# x)) (\_ _ -> (# realWorld#, Nothing #)) realWorld#) + +-- | This method *only* supports `Prelude.undefined` as the thrown error +-- (`unsafeDupablePerformIO` doesn't work with parallelism, but neither +-- does `makeStableName` +catchMethod6 :: a -> Maybe a +{-# INLINE catchMethod6 #-} +catchMethod6 x = if eqStableName undefName . unsafeDupablePerformIO . makeStableName $ x + then Nothing + else Just x + where + undefName :: forall t. StableName t + undefName = unsafeDupablePerformIO . makeStableName $ undefined + +-- | Benchmark the different options, with controls for comparison +benchControlSpoonPrim :: [Benchmark] +benchControlSpoonPrim = [ + bgroup "teaspoon " [ bench "Check undefined" $ whnf teaspoon undefined + , bench "Check defined" $ whnf teaspoon False + ], + bgroup "const (control) " [ bench "Check undefined" $ whnf catchMethod0 undefined + , bench "Check defined" $ whnf catchMethod0 False + ], + bgroup "Just (control) " [ + bench "Check defined" $ whnf Just False + ], + bgroup "justToJust (control)" [ bench "check Nothing " $ whnf justToJust Nothing + , bench "Check Just " $ whnf Just False + ], + bgroup "catchMethod1 " [ bench "Check undefined" $ whnf catchMethod1 undefined + , bench "Check defined" $ whnf catchMethod1 False + ], + bgroup "catchMethod2 " [ bench "Check undefined" $ whnf catchMethod2 undefined + , bench "Check defined" $ whnf catchMethod2 False + ], + bgroup "catchMethod3 " [ bench "Check undefined" $ whnf catchMethod3 undefined + , bench "Check defined" $ whnf catchMethod3 False + ], + bgroup "catchMethod4 " [ bench "Check undefined" $ whnf catchMethod4 undefined + , bench "Check defined" $ whnf catchMethod4 False + ], + bgroup "catchMethod5 " [ bench "Check undefined" $ whnf catchMethod5 undefined + , bench "Check defined" $ whnf catchMethod5 False + ], + bgroup "catchMethod6 " [ bench "Check undefined" $ whnf catchMethod6 undefined + , bench "Check defined" $ whnf catchMethod6 False + ], + bgroup "primspoon " [ bench "Check undefined" $ whnf primspoon undefined + , bench "Check defined" $ whnf primspoon False + ]] + diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import Bench.Control.Spoon.Prim (benchControlSpoonPrim) +import Criterion.Main (defaultMain ) + +main :: IO () +main = defaultMain . concat $ [ benchControlSpoonPrim + ] diff --git a/prim-spoon.cabal b/prim-spoon.cabal new file mode 100644 --- /dev/null +++ b/prim-spoon.cabal @@ -0,0 +1,64 @@ +name: prim-spoon +version: 0.1.0 +license: BSD3 +license-file: LICENSE +author: Michael Klein +maintainer: Michael Klein +homepage: https://github.com/michaeljklein/prim-spoon +stability: experimental +category: Error handling +synopsis: Catch errors thrown from pure computations using primops. +copyright: 2016 Michael Klein, portions also licensed to: 2009 Matt Morrow & Dan Peebles, 2013 Liyang HU +description: Takes an error-throwing expression and puts it back in the Maybe it belongs in, but with primops. +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: README.md + +library + hs-source-dirs: src + build-depends: base >= 4.7 && < 5 + , ghc-prim >= 0.3.1.0 + , spoon >= 0.3 + exposed-modules: Control.Spoon.Prim + ghc-options: -Wall -funbox-strict-fields + default-language: Haskell2010 + default-extensions: MagicHash + , RankNTypes + , ScopedTypeVariables + , UnboxedTuples + , Unsafe + +benchmark prim-spoon-bench + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Main.hs + build-depends: base + , criterion >= 1.1.0.0 && < 1.2.0.0 + , ghc-prim >= 0.3.1.0 + , prim-spoon + , spoon >= 0.3.1 + other-modules: Bench.Control.Spoon.Prim + ghc-options: -Wall -funbox-strict-fields + default-language: Haskell2010 + default-extensions: MagicHash + , RankNTypes + , ScopedTypeVariables + , UnboxedTuples + , Unsafe + +test-suite prim-spoon-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , HUnit >= 1.2.5.2 + , spoon >= 0.3.1 + , prim-spoon + , QuickCheck >= 2.7.6 + other-modules: Test.Control.Spoon.Prim + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/michaeljklein/prim-spoon.git diff --git a/src/Control/Spoon/Prim.hs b/src/Control/Spoon/Prim.hs new file mode 100644 --- /dev/null +++ b/src/Control/Spoon/Prim.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE Unsafe #-} + +{-| +Module : Control.Spoon.Prim +Description : This is the main module for prim-spoon +Copyright : (c) Michael Klein, 2016 +License : GPL-3 +Maintainer : lambdamichael@gmail.com +Stability : experimental + + This module exports `primspoon`. If you want the other + spoon functions, you'll need "Control.Spoon". +-} + +module Control.Spoon.Prim (primspoon) where + +import GHC.Prim (RealWorld, State#, catch#, realWorld#, seq#) +import Prelude (Maybe(..)) + +-- | This function takes an exception and a `State#` `RealWorld`, returning the output of `realWorld#` and `Nothing` +exceptionToNothing :: a -> State# RealWorld -> (forall b. (# State# RealWorld, Maybe b #)) +{-# INLINE exceptionToNothing #-} +exceptionToNothing _ _ = (# realWorld#, Nothing #) + +-- | Evaluate a value to weak-head normal form and return Nothing if any exceptions are thrown during evaluation. For any error-free value, @primspoon = Just@. +primspoon :: a -> Maybe a +{-# INLINE primspoon #-} +primspoon x = (\(# _, v #) -> v) (catch# ((\f s -> (\(# t, y #) -> (# t, Just y #)) (f s)) (seq# x)) exceptionToNothing realWorld#) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,12 @@ +module Main where + +import Test.Control.Spoon.Prim (testControlSpoonPrim) +import Test.HUnit + +doTests :: [[Test]] -> IO () +doTests ts = print =<< (runTestTT. test . concat) ts + +main :: IO () +main = doTests [ testControlSpoonPrim + ] + diff --git a/test/Test/Control/Spoon/Prim.hs b/test/Test/Control/Spoon/Prim.hs new file mode 100644 --- /dev/null +++ b/test/Test/Control/Spoon/Prim.hs @@ -0,0 +1,24 @@ +module Test.Control.Spoon.Prim where + +import Control.Spoon (teaspoon ) +import Control.Spoon.Prim (primspoon ) +import Test.HUnit +import Test.QuickCheck (quickCheck) + +testIsJust :: (Int -> Maybe Int) -> Test +testIsJust f = test $ quickCheck (\x -> Just x == f x) + +testTeaspoon :: Test +testTeaspoon = test [ "Test teaspoon for undefined" ~: Nothing ~=? teaspoon (undefined :: Int), + "Test teaspoon for defined " ~: testIsJust teaspoon + ] + +testPrimspoon :: Test +testPrimspoon = test [ "Test primspoon for undefined" ~: Nothing ~=? primspoon (undefined :: Int), + "Test primspoon for defined " ~: testIsJust primspoon + ] + +testControlSpoonPrim :: [Test] +testControlSpoonPrim = [ testTeaspoon + , testPrimspoon + ]