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