Initial check-in master
authorJoachim Breitner <mail@joachim-breitner.de>
Thu, 15 Aug 2013 09:26:03 +0000 (09:26 +0000)
committerJoachim Breitner <mail@joachim-breitner.de>
Thu, 15 Aug 2013 09:26:03 +0000 (09:26 +0000)
LICENSE [new file with mode: 0644]
Setup.hs [new file with mode: 0644]
ghc-deepseq.cabal [new file with mode: 0644]
src/GHC/DeepSeq.hs [new file with mode: 0644]

diff --git a/LICENSE b/LICENSE
new file mode 100644 (file)
index 0000000..2a93d81
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2013, Joachim Breitner
+
+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 Joachim Breitner 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/Setup.hs b/Setup.hs
new file mode 100644 (file)
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/ghc-deepseq.cabal b/ghc-deepseq.cabal
new file mode 100644 (file)
index 0000000..b44e679
--- /dev/null
@@ -0,0 +1,25 @@
+name:                ghc-deepseq
+version:             0.1.0.0
+synopsis:            Typeclassless deepseq
+description:         This library provides a 'deepseq' function that works
+                     without a typeclass, by inspecting the actual heap
+                     contents.
+license:             BSD3
+license-file:        LICENSE
+author:              Joachim Breitner
+maintainer:          Joachim Breitner <mail@joachim-breitner.de>
+copyright:           2013 Joachim Breitner
+category:            Control
+build-type:          Simple
+cabal-version:       >=1.8
+
+library
+  exposed-modules:
+    GHC.DeepSeq 
+  build-depends:
+    base == 4.5.* || == 4.6.*,
+    ghc-heap-view == 0.5.*
+  Hs-source-dirs:
+    src/
+  Ghc-options:
+    -Wall
diff --git a/src/GHC/DeepSeq.hs b/src/GHC/DeepSeq.hs
new file mode 100644 (file)
index 0000000..9283566
--- /dev/null
@@ -0,0 +1,47 @@
+{-|
+Module      :  GHC.DeepSeq
+Copyright   :  (c) 2013 Joachim Breitner
+License     :  BSD3
+Maintainer  :  Joachim Breitner <mail@joachim-breitner.de>
+
+A generic version of 'deepseq' that investigates the heap structure.
+-}
+
+
+module GHC.DeepSeq where
+
+import GHC.HeapView
+import Control.Monad
+import System.IO.Unsafe
+
+evalBox :: Box -> IO ()
+evalBox (Box a) = a `seq` return ()
+
+needsEval :: Closure -> IO Bool
+needsEval c = do
+    case c of
+        ThunkClosure {}    -> return True 
+        APClosure {}       -> return True
+        IndClosure {}      -> getBoxedClosureData (indirectee c) >>= needsEval
+        SelectorClosure {} -> return True
+        _                  -> return False
+
+isConstructor :: Closure -> Bool
+isConstructor (ConsClosure {}) = True
+isConstructor _ = False
+
+
+deepEval :: Box -> IO ()
+deepEval b = do
+    c <- getBoxedClosureData b
+    evalNeeded <- needsEval c
+    when evalNeeded $ evalBox b
+    when (isConstructor c) $ do
+        c' <- getBoxedClosureData b
+        mapM_ deepEval (allPtrs c')
+
+deepseq :: a -> b -> b
+deepseq v x = unsafePerformIO $ do
+    deepEval (asBox v)
+    return x
+