[commit: ghc] master: Implement amap/coerce for Array (re #9796) (603b7be)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/603b7be7bd3abaf0e2c210e8d9015b1d613b4715/ghc

>---------------------------------------------------------------

commit 603b7be7bd3abaf0e2c210e8d9015b1d613b4715
Author: David Feuer <David.Feuer at gmail.com>
Date:   Thu Nov 13 21:12:05 2014 +0100

    Implement amap/coerce for Array (re #9796)
    
    Implement an `amap`/`coerce` rule in `GHC.Arr` to match the
    `map`/`coerce` rule in GHC.Base.
    
    In order to do so, delay inlining `amap` until phase 1.
    
    To prevent the inlining delay from causing major inefficiencies due to
    missed list fusion, rewrite `amap` to avoid relying on list fusion. This
    has the extra benefit of reducing the size of the compiled amap code by
    skipping the impossible case of an array with a negative size.
    
    Reviewed By: nomeata
    
    Differential Revision: https://phabricator.haskell.org/D471


>---------------------------------------------------------------

603b7be7bd3abaf0e2c210e8d9015b1d613b4715
 libraries/base/GHC/Arr.hs                          | 40 ++++++++++++++++++++--
 .../should_run/{T2110.hs => AmapCoerce.hs}         | 15 ++++----
 .../should_run/{T2110.stdout => AmapCoerce.stdout} |  0
 testsuite/tests/simplCore/should_run/all.T         |  1 +
 4 files changed, 46 insertions(+), 10 deletions(-)

diff --git a/libraries/base/GHC/Arr.hs b/libraries/base/GHC/Arr.hs
index 67702ea..02bf7d8 100644
--- a/libraries/base/GHC/Arr.hs
+++ b/libraries/base/GHC/Arr.hs
@@ -704,10 +704,44 @@ unsafeAccum f arr ies = runST (do
     STArray l u n marr# <- thawSTArray arr
     ST (foldr (adjust f marr#) (done l u n marr#) ies))
 
-{-# INLINE amap #-}
+{-# INLINE [1] amap #-}
 amap :: Ix i => (a -> b) -> Array i a -> Array i b
-amap f arr@(Array l u n _) =
-    unsafeArray' (l,u) n [(i, f (unsafeAt arr i)) | i <- [0 .. n - 1]]
+amap f arr@(Array l u n@(I# n#) _) = runST (ST $ \s1# ->
+    case newArray# n# arrEleBottom s1# of
+        (# s2#, marr# #) ->
+          let go i s#
+                | i == n    = done l u n marr# s#
+                | otherwise = fill marr# (i, f (unsafeAt arr i)) (go (i+1)) s#
+          in go 0 s2# )
+
+{-
+amap was originally defined like this:
+
+ amap f arr@(Array l u n _) =
+     unsafeArray' (l,u) n [(i, f (unsafeAt arr i)) | i <- [0 .. n - 1]]
+
+There are two problems:
+
+1. The enumFromTo implementation produces (spurious) code for the impossible
+case of n<0 that ends up duplicating the array freezing code.
+
+2. This implementation relies on list fusion for efficiency. In order to
+implement the amap/coerce rule, we need to delay inlining amap until simplifier
+phase 1, which is when the eftIntList rule kicks in and makes that impossible.
+-}
+
+
+-- See Breitner, Eisenberg, Peyton Jones, and Weirich, "Safe Zero-cost
+-- Coercions for Haskell", section 6.5:
+--   http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/coercible.pdf
+{-# RULES
+"amap/coerce" amap coerce = coerce
+ #-}
+
+-- Second functor law:
+{-# RULES
+"amap/amap" forall f g a . amap f (amap g a) = amap (f . g) a
+ #-}
 
 -- | 'ixmap' allows for transformations on array indices.
 -- It may be thought of as providing function composition on the right
diff --git a/testsuite/tests/simplCore/should_run/T2110.hs b/testsuite/tests/simplCore/should_run/AmapCoerce.hs
similarity index 54%
copy from testsuite/tests/simplCore/should_run/T2110.hs
copy to testsuite/tests/simplCore/should_run/AmapCoerce.hs
index 610be09..01a9a5d 100644
--- a/testsuite/tests/simplCore/should_run/T2110.hs
+++ b/testsuite/tests/simplCore/should_run/AmapCoerce.hs
@@ -2,15 +2,16 @@
 
 import GHC.Exts
 import Unsafe.Coerce
+import Data.Array
 
 newtype Age = Age Int
 
-fooAge :: [Int] -> [Age]
-fooAge = map Age
-fooCoerce :: [Int] -> [Age]
-fooCoerce = map coerce
-fooUnsafeCoerce :: [Int] -> [Age]
-fooUnsafeCoerce = map unsafeCoerce
+fooAge :: Array Int Int -> Array Int Age
+fooAge = fmap Age
+fooCoerce :: Array Int Int -> Array Int Age
+fooCoerce = fmap coerce
+fooUnsafeCoerce :: Array Int Int -> Array Int Age
+fooUnsafeCoerce = fmap unsafeCoerce
 
 same :: a -> b -> IO ()
 same x y = case reallyUnsafePtrEquality# (unsafeCoerce x) y of
@@ -18,7 +19,7 @@ same x y = case reallyUnsafePtrEquality# (unsafeCoerce x) y of
     _  -> putStrLn "no"
 
 main = do
-    let l = [1,2,3]
+    let l = listArray (1,3) [1,2,3]
     same (fooAge l) l
     same (fooCoerce l) l
     same (fooUnsafeCoerce l) l
diff --git a/testsuite/tests/simplCore/should_run/T2110.stdout b/testsuite/tests/simplCore/should_run/AmapCoerce.stdout
similarity index 100%
copy from testsuite/tests/simplCore/should_run/T2110.stdout
copy to testsuite/tests/simplCore/should_run/AmapCoerce.stdout
diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T
index 93dc4c6..364dfd6 100644
--- a/testsuite/tests/simplCore/should_run/all.T
+++ b/testsuite/tests/simplCore/should_run/all.T
@@ -53,6 +53,7 @@ test('T5441', extra_clean(['T5441a.o','T5441a.hi']),
               multimod_compile_and_run, ['T5441',''])
 test('T5603', normal, compile_and_run, [''])
 test('T2110', normal, compile_and_run, [''])
+test('AmapCoerce', normal, compile_and_run, [''])
 
 # Run these tests *without* optimisation too
 test('T5625', [ only_ways(['normal','optasm']), exit_code(1) ], compile_and_run, [''])