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