[add real array support to -fvia-ghc mode
John Meacham <john@repetae.net>**20061115071015] hunk ./E/ToHs.hs 121
-    builtIns = [tc_Int,tc_Char,dc_Int,dc_Char,rt_int,rt_HsChar,tc_World__,rt_HsPtr]
+    builtIns = [tc_Int,tc_Char,dc_Int,dc_Char,rt_int,rt_HsChar,tc_World__,tc_Array__,tc_MutArray__,rt_HsPtr]
hunk ./E/ToHs.hs 158
+showCon c [a] | c == tc_Array__ = parens $ text "Array__" <+> a
+showCon c [a] | c == tc_MutArray__ = parens $ text "MutArray__" <+> a
hunk ./E/ToHs.hs 260
-    ("catch__",args)    -> mparen $ mapM transE args >>= \args' -> return $ hsep (text "catch#":args')
-    ("raiseIO__",args)  -> mparen $ mapM transE args >>= \args' -> return $ hsep (text "raiseIO#":args')
-    ("newRef__",args)   -> mparen $ mapM transE args >>= \args' -> return $ hsep (text "newMVar#":args')
-    ("readRef__",args)  -> mparen $ mapM transE args >>= \args' -> return $ hsep (text "readMutVar#":args')
-    ("writeRef__",args) -> mparen $ mapM transE args >>= \args' -> return $ hsep (text "writeMutVar#":args')
-    ("alloca__",args)   -> mparen $ mapM transE args >>= \args' -> return $ hsep (text "alloca__":args')
+    (fs,args) | Just ghcprim <- lookup fs ghcPrimTable -> mparen $ mapM transE args >>= \args' -> return $ hsep (text ghcprim:args')
hunk ./E/ToHs.hs 289
+ghcPrimTable = [
+    ("newWorld__","newWorld__"),
+    ("catch__","catch#"),
+    ("raiseIO__","raiseIO#"),
+    ("newRef__","newMVar#"),
+    ("readRef__","readMutVar#"),
+    ("writeRef__","writeMutVar#"),
+    ("newMutArray__","newArray#"),
+    ("readArray__","readArray#"),
+    ("writeArray__","writeArray#"),
+    ("indexArray__","indexArray#"),
+    ("unsafeFreezeArray__","unsafeFreezeArray#"),
+    ("alloca__","alloca__")
+    ]
+
+
hunk ./Name/Names.hs 81
+tc_Array__ = toName TypeConstructor  ("Jhc.Array","Array__")
+tc_MutArray__ = toName TypeConstructor  ("Jhc.Array","MutArray__")
hunk ./data/ViaGhc.hs 10
+type Array__ a = Array# a
+type MutArray__ a = MutableArray# RealWorld a
hunk ./data/ViaGhc.hs 55
+{-# NOINLINE newWorld__ #-}
+newWorld__ :: a -> World__
+newWorld__ a = case lazy a of
+    _ -> realWorld#
+
hunk ./data/ViaGhc.hs 62
+
hunk ./lib/base/Jhc/Array.hs 1
-{-# OPTIONS_JHC -N #-}
-module Jhc.Array(
-    Array__(),
-    AT(),
-    seqAT__,
-    doneAT__,
-    newAT__,
-    writeAT__,
-    unsafeAt__,
-    newArray
-    )
-    where
+{-# OPTIONS_JHC -N -funboxed-tuples #-}
+module Jhc.Array where
hunk ./lib/base/Jhc/Array.hs 5
-import Jhc.IO(dependingOn)
+import Jhc.IO
hunk ./lib/base/Jhc/Array.hs 8
--- The internal array type
-data Array__ :: * -> #
-
--- the built-in array quasi-monad
-newtype AT a = AT (Array__ a -> Array__ a)
-
-seqAT__ :: AT a -> AT a -> AT a
-seqAT__ (AT a1) (AT a2) = AT $ \a -> case a1 a of
-    a' -> a2 a'
-
-doneAT__ :: AT a
-doneAT__ = AT (\arr -> arr)
+type UIO a = World__ -> (# World__, a #)
+type UIO_ = World__ -> World__
hunk ./lib/base/Jhc/Array.hs 11
-newAT__ :: Int -> AT a -> Array__ a
-newAT__ n (AT a1) = case unboxInt (n `dependingOn` a1) of
-    nn -> case prim_newAT__ nn of a' -> a1 a'
-
-writeAT__ :: Int -> a -> AT a
-writeAT__ i x = case unboxInt i of i' -> prim_writeAT__ i' x
-
--- none of these routines have run-time checks
-foreign import primitive prim_newAT__ :: Int__ -> Array__ a
-foreign import primitive prim_writeAT__ :: Int__ -> a -> AT a
---foreign import primitive prim_copyAT__ :: Int__ -> Int__ -> Array__ a -> AT a
-
--- lookup a value in an array
-foreign import primitive unsafeAt__ :: Array__ a -> Int__ -> a
hunk ./lib/base/Jhc/Array.hs 12
+data MutArray__ :: * -> #
+data Array__ :: * -> #
hunk ./lib/base/Jhc/Array.hs 15
+foreign import primitive newMutArray__      :: Int__ -> a -> UIO (MutArray__ a)
+foreign import primitive newBlankMutArray__ :: Int__ -> UIO (MutArray__ a)
+foreign import primitive copyArray__        :: Int__ -> Int__ -> Int__ -> Array__ a -> MutArray__ a -> UIO_
+foreign import primitive copyMutArray__     :: Int__ -> Int__ -> Int__ -> MutArray__ a -> MutArray__ a -> UIO_
+foreign import primitive readArray__        :: MutArray__ a -> Int__ -> IO a
+foreign import primitive writeArray__       :: MutArray__ a -> Int__ -> a -> UIO_
+foreign import primitive indexArray__       :: Array__ a -> Int__ -> (# a #)
hunk ./lib/base/Jhc/Array.hs 23
---newArray :: [a] -> Array__ a
---newArray xs = newAT__ (length xs) $ foldr assign doneAT__ (zip [0..] xs) where
---    assign (i,v) rs = writeAT__ i v `seqAT__` rs
+-- these basically cast from a mutable to an immutable array and back again
+foreign import primitive unsafeFreezeArray__ :: MutArray__ a -> UIO (Array__ a)
+foreign import primitive unsafeThawArray__ :: Array__ a -> UIO (MutArray__ a)
hunk ./lib/base/Jhc/Array.hs 27
-newArray :: Int -> [(Int,a)] -> Array__ a
-newArray n xs = newAT__ n (foldr assign doneAT__ xs) where
-        assign (i,v) rs = writeAT__ i v `seqAT__` rs
+foreign import primitive newWorld__ :: a -> World__
hunk ./lib/base/Jhc/Array.hs 29
+newArray :: a -> Int -> [(Int,a)] -> Array__ a
+newArray init n xs = case unboxInt n of
+    n' -> case newWorld__ (init,n,xs) of
+     w -> case newMutArray__ n' init w of
+      (# w, arr #) -> let
+        f :: MutArray__ a -> World__ -> [(Int,a)] -> Array__ a
+        f arr w [] = case unsafeFreezeArray__ arr w  of (# _, r #) -> r
+        f arr w ((i,v):xs) = case unboxInt i of i' -> case writeArray__ arr i' v w of w -> f arr w xs
+            in f arr w xs
hunk ./lib/base/Jhc/Array.hs 39
-{-
-newArray :: Int -> [a] -> Array__ a
-newArray n xs = case unboxInt n of
-    un -> newAT__ un $ f zero__ xs where
-        f _ [] = doneAT__
-        f n (x:xs) = case increment__ n of nn -> writeAT__ n x `seqAT__` f nn xs
--}