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