From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001 From: Yale AI Dept Date: Wed, 14 Jul 1993 13:08:00 -0500 Subject: Import to github. --- progs/prelude/PreludeArray.hs | 201 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 201 insertions(+) create mode 100644 progs/prelude/PreludeArray.hs (limited to 'progs/prelude/PreludeArray.hs') diff --git a/progs/prelude/PreludeArray.hs b/progs/prelude/PreludeArray.hs new file mode 100644 index 0000000..a501631 --- /dev/null +++ b/progs/prelude/PreludeArray.hs @@ -0,0 +1,201 @@ +module PreludeArray ( Array, Assoc((:=)), array, listArray, (!), bounds, + indices, elems, assocs, accumArray, (//), accum, amap, + ixmap + ) where + +{-#Prelude#-} -- Indicates definitions of compiler prelude symbols + +-- This module uses some simple techniques with updatable vectors to +-- avoid vector copying in loops where single threading is obvious. +-- This is rather fragile and depends on the way the compiler handles +-- strictness. + +import PreludeBltinArray + +infixl 9 ! +infixl 9 // +infix 1 := + +data Assoc a b = a := b deriving (Eq, Ord, Ix, Text, Binary) +data (Ix a) => Array a b = MkArray (a,a) {-#STRICT#-} + (Vector (Box b)) {-#STRICT#-} + deriving () + +array :: (Ix a) => (a,a) -> [Assoc a b] -> Array a b +listArray :: (Ix a) => (a,a) -> [b] -> Array a b +(!) :: (Ix a) => Array a b -> a -> b +bounds :: (Ix a) => Array a b -> (a,a) +indices :: (Ix a) => Array a b -> [a] +elems :: (Ix a) => Array a b -> [b] +assocs :: (Ix a) => Array a b -> [Assoc a b] +accumArray :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [Assoc a c] + -> Array a b +(//) :: (Ix a) => Array a b -> [Assoc a b] -> Array a b +accum :: (Ix a) => (b -> c -> b) -> Array a b -> [Assoc a c] + -> Array a b +amap :: (Ix a) => (b -> c) -> Array a b -> Array a c +ixmap :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c + -> Array a c + +-- Arrays are a datatype containing a bounds pair and a vector of values. +-- Uninitialized array elements contain an error value. + +-- Primitive vectors now contain only unboxed values. This permits us to +-- treat array indexing as an atomic operation without forcing the element +-- being accessed. The boxing and unboxing of array elements happens +-- explicitly using these operations: + +data Box a = MkBox a +unBox (MkBox x) = x +{-# unBox :: Inline #-} + + +-- Array construction and update using index/value associations share +-- the same helper function. + +array b@(bmin, bmax) ivs = + let size = (index b bmax) + 1 + v = primMakeVector size uninitializedArrayError + in (MkArray b (updateArrayIvs b v ivs)) +{-# array :: Inline #-} + +a@(MkArray b v) // ivs = + let v' = primCopyVector v + in (MkArray b (updateArrayIvs b v' ivs)) +{-# (//) :: Inline #-} + +updateArrayIvs b v ivs = + let g (i := x) next = strict1 (primVectorUpdate v (index b i) (MkBox x)) + next + in foldr g v ivs +{-# updateArrayIvs :: Inline #-} + +uninitializedArrayError = + MkBox (error "(!){PreludeArray}: uninitialized array element.") + + +-- when mapping a list onto an array, be smart and don't do full index +-- computation + +listArray b@(bmin, bmax) vs = + let size = (index b bmax) + 1 + v = primMakeVector size uninitializedArrayError + in (MkArray b (updateArrayVs size v vs)) +{-# listArray :: Inline #-} + +updateArrayVs size v vs = + let g x next j = if (j == size) + then v + else strict1 (primVectorUpdate v j (MkBox x)) + (next (j + 1)) + in foldr g (\ _ -> v) vs 0 +{-# updateArrayVs :: Inline #-} + + +-- Array access + +a@(MkArray b v) ! i = unBox (primVectorSel v (index b i)) +{-# (!) :: Inline #-} + +bounds (MkArray b _) = b + +indices = range . bounds + + +-- Again, when mapping array elements into a list, be smart and don't do +-- the full index computation for every element. + +elems a@(MkArray b@(bmin, bmax) v) = + build (\ c n -> + let size = (index b bmax) + 1 + g j = if (j == size) + then n + else c (unBox (primVectorSel v j)) (g (j + 1)) + -- This strict1 is so size doesn't get inlined and recomputed + -- at every iteration. It should also force the array argument + -- to be strict. + in strict1 size (g 0)) +{-# elems :: Inline #-} + +assocs a@(MkArray b@(bmin, bmax) v) = + build (\ c n -> + let g i next j = let y = unBox (primVectorSel v j) + in c (i := y) (next (j + 1)) + in foldr g (\ _ -> n) (range b) 0) +{-# assocs :: Inline #-} + + +-- accum and accumArray share the same helper function. The difference is +-- that accum makes a copy of an existing array and accumArray creates +-- a new one with all elements initialized to the given value. + +accum f a@(MkArray b v) ivs = + let v' = primCopyVector v + in (MkArray b (accumArrayIvs f b v' ivs)) +{-# accum :: Inline #-} + +accumArray f z b@(bmin, bmax) ivs = + let size = (index b bmax) + 1 + v = primMakeVector size (MkBox z) + in (MkArray b (accumArrayIvs f b v ivs)) +{-# accumArray :: Inline #-} + + +-- This is a bit tricky. We need to force the access to the array element +-- before the update, but not force the thunk that is the value of the +-- array element unless f is strict. + +accumArrayIvs f b v ivs = + let g (i := x) next = + let j = index b i + y = primVectorSel v j + in strict1 + y + (strict1 (primVectorUpdate v j (MkBox (f (unBox y) x))) + next) + in foldr g v ivs +{-# accumArrayIvs :: Inline #-} + + +-- again, be smart and bypass full array indexing on array mapping + +amap f a@(MkArray b@(bmin, bmax) v) = + let size = (index b bmax) + 1 + v' = primMakeVector size uninitializedArrayError + g j = if (j == size) + then v' + else let y = primVectorSel v j + in strict1 (primVectorUpdate v' j (MkBox (f (unBox y)))) + (g (j + 1)) + in (MkArray b (g 0)) +{-# amap :: Inline #-} + + +-- can't bypass the index computation here since f needs it as an argument + +ixmap b f a = array b [i := a ! f i | i <- range b] +{-# ixmap :: Inline #-} + + +-- random other stuff + +instance (Ix a, Eq b) => Eq (Array a b) where + a == a' = assocs a == assocs a' + +instance (Ix a, Ord b) => Ord (Array a b) where + a <= a' = assocs a <= assocs a' + +instance (Ix a, Text a, Text b) => Text (Array a b) where + showsPrec p a = showParen (p > 9) ( + showString "array " . + shows (bounds a) . showChar ' ' . + shows (assocs a) ) + + readsPrec p = readParen (p > 9) + (\r -> [(array b as, u) | ("array",s) <- lex r, + (b,t) <- reads s, + (as,u) <- reads t ] + ++ + [(listArray b xs, u) | ("listArray",s) <- lex r, + (b,t) <- reads s, + (xs,u) <- reads t ]) -- cgit v1.2.3