ghc/tests/codeGen/should_run/cg026.hs

   1 -- !!! simple tests of primitive arrays
   2 --
   3 module Main ( main ) where
   4
   5 import PrelBase
   6 import ST
   7 import IOExts
   8 import ST
   9 import MutableArray
  10 import ByteArray
  11 import Addr
  12 import Int( Num(fromInt) )
  13 import CString (packString)
  14
  15 import Ratio
  16 import Array
  17
  18 main = putStr
  19          (test_chars    ++ "\n"  ++
  20           test_ints     ++ "\n"  ++
  21           test_addrs    ++ "\n"  ++
  22           test_floats   ++ "\n"  ++
  23           test_doubles  ++ "\n"  ++
  24           test_ptrs     ++ "\n")
  25
  26
  27 -- Arr# Char# -------------------------------------------
  28 -- (main effort is in packString#)
  29
  30 test_chars :: String
  31 test_chars
  32   = let str = reverse "Now is the time for all good men to come to...\n"
  33     in
  34     unsafePerformIO (
  35         _ccall_ fprintf (``stdout''::Addr) (packString "%d %s\n") (93::Int) (packString str) >>
  36         _ccall_ fflush  (``stdout''::Addr)  >>
  37         return ""
  38         )
  39
  40 -- Arr# Int# -------------------------------------------
  41
  42 test_ints :: String
  43 test_ints
  44   = let arr# = f 1000
  45     in
  46         shows (lookup_range arr# 42# 416#) "\n"
  47   where
  48     f :: Int -> ByteArray Int
  49
  50     f size@(I# size#)
  51       = runST (
  52             -- allocate an array of the specified size
  53           newIntArray (0, (size-1))     >>= \ arr# ->
  54
  55             -- fill in all elements; elem i has i^2 put in it
  56           fill_in arr# 0# (size# -# 1#) >>
  57
  58             -- freeze the puppy:
  59           freezeByteArray arr#
  60         )
  61
  62     fill_in :: MutableByteArray s Int -> Int# -> Int# -> ST s ()
  63
  64     fill_in arr_in# first# last#
  65       = if (first# ># last#)
  66         then return ()
  67         else writeIntArray arr_in# (I# first#) (I# (first# *# first#)) >>
  68              fill_in arr_in# (first# +# 1#) last#
  69
  70     lookup_range :: ByteArray Int -> Int# -> Int# -> [Int]
  71     lookup_range arr from# to#
  72       = if (from# ># to#)
  73         then []
  74         else (indexIntArray arr (I# from#))
  75              : (lookup_range arr (from# +# 1#) to#)
  76
  77 -- Arr# Addr# -------------------------------------------
  78
  79 test_addrs :: String
  80 test_addrs
  81   = let arr# = f 1000
  82     in
  83         shows (lookup_range arr# 42# 416#) "\n"
  84   where
  85     f :: Int -> ByteArray Int
  86
  87     f size@(I# size#)
  88       = runST (
  89             -- allocate an array of the specified size
  90           newAddrArray (0, (size-1))    >>= \ arr# ->
  91
  92             -- fill in all elements; elem i has i^2 put in it
  93           fill_in arr# 0# (size# -# 1#) >>
  94
  95             -- freeze the puppy:
  96           freezeByteArray arr#
  97         )
  98
  99     fill_in :: MutableByteArray s Int -> Int# -> Int# -> ST s ()
 100
 101     fill_in arr_in# first# last#
 102       = if (first# ># last#)
 103         then return ()
 104         else writeAddrArray arr_in# (I# first#)
 105                             (A# (int2Addr# (first# *# first#))) >>
 106              fill_in arr_in# (first# +# 1#) last#
 107
 108     lookup_range :: ByteArray Int -> Int# -> Int# -> [ Int ]
 109     lookup_range arr from# to#
 110       = let
 111             a2i (A# a#) = I# (addr2Int# a#)
 112         in
 113         if (from# ># to#)
 114         then []
 115         else (a2i (indexAddrArray arr (I# from#)))
 116              : (lookup_range arr (from# +# 1#) to#)
 117
 118 -- Arr# Float# -------------------------------------------
 119
 120 test_floats :: String
 121 test_floats
 122   = let arr# = f 1000
 123     in
 124         shows (lookup_range arr# 42# 416#) "\n"
 125   where
 126     f :: Int -> ByteArray Int
 127
 128     f size@(I# size#)
 129       = runST (
 130             -- allocate an array of the specified size
 131           newFloatArray (0, (size-1))   >>= \ arr# ->
 132
 133             -- fill in all elements; elem i has "i * pi" put in it
 134           fill_in arr# 0# (size# -# 1#) >>
 135
 136             -- freeze the puppy:
 137           freezeByteArray arr#
 138         )
 139
 140     fill_in :: MutableByteArray s Int -> Int# -> Int# -> ST s ()
 141
 142     fill_in arr_in# first# last#
 143       = if (first# ># last#)
 144         then return ()
 145 {-      else let e = ((fromInt (I# first#)) * pi)
 146              in trace (show e) $ writeFloatArray arr_in# (I# first#) e >>
 147              fill_in arr_in# (first# +# 1#) last#
 148 -}
 149         else writeFloatArray arr_in# (I# first#) ((fromInt (I# first#)) * pi) >>
 150              fill_in arr_in# (first# +# 1#) last#
 151
 152     lookup_range :: ByteArray Int -> Int# -> Int# -> [Float]
 153     lookup_range arr from# to#
 154       = if (from# ># to#)
 155         then []
 156         else (indexFloatArray arr (I# from#))
 157              : (lookup_range arr (from# +# 1#) to#)
 158
 159 -- Arr# Double# -------------------------------------------
 160
 161 test_doubles :: String
 162 test_doubles
 163   = let arr# = f 1000
 164     in
 165         shows (lookup_range arr# 42# 416#) "\n"
 166   where
 167     f :: Int -> ByteArray Int
 168
 169     f size@(I# size#)
 170       = runST (
 171             -- allocate an array of the specified size
 172           newDoubleArray (0, (size-1))  >>= \ arr# ->
 173
 174             -- fill in all elements; elem i has "i * pi" put in it
 175           fill_in arr# 0# (size# -# 1#) >>
 176
 177             -- freeze the puppy:
 178           freezeByteArray arr#
 179         )
 180
 181     fill_in :: MutableByteArray s Int -> Int# -> Int# -> ST s ()
 182
 183     fill_in arr_in# first# last#
 184       = if (first# ># last#)
 185         then return ()
 186         else writeDoubleArray arr_in# (I# first#) ((fromInt (I# first#)) * pi) >>
 187              fill_in arr_in# (first# +# 1#) last#
 188
 189     lookup_range :: ByteArray Int -> Int# -> Int# -> [Double]
 190     lookup_range arr from# to#
 191       = if (from# ># to#)
 192         then []
 193         else (indexDoubleArray arr (I# from#))
 194              : (lookup_range arr (from# +# 1#) to#)
 195
 196 -- Arr# (Ratio Int) (ptrs) ---------------------------------
 197 -- just like Int# test
 198
 199 test_ptrs :: String
 200 test_ptrs
 201   = let arr# = f 1000
 202     in
 203         shows (lookup_range arr# 42 416) "\n"
 204   where
 205     f :: Int -> Array Int (Ratio Int)
 206
 207     f size
 208       = runST (
 209           newSTArray (1, size) (3 % 5)  >>= \ arr# ->
 210           -- don't fill in the whole thing
 211           fill_in arr# 1 400            >>
 212           freezeSTArray arr#
 213         )
 214
 215     fill_in :: STArray s Int (Ratio Int) -> Int -> Int -> ST s ()
 216
 217     fill_in arr_in# first last
 218       = if (first > last)
 219         then return ()
 220         else writeSTArray arr_in# first (fromInt (first * first)) >>
 221              fill_in  arr_in# (first + 1) last
 222
 223     lookup_range :: Array Int (Ratio Int) -> Int -> Int -> [Ratio Int]
 224     lookup_range array from too
 225       = if (from > too)
 226         then []
 227         else (array ! from) : (lookup_range array (from + 1) too)