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