diff --git a/Data/Array/Accelerate.hs b/Data/Array/Accelerate.hs
--- a/Data/Array/Accelerate.hs
+++ b/Data/Array/Accelerate.hs
@@ -62,10 +62,10 @@
 
   -- ** Accessors
   -- *** Indexing
-  (L.!), (L.!!), L.the,
+  (L.!), (L.!!), P.the,
 
   -- *** Shape information
-  L.null, L.shape, L.size, L.shapeSize,
+  P.null, L.shape, L.size, L.shapeSize,
 
   -- *** Extracting sub-arrays
   L.slice,
@@ -81,9 +81,12 @@
   -- *** Enumeration
   P.enumFromN, P.enumFromStepN,
 
+  -- *** Concatenation
+  (P.++),
+
   -- ** Composition
   -- *** Flow control
-  (L.?|), L.cond,
+  (P.?|), L.acond, L.awhile,
 
   -- *** Pipelining
   (L.>->),
@@ -103,11 +106,11 @@
   L.map,
 
   -- *** Zipping
-  L.zipWith, P.zipWith3, P.zipWith4,
-  P.zip, P.zip3, P.zip4,
+  L.zipWith, P.zipWith3, P.zipWith4, P.zipWith5, P.zipWith6, P.zipWith7, P.zipWith8, P.zipWith9,
+  P.zip, P.zip3, P.zip4, P.zip5, P.zip6, P.zip7, P.zip8, P.zip9,
 
   -- *** Unzipping
-  P.unzip, P.unzip3, P.unzip4,
+  P.unzip, P.unzip3, P.unzip4, P.unzip5, P.unzip6, P.unzip7, P.unzip8, P.unzip9,
 
   -- ** Working with predicates
   -- *** Filtering
@@ -171,17 +174,32 @@
 
   -- | A value of type `Int` is a plain Haskell value (unlifted), whereas an
   -- @Exp Int@ is a /lifted/ value, that is, an integer lifted into the domain
-  -- of expressions (an abstract syntax tree in disguise).  Both `Acc` and `Exp`
-  -- are /surface types/ into which values may be lifted.
+  -- of expressions (an abstract syntax tree in disguise). Both `Acc` and `Exp`
+  -- are /surface types/ into which values may be lifted. Lifting plain array
+  -- and scalar surface types is equivalent to 'use' and 'constant'
+  -- respectively.
   --
   -- In general an @Exp Int@ cannot be unlifted into an `Int`, because the
   -- actual number will not be available until a later stage of execution (e.g.
-  -- GPU execution, when `run` is called).  However, in some cases unlifting
-  -- makes sense.  For example, unlifting can convert, or unpack, an expression
-  -- of tuple type into a tuple of expressions; those expressions, at runtime,
-  -- will become tuple dereferences.
+  -- GPU execution, when `run` is called). Similarly an @Acc array@ can not be
+  -- unlifted to a vanilla `array`; should instead `run` the expression with a
+  -- specific backend to evaluate it.
   --
-  L.Lift(..), L.Unlift(..), L.lift1, L.lift2, L.ilift1, L.ilift2,
+  -- Lifting and unlift are also used to pack and unpack an expression into and
+  -- out of constructors such as tuples, respectively. Those expressions, at
+  -- runtime, will become tuple dereferences. For example:
+  --
+  -- > Exp (Z :. Int :. Int)
+  -- >     -> unlift -> (Z :. Exp Int :. Exp Int)
+  -- >     -> lift   -> Exp (Z :. Int :. Int)
+  -- >     -> ...
+  --
+  -- > Acc (Scalar Int, Vector Float)
+  -- >     -> unlift -> (Acc (Scalar Int), Acc (Vector Float))
+  -- >     -> lift   -> Acc (Scalar Int, Vector Float)
+  -- >     -> ...
+  --
+  P.Lift(..), P.Unlift(..), P.lift1, P.lift2, P.ilift1, P.ilift2,
 
   -- ** Operations
   --
@@ -195,17 +213,20 @@
   L.constant,
 
   -- *** Tuples
-  L.fst, L.snd, L.curry, L.uncurry,
+  P.fst, P.snd, P.curry, P.uncurry,
 
-  -- *** Conditional
-  (L.?),
+  -- *** Flow control
+  (P.?), L.cond, L.while, P.iterate,
 
+  -- *** Scalar reduction
+  P.sfoldl,
+
   -- *** Basic operations
   (L.&&*), (L.||*), L.not,
-  (L.==*), (L./=*), (L.<*), (L.<=*), (L.>*), (L.>=*), L.max, L.min,
+  (L.==*), (L./=*), (L.<*), (L.<=*), (L.>*), (L.>=*),
 
   -- *** Numeric functions
-  L.truncate, L.round, L.floor, L.ceiling,
+  L.truncate, L.round, L.floor, L.ceiling, L.even, L.odd,
 
   -- *** Bitwise functions
   L.bit, L.setBit, L.clearBit, L.complementBit, L.testBit,
@@ -213,9 +234,10 @@
   L.rotate, L.rotateL, L.rotateR,
 
   -- *** Shape manipulation
-  L.index0, L.index1, L.unindex1, L.index2, L.unindex2,
+  P.index0, P.index1, P.unindex1, P.index2, P.unindex2,
   L.indexHead, L.indexTail,
   L.toIndex, L.fromIndex,
+  L.intersect,
 
   -- *** Conversions
   L.boolToInt, L.fromIntegral,
@@ -231,6 +253,9 @@
   -- | For additional conversion routines, see the accelerate-io package:
   -- <http://hackage.haskell.org/package/accelerate-io>
 
+  -- *** Function
+  fromFunction,
+
   -- *** Lists
   S.fromList, S.toList,
 
@@ -258,25 +283,31 @@
 
 -- rename as '(!)' is already used by the EDSL for indexing
 
--- |Array indexing in plain Haskell code
+-- |Array indexing in plain Haskell code.
 --
 indexArray :: S.Array sh e -> sh -> e
 indexArray = (S.!)
 
--- | Rank of an array
+-- | Rank of an array.
 --
 arrayDim :: S.Shape sh => sh -> T.Int
 arrayDim = S.dim
 -- FIXME: Rename to rank
 
--- |Array shape in plain Haskell code
+-- |Array shape in plain Haskell code.
 --
 arrayShape :: S.Shape sh => S.Array sh e -> sh
 arrayShape = S.shape
 -- rename as 'shape' is already used by the EDSL to query an array's shape
 
--- | Total number of elements in an array of the given 'Shape'
+-- | Total number of elements in an array of the given 'Shape'.
 --
 arraySize :: S.Shape sh => sh -> T.Int
 arraySize = S.size
+
+-- | Create an array from its representation function.
+--
+{-# INLINE fromFunction #-}
+fromFunction :: (S.Shape sh, S.Elt e) => sh -> (sh -> e) -> S.Array sh e
+fromFunction = S.newArray
 
diff --git a/Data/Array/Accelerate/AST.hs b/Data/Array/Accelerate/AST.hs
--- a/Data/Array/Accelerate/AST.hs
+++ b/Data/Array/Accelerate/AST.hs
@@ -246,12 +246,20 @@
               -> PreOpenAcc   acc aenv a
 
   -- If-then-else for array-level computations
-  Acond       :: (Arrays arrs)
+  Acond       :: Arrays arrs
               => PreExp     acc aenv Bool
               -> acc            aenv arrs
               -> acc            aenv arrs
               -> PreOpenAcc acc aenv arrs
 
+  -- Value-recursion for array-level computations
+  Awhile      :: Arrays arrs
+              => PreOpenAfun acc aenv (arrs -> Scalar Bool)     -- continue iteration while true
+              -> PreOpenAfun acc aenv (arrs -> arrs)            -- function to iterate
+              -> acc             aenv arrs                      -- initial value
+              -> PreOpenAcc  acc aenv arrs
+
+
   -- Array inlet (triggers async host->device transfer if necessary)
   Use         :: Arrays arrs
               => ArrRepr arrs
@@ -393,18 +401,26 @@
               -> acc            aenv (Vector e)                 -- linear array
               -> PreOpenAcc acc aenv (Vector e)
 
-  -- Generalised forward permutation is characterised by a permutation
-  -- function that determines for each element of the source array where it
-  -- should go in the target; the permutation can be between arrays of varying
-  -- shape; the permutation function must be total.
+  -- Generalised forward permutation is characterised by a permutation function
+  -- that determines for each element of the source array where it should go in
+  -- the output. The permutation can be between arrays of varying shape and
+  -- dimensionality.
   --
-  -- The target array is initialised from an array of default values (in case
-  -- some positions in the target array are never picked by the permutation
-  -- functions).  Moreover, we have a combination function (in case some
-  -- positions on the target array are picked multiple times by the
-  -- permutation functions).  The combination function needs to be
-  -- /associative/ and /commutative/ .  We drop every element for which the
-  -- permutation function yields -1 (i.e., a tuple of -1 values).
+  -- Other characteristics of the permutation function 'f':
+  --
+  --   1. 'f' is a partial function: if it evaluates to the magic value 'ignore'
+  --      (i.e. a tuple of -1 values) then those elements of the domain are
+  --      dropped.
+  --
+  --   2. 'f' is not surjective: positions in the target array need not be
+  --      picked up by the permutation function, so the target array must first
+  --      be initialised from an array of default values.
+  --
+  --   3. 'f' is not injective: distinct elements of the domain may map to the
+  --      same position in the target array. In this case the combination
+  --      function is used to combine elements, which needs to be /associative/
+  --      and /commutative/.
+  --
   Permute     :: (Shape sh, Shape sh', Elt e)
               => PreFun     acc aenv (e -> e -> e)              -- combination function
               -> acc            aenv (Array sh' e)              -- default values
@@ -765,10 +781,10 @@
                 -> PreOpenExp acc env aenv t
                 -> PreOpenExp acc env aenv t
 
-  -- Value recursion with static loop count
-  Iterate       :: Elt a
-                => PreOpenExp acc env aenv Int          -- number of times to repeat
-                -> PreOpenExp acc (env, a) aenv a       -- function to iterate
+  -- Value recursion
+  While         :: Elt a
+                => PreOpenFun acc env aenv (a -> Bool)  -- continue while true
+                -> PreOpenFun acc env aenv (a -> a)     -- function to iterate
                 -> PreOpenExp acc env aenv a            -- initial value
                 -> PreOpenExp acc env aenv a
 
@@ -928,6 +944,7 @@
 showPreAccOp Apply{}            = "Apply"
 showPreAccOp Aforeign{}         = "Aforeign"
 showPreAccOp Acond{}            = "Acond"
+showPreAccOp Awhile{}           = "Awhile"
 showPreAccOp Atuple{}           = "Atuple"
 showPreAccOp Aprj{}             = "Aprj"
 showPreAccOp Unit{}             = "Unit"
@@ -991,7 +1008,7 @@
 showPreExpOp ToIndex{}          = "ToIndex"
 showPreExpOp FromIndex{}        = "FromIndex"
 showPreExpOp Cond{}             = "Cond"
-showPreExpOp Iterate{}          = "Iterate"
+showPreExpOp While{}            = "While"
 showPreExpOp PrimConst{}        = "PrimConst"
 showPreExpOp PrimApp{}          = "PrimApp"
 showPreExpOp Index{}            = "Index"
diff --git a/Data/Array/Accelerate/Analysis/Match.hs b/Data/Array/Accelerate/Analysis/Match.hs
--- a/Data/Array/Accelerate/Analysis/Match.hs
+++ b/Data/Array/Accelerate/Analysis/Match.hs
@@ -87,10 +87,10 @@
     -> Maybe (s :=: t)
 matchPreOpenAcc matchAcc hashAcc = match
   where
-    matchFun :: PreOpenFun acc env aenv u -> PreOpenFun acc env aenv v -> Maybe (u :=: v)
+    matchFun :: PreOpenFun acc env' aenv' u -> PreOpenFun acc env' aenv' v -> Maybe (u :=: v)
     matchFun = matchPreOpenFun matchAcc hashAcc
 
-    matchExp :: PreOpenExp acc env aenv u -> PreOpenExp acc env aenv v -> Maybe (u :=: v)
+    matchExp :: PreOpenExp acc env' aenv' u -> PreOpenExp acc env' aenv' v -> Maybe (u :=: v)
     matchExp = matchPreOpenExp matchAcc hashAcc
 
     match :: PreOpenAcc acc aenv s -> PreOpenAcc acc aenv t -> Maybe (s :=: t)
@@ -117,8 +117,8 @@
       = Just REFL
 
     match (Aforeign ff1 _ a1) (Aforeign ff2 _ a2)
-      | Just REFL <- matchAcc a1 a2,
-        unsafePerformIO $ do
+      | Just REFL <- matchAcc a1 a2
+      , unsafePerformIO $ do
           sn1 <- makeStableName ff1
           sn2 <- makeStableName ff2
           return $! hashStableName sn1 == hashStableName sn2
@@ -130,6 +130,12 @@
       , Just REFL <- matchAcc e1 e2
       = Just REFL
 
+    match (Awhile p1 f1 a1) (Awhile p2 f2 a2)
+      | Just REFL <- matchAcc a1 a2
+      , Just REFL <- matchPreOpenAfun matchAcc p1 p2
+      , Just REFL <- matchPreOpenAfun matchAcc f1 f2
+      = Just REFL
+
     match (Use a1) (Use a2)
       | Just REFL <- matchArrays (arrays (undefined::s)) (arrays (undefined::t)) a1 a2
       = gcast REFL
@@ -436,10 +442,10 @@
       , Just REFL <- match e1 e2
       = Just REFL
 
-    match (Iterate n1 f1 x1) (Iterate n2 f2 x2)
-      | Just REFL <- match n1 n2
-      , Just REFL <- match x1 x2
-      , Just REFL <- match f1 f2
+    match (While p1 f1 x1) (While p2 f2 x2)
+      | Just REFL <- match x1 x2
+      , Just REFL <- matchPreOpenFun matchAcc hashAcc p1 p2
+      , Just REFL <- matchPreOpenFun matchAcc hashAcc f1 f2
       = Just REFL
 
     match (PrimConst c1) (PrimConst c2)
@@ -878,6 +884,7 @@
     Apply f a                   -> hash "Apply"         `hashWithSalt` hashAfun hashAcc f `hashA` a
     Aforeign _ f a              -> hash "Aforeign"      `hashWithSalt` hashAfun hashAcc f `hashA` a
     Use a                       -> hash "Use"           `hashWithSalt` hashArrays (arrays (undefined::arrs)) a
+    Awhile p f a                -> hash "Awhile"        `hashWithSalt` hashAfun hashAcc f `hashWithSalt` hashAfun hashAcc p `hashA` a
     Unit e                      -> hash "Unit"          `hashE` e
     Generate e f                -> hash "Generate"      `hashE` e  `hashF` f
     Acond e a1 a2               -> hash "Acond"         `hashE` e  `hashA` a1 `hashA` a2
@@ -954,7 +961,7 @@
     ToIndex sh i                -> hash "ToIndex"       `hashE` sh `hashE` i
     FromIndex sh i              -> hash "FromIndex"     `hashE` sh `hashE` i
     Cond c t e                  -> hash "Cond"          `hashE` c  `hashE` t  `hashE` e
-    Iterate n f x               -> hash "Iterate"       `hashE` n  `hashE` f  `hashE` x
+    While p f x                 -> hash "While"         `hashWithSalt` hashPreOpenFun hashAcc p  `hashWithSalt` hashPreOpenFun hashAcc f  `hashE` x
     PrimApp f x                 -> hash "PrimApp"       `hashWithSalt` hashPrimFun f `hashE` fromMaybe x (commutes hashAcc f x)
     PrimConst c                 -> hash "PrimConst"     `hashWithSalt` hashPrimConst c
     Index a ix                  -> hash "Index"         `hashA` a  `hashE` ix
diff --git a/Data/Array/Accelerate/Analysis/Shape.hs b/Data/Array/Accelerate/Analysis/Shape.hs
--- a/Data/Array/Accelerate/Analysis/Shape.hs
+++ b/Data/Array/Accelerate/Analysis/Shape.hs
@@ -66,6 +66,7 @@
                               _            -> error "inconceivable!"
 
     Acond _ acc _        -> k acc
+    Awhile _ _ acc       -> k acc
     Use ((),(Array _ _)) -> ndim (eltType (undefined::sh))
     Unit _               -> 0
     Generate _ _         -> ndim (eltType (undefined::sh))
diff --git a/Data/Array/Accelerate/Analysis/Type.hs b/Data/Array/Accelerate/Analysis/Type.hs
--- a/Data/Array/Accelerate/Analysis/Type.hs
+++ b/Data/Array/Accelerate/Analysis/Type.hs
@@ -102,6 +102,7 @@
                              _            -> error "Who on earth wrote all these weird error messages?"
 
     Acond _ acc _       -> k acc
+    Awhile _ _ acc      -> k acc
     Use ((),a)          -> arrayType a
     Unit _              -> eltType (undefined::e)
     Generate _ _        -> eltType (undefined::e)
@@ -157,7 +158,7 @@
     ToIndex _ _       -> eltType (undefined::t)
     FromIndex _ _     -> eltType (undefined::t)
     Cond _ t _        -> preExpType k t
-    Iterate _ _ _     -> eltType (undefined::t)
+    While _ _ _       -> eltType (undefined::t)
     PrimConst _       -> eltType (undefined::t)
     PrimApp _ _       -> eltType (undefined::t)
     Index acc _       -> k acc
diff --git a/Data/Array/Accelerate/Array/Data.hs b/Data/Array/Accelerate/Array/Data.hs
--- a/Data/Array/Accelerate/Array/Data.hs
+++ b/Data/Array/Accelerate/Array/Data.hs
@@ -55,11 +55,7 @@
 import qualified Data.Array.Base    as MArray (unsafeRead, unsafeWrite)
 import qualified Data.Array.Base    as IArray (unsafeAt)
 #endif
-#if __GLASGOW_HASKELL__ >= 700 && __GLASGOW_HASKELL__ < 703
-import qualified Data.Array.MArray  as Unsafe
-#else
 import qualified Data.Array.Unsafe  as Unsafe
-#endif
 import Data.Array.ST      (STUArray)
 import Data.Array.Unboxed (UArray)
 import Data.Array.MArray  (MArray)
diff --git a/Data/Array/Accelerate/Array/Delayed.hs b/Data/Array/Accelerate/Array/Delayed.hs
--- a/Data/Array/Accelerate/Array/Delayed.hs
+++ b/Data/Array/Accelerate/Array/Delayed.hs
@@ -2,7 +2,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies        #-}
 -- |
--- Module      : Data.Array.Accelerate
+-- Module      : Data.Array.Accelerate.Array.Delayed
 -- Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee
 --               [2009..2013] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell
 -- License     : BSD3
diff --git a/Data/Array/Accelerate/Array/Sugar.hs b/Data/Array/Accelerate/Array/Sugar.hs
--- a/Data/Array/Accelerate/Array/Sugar.hs
+++ b/Data/Array/Accelerate/Array/Sugar.hs
@@ -663,9 +663,7 @@
 {-# RULES
 
 "fromElt/toElt" forall e.
-  fromElt (toElt e) = e
-
-  #-}
+  fromElt (toElt e) = e #-}
 
 
 -- Foreign functions
@@ -678,9 +676,7 @@
 class Typeable2 f => Foreign (f :: * -> * -> *) where
 
   -- Backends should be able to produce a string representation of the foreign
-  -- function for pretty printing. It should contain the backend name and
-  -- ideally a string uniquely identifying the foreign function being used.
-  --
+  -- function for pretty printing, typically the name of the function.
   strForeign :: f args results -> String
 
 
@@ -1087,8 +1083,38 @@
 -- Convert an array to a string
 --
 instance Show (Array sh e) where
-  show arr@(Array sh _adata)
-    = "Array (" ++ showShape (toElt sh :: sh) ++ ") " ++ show (toList arr)
+  show arr@Array{}
+    = "Array (" ++ showShape (shape arr) ++ ") " ++ show (toList arr)
+
+{--
+-- Specialised Show instances for dimensions zero, one, and two. Requires
+-- overlapping instances.
+--
+-- TODO:
+--   * Formatting of the matrix should be better, such as aligning the columns?
+--   * Make matrix formatting optional? It is more difficult to copy/paste the
+--     result, for example.
+--
+instance Show (Scalar e) where
+  show arr@Array{}
+    = "Scalar Z " ++ show (toList arr)
+
+instance Show (Vector e) where
+  show arr@Array{}
+    = "Vector (" ++ showShape (shape arr) ++ ") " ++ show (toList arr)
+
+instance Show (Array DIM2 e) where
+  show arr@Array{}
+    = "Array (" ++ showShape (shape arr) ++ ") \n " ++ showMat (toMatrix (toList arr))
+    where
+      showRow xs        = intercalate "," (map show xs)
+      showMat mat       = "[" ++ intercalate "\n ," (map showRow mat) ++ "]"
+
+      Z :. _ :. cols    = shape arr
+      toMatrix []       = []
+      toMatrix xs       = let (r,rs) = splitAt cols xs
+                          in  r : toMatrix rs
+--}
 
 -- | Nicely format a shape as a string
 --
diff --git a/Data/Array/Accelerate/Debug.hs b/Data/Array/Accelerate/Debug.hs
--- a/Data/Array/Accelerate/Debug.hs
+++ b/Data/Array/Accelerate/Debug.hs
@@ -47,26 +47,7 @@
 import System.IO.Unsafe                         ( unsafePerformIO )
 import qualified Data.Map                       as Map
 
-
-#if __GLASGOW_HASKELL__ >= 704
 import Debug.Trace                              ( traceIO, traceEventIO )
-#else
-import Debug.Trace                              ( putTraceMsg )
-
-traceIO :: String -> IO ()
-traceIO = putTraceMsg
-
-traceEventIO :: String -> IO ()
-traceEventIO = traceIO
-#endif
-
-#if !MIN_VERSION_base(4,6,0)
-modifyIORef' :: IORef a -> (a -> a) -> IO ()
-modifyIORef' ref f = do
-  x <- readIORef ref
-  let x' = f x
-  x' `seq` writeIORef ref x'
-#endif
 
 
 -- -----------------------------------------------------------------------------
diff --git a/Data/Array/Accelerate/Interpreter.hs b/Data/Array/Accelerate/Interpreter.hs
--- a/Data/Array/Accelerate/Interpreter.hs
+++ b/Data/Array/Accelerate/Interpreter.hs
@@ -130,6 +130,15 @@
 evalPreOpenAcc (Acond cond acc1 acc2) aenv
   = if (evalExp cond aenv) then evalOpenAcc acc1 aenv else evalOpenAcc acc2 aenv
 
+evalPreOpenAcc (Awhile cond body acc) aenv
+  = let f       = evalOpenAfun body aenv
+        p       = evalOpenAfun cond aenv
+        go !x
+          | (p x) Sugar.! Z = go (f x)
+          | otherwise       = delay x
+    in
+    go . force $ evalOpenAcc acc aenv
+
 evalPreOpenAcc (Use arr) _aenv = delay (Sugar.toArr arr :: a)
 
 evalPreOpenAcc (Unit e) aenv = unitOp (evalExp e aenv)
@@ -311,22 +320,22 @@
         in
         BOUNDS_CHECK(checkIndex) "slice" i sz $ (sl', \ix -> (f' ix, i))
 
-mapOp :: Sugar.Elt e' 
-      => (e -> e') 
-      -> Delayed (Array dim e) 
+mapOp :: Sugar.Elt e'
+      => (e -> e')
+      -> Delayed (Array dim e)
       -> Delayed (Array dim e')
 mapOp f (DelayedRpair DelayedRunit (DelayedRarray sh rf))
   = DelayedRpair DelayedRunit
   $ DelayedRarray sh (Sugar.sinkFromElt f . rf)
 
 zipWithOp :: Sugar.Elt e3
-          => (e1 -> e2 -> e3) 
-          -> Delayed (Array dim e1) 
-          -> Delayed (Array dim e2) 
+          => (e1 -> e2 -> e3)
+          -> Delayed (Array dim e1)
+          -> Delayed (Array dim e2)
           -> Delayed (Array dim e3)
 zipWithOp f (DelayedRpair DelayedRunit (DelayedRarray sh1 rf1)) (DelayedRpair DelayedRunit (DelayedRarray sh2 rf2))
   = DelayedRpair DelayedRunit
-  $ DelayedRarray (sh1 `intersect` sh2) 
+  $ DelayedRarray (sh1 `intersect` sh2)
                  (\ix -> (Sugar.sinkFromElt2 f) (rf1 ix) (rf2 ix))
 
 foldOp :: Sugar.Shape dim
@@ -634,8 +643,8 @@
                                     Left v    -> v
                                     Right ix' -> rf (Sugar.fromElt ix')
 
-stencil2Op :: forall dim e1 e2 e' stencil1 stencil2. 
-              (Sugar.Elt e1, Sugar.Elt e2, Sugar.Elt e', 
+stencil2Op :: forall dim e1 e2 e' stencil1 stencil2.
+              (Sugar.Elt e1, Sugar.Elt e2, Sugar.Elt e',
                Stencil dim e1 stencil1, Stencil dim e2 stencil2)
            => (stencil1 -> stencil2 -> e')
            -> Boundary (Sugar.EltRepr e1)
@@ -669,7 +678,7 @@
 --
 evalOpenFun :: OpenFun env aenv t -> ValElt env -> Val aenv -> t
 evalOpenFun (Body e) env aenv = evalOpenExp e env aenv
-evalOpenFun (Lam f)  env aenv 
+evalOpenFun (Lam f)  env aenv
   = \x -> evalOpenFun f (env `PushElt` Sugar.fromElt x) aenv
 
 -- Evaluate a closed function
@@ -684,7 +693,7 @@
 --     execution.  If these operations are in the body of a function that
 --     gets mapped over an array, the array argument would be forced many times
 --     leading to a large amount of wasteful recomputation.
---  
+--
 evalOpenExp :: OpenExp env aenv a -> ValElt env -> Val aenv -> a
 
 evalOpenExp (Let exp1 exp2) env aenv
@@ -697,22 +706,22 @@
 evalOpenExp (Const c) _ _
   = Sugar.toElt c
 
-evalOpenExp (Tuple tup) env aenv 
+evalOpenExp (Tuple tup) env aenv
   = toTuple $ evalTuple tup env aenv
 
-evalOpenExp (Prj idx e) env aenv 
+evalOpenExp (Prj idx e) env aenv
   = evalPrj idx (fromTuple $ evalOpenExp e env aenv)
 
-evalOpenExp IndexNil _env _aenv 
+evalOpenExp IndexNil _env _aenv
   = Z
 
-evalOpenExp (IndexCons sh i) env aenv 
+evalOpenExp (IndexCons sh i) env aenv
   = evalOpenExp sh env aenv :. evalOpenExp i env aenv
 
-evalOpenExp (IndexHead ix) env aenv 
+evalOpenExp (IndexHead ix) env aenv
   = case evalOpenExp ix env aenv of _:.h -> h
 
-evalOpenExp (IndexTail ix) env aenv 
+evalOpenExp (IndexTail ix) env aenv
   = case evalOpenExp ix env aenv of t:._ -> t
 
 evalOpenExp (IndexAny) _ _
@@ -756,14 +765,14 @@
     then evalOpenExp t env aenv
     else evalOpenExp e env aenv
 
-evalOpenExp (Iterate limit loop seed) env aenv
-  = let f = evalOpenFun (Lam (Body loop)) env aenv
-        x = evalOpenExp seed  env aenv
-        n = evalOpenExp limit env aenv
-        --
-        go !i !acc | i >= n     = acc
-                   | otherwise  = go (i+1) (f acc)
-    in go 0 x
+evalOpenExp (While cond body seed) env aenv
+  = let f       = evalOpenFun body env aenv
+        p       = evalOpenFun cond env aenv
+        go !x
+          | p x         = go (f x)
+          | otherwise   = x
+    in
+    go (evalOpenExp seed env aenv)
 
 evalOpenExp (PrimConst c) _ _ = evalPrimConst c
 
@@ -924,25 +933,25 @@
 
 
 -- Extract methods from reified dictionaries
--- 
+--
 
 -- Constant methods of Bounded
--- 
+--
 
 evalMinBound :: BoundedType a -> a
-evalMinBound (IntegralBoundedType ty) 
+evalMinBound (IntegralBoundedType ty)
   | IntegralDict <- integralDict ty = minBound
-evalMinBound (NonNumBoundedType   ty) 
+evalMinBound (NonNumBoundedType   ty)
   | NonNumDict   <- nonNumDict ty   = minBound
 
 evalMaxBound :: BoundedType a -> a
-evalMaxBound (IntegralBoundedType ty) 
+evalMaxBound (IntegralBoundedType ty)
   | IntegralDict <- integralDict ty = maxBound
-evalMaxBound (NonNumBoundedType   ty) 
+evalMaxBound (NonNumBoundedType   ty)
   | NonNumDict   <- nonNumDict ty   = maxBound
 
 -- Constant method of floating
--- 
+--
 
 evalPi :: FloatingType a -> a
 evalPi ty | FloatingDict <- floatingDict ty = pi
@@ -1014,7 +1023,7 @@
 
 
 -- Methods of Num
--- 
+--
 
 evalAdd :: NumType a -> ((a, a) -> a)
 evalAdd (IntegralNumType ty) | IntegralDict <- integralDict ty = uncurry (+)
@@ -1085,66 +1094,66 @@
 
 
 evalLt :: ScalarType a -> ((a, a) -> Bool)
-evalLt (NumScalarType (IntegralNumType ty)) 
+evalLt (NumScalarType (IntegralNumType ty))
   | IntegralDict <- integralDict ty = uncurry (<)
-evalLt (NumScalarType (FloatingNumType ty)) 
+evalLt (NumScalarType (FloatingNumType ty))
   | FloatingDict <- floatingDict ty = uncurry (<)
-evalLt (NonNumScalarType ty) 
+evalLt (NonNumScalarType ty)
   | NonNumDict   <- nonNumDict ty   = uncurry (<)
 
 evalGt :: ScalarType a -> ((a, a) -> Bool)
-evalGt (NumScalarType (IntegralNumType ty)) 
+evalGt (NumScalarType (IntegralNumType ty))
   | IntegralDict <- integralDict ty = uncurry (>)
-evalGt (NumScalarType (FloatingNumType ty)) 
+evalGt (NumScalarType (FloatingNumType ty))
   | FloatingDict <- floatingDict ty = uncurry (>)
-evalGt (NonNumScalarType ty) 
+evalGt (NonNumScalarType ty)
   | NonNumDict   <- nonNumDict ty   = uncurry (>)
 
 evalLtEq :: ScalarType a -> ((a, a) -> Bool)
-evalLtEq (NumScalarType (IntegralNumType ty)) 
+evalLtEq (NumScalarType (IntegralNumType ty))
   | IntegralDict <- integralDict ty = uncurry (<=)
-evalLtEq (NumScalarType (FloatingNumType ty)) 
+evalLtEq (NumScalarType (FloatingNumType ty))
   | FloatingDict <- floatingDict ty = uncurry (<=)
-evalLtEq (NonNumScalarType ty) 
+evalLtEq (NonNumScalarType ty)
   | NonNumDict   <- nonNumDict ty   = uncurry (<=)
 
 evalGtEq :: ScalarType a -> ((a, a) -> Bool)
-evalGtEq (NumScalarType (IntegralNumType ty)) 
+evalGtEq (NumScalarType (IntegralNumType ty))
   | IntegralDict <- integralDict ty = uncurry (>=)
-evalGtEq (NumScalarType (FloatingNumType ty)) 
+evalGtEq (NumScalarType (FloatingNumType ty))
   | FloatingDict <- floatingDict ty = uncurry (>=)
-evalGtEq (NonNumScalarType ty) 
+evalGtEq (NonNumScalarType ty)
   | NonNumDict   <- nonNumDict ty   = uncurry (>=)
 
 evalEq :: ScalarType a -> ((a, a) -> Bool)
-evalEq (NumScalarType (IntegralNumType ty)) 
+evalEq (NumScalarType (IntegralNumType ty))
   | IntegralDict <- integralDict ty = uncurry (==)
-evalEq (NumScalarType (FloatingNumType ty)) 
+evalEq (NumScalarType (FloatingNumType ty))
   | FloatingDict <- floatingDict ty = uncurry (==)
-evalEq (NonNumScalarType ty) 
+evalEq (NonNumScalarType ty)
   | NonNumDict   <- nonNumDict ty   = uncurry (==)
 
 evalNEq :: ScalarType a -> ((a, a) -> Bool)
-evalNEq (NumScalarType (IntegralNumType ty)) 
+evalNEq (NumScalarType (IntegralNumType ty))
   | IntegralDict <- integralDict ty = uncurry (/=)
-evalNEq (NumScalarType (FloatingNumType ty)) 
+evalNEq (NumScalarType (FloatingNumType ty))
   | FloatingDict <- floatingDict ty = uncurry (/=)
-evalNEq (NonNumScalarType ty) 
+evalNEq (NonNumScalarType ty)
   | NonNumDict   <- nonNumDict ty   = uncurry (/=)
 
 evalMax :: ScalarType a -> ((a, a) -> a)
-evalMax (NumScalarType (IntegralNumType ty)) 
+evalMax (NumScalarType (IntegralNumType ty))
   | IntegralDict <- integralDict ty = uncurry max
-evalMax (NumScalarType (FloatingNumType ty)) 
+evalMax (NumScalarType (FloatingNumType ty))
   | FloatingDict <- floatingDict ty = uncurry max
-evalMax (NonNumScalarType ty) 
+evalMax (NonNumScalarType ty)
   | NonNumDict   <- nonNumDict ty   = uncurry max
 
 evalMin :: ScalarType a -> ((a, a) -> a)
-evalMin (NumScalarType (IntegralNumType ty)) 
+evalMin (NumScalarType (IntegralNumType ty))
   | IntegralDict <- integralDict ty = uncurry min
-evalMin (NumScalarType (FloatingNumType ty)) 
+evalMin (NumScalarType (FloatingNumType ty))
   | FloatingDict <- floatingDict ty = uncurry min
-evalMin (NonNumScalarType ty) 
+evalMin (NonNumScalarType ty)
   | NonNumDict   <- nonNumDict ty   = uncurry min
 
diff --git a/Data/Array/Accelerate/Language.hs b/Data/Array/Accelerate/Language.hs
--- a/Data/Array/Accelerate/Language.hs
+++ b/Data/Array/Accelerate/Language.hs
@@ -1,13 +1,7 @@
-{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverlappingInstances  #-}
-{-# LANGUAGE RankNTypes            #-}
-{-# LANGUAGE ScopedTypeVariables   #-}
-{-# LANGUAGE TypeFamilies          #-}
-{-# LANGUAGE TypeOperators         #-}
-{-# LANGUAGE TypeSynonymInstances  #-}
-{-# OPTIONS_GHC -fno-warn-missing-methods -fno-warn-orphans #-}
+{-# LANGUAGE OverlappingInstances #-}   -- TLM: required by client code
+{-# LANGUAGE TypeOperators        #-}
+{-# OPTIONS -fno-warn-missing-methods #-}
+{-# OPTIONS -fno-warn-orphans         #-}
 -- |
 -- Module      : Data.Array.Accelerate.Language
 -- Copyright   : [2008..2011] Manuel M T Chakravarty, Gabriele Keller, Sean Lee
@@ -28,98 +22,80 @@
 
 module Data.Array.Accelerate.Language (
 
-  -- ** Array and scalar expressions
+  -- * Array and scalar expressions
   Acc, Exp,                                 -- re-exporting from 'Smart'
 
-  -- ** Stencil specification
-  Boundary(..), Stencil,                    -- re-exporting from 'Smart'
-
-  -- ** Common stencil types
-  Stencil3, Stencil5, Stencil7, Stencil9,
-  Stencil3x3, Stencil5x3, Stencil3x5, Stencil5x5,
-  Stencil3x3x3, Stencil5x3x3, Stencil3x5x3, Stencil3x3x5, Stencil5x5x3, Stencil5x3x5,
-  Stencil3x5x5, Stencil5x5x5,
-
-  -- ** Scalar introduction
+  -- * Scalar introduction
   constant,                                 -- re-exporting from 'Smart'
 
-  -- ** Array construction
+  -- * Array construction
   use, unit, replicate, generate,
 
-  -- ** Shape manipulation
+  -- * Shape manipulation
   reshape,
 
-  -- ** Extraction of subarrays
+  -- * Extraction of subarrays
   slice,
 
-  -- ** Map-like functions
+  -- * Map-like functions
   map, zipWith,
 
-  -- ** Reductions
+  -- * Reductions
   fold, fold1, foldSeg, fold1Seg,
 
-  -- ** Scan functions
+  -- * Scan functions
   scanl, scanl', scanl1, scanr, scanr', scanr1,
 
-  -- ** Permutations
+  -- * Permutations
   permute, backpermute,
 
-  -- ** Stencil operations
+  -- * Stencil operations
   stencil, stencil2,
 
-  -- ** Foreign functions
+  -- ** Stencil specification
+  Boundary(..), Stencil,
+
+  -- ** Common stencil types
+  Stencil3, Stencil5, Stencil7, Stencil9,
+  Stencil3x3, Stencil5x3, Stencil3x5, Stencil5x5,
+  Stencil3x3x3, Stencil5x3x3, Stencil3x5x3, Stencil3x3x5, Stencil5x5x3, Stencil5x3x5,
+  Stencil3x5x5, Stencil5x5x5,
+
+  -- * Foreign functions
   foreignAcc, foreignAcc2, foreignAcc3,
   foreignExp, foreignExp2, foreignExp3,
 
-  -- ** Pipelining
+  -- * Pipelining
   (>->),
 
-  -- ** Array-level flow-control
-  cond, (?|),
-
-  -- ** Lifting and Unlifting
-  -- | A value of type `Int` is a plain Haskell value (unlifted),
-  --   whereas an @Exp Int@ is a /lifted/ value, that is, an integer
-  --   lifted into the domain of expressions (an abstract syntax tree
-  --   in disguise).  Both `Acc` and `Exp` are /surface types/ into
-  --   which values may be lifted.
-  --
-  --   In general an @Exp Int@ cannot be unlifted into an `Int`,
-  --   because the actual number will not be available until a later stage of
-  --   execution (e.g. GPU execution, when `run` is called).  However,
-  --   in some cases unlifting makes sense.  For example, unlifting
-  --   can convert unpack an expression of tuple type into a tuple of
-  --   expressions; those expressions, at runtime, will become tuple
-  --   dereferences.
-  Lift(..), Unlift(..), lift1, lift2, ilift1, ilift2,
-
-  -- ** Tuple construction and destruction
-  fst, snd, curry, uncurry,
+  -- * Array-level flow-control
+  acond, awhile,
 
-  -- ** Index construction and destruction
-  index0, index1, unindex1, index2, unindex2,
+  -- * Index construction and destruction
   indexHead, indexTail, toIndex, fromIndex,
+  intersect,
 
-  -- ** Conditional expressions
-  (?),
+  -- * Flow-control
+  cond, while,
 
-  -- ** Array operations with a scalar result
-  (!), (!!), the, null, shape, size, shapeSize,
+  -- * Array operations with a scalar result
+  (!), (!!), shape, size, shapeSize,
 
-  -- ** Methods of H98 classes that we need to redefine as their signatures change
-  (==*), (/=*), (<*), (<=*), (>*), (>=*), max, min,
+  -- * Methods of H98 classes that we need to redefine as their signatures change
+  (==*), (/=*), (<*), (<=*), (>*), (>=*),
   bit, setBit, clearBit, complementBit, testBit,
   shift,  shiftL,  shiftR,
   rotate, rotateL, rotateR,
   truncate, round, floor, ceiling,
+  even, odd,
 
-  -- ** Standard functions that we need to redefine as their signatures change
+  -- * Standard functions that we need to redefine as their signatures change
   (&&*), (||*), not,
 
-  -- ** Conversions
+  -- * Conversions
   boolToInt, fromIntegral,
 
-  -- ** Constants
+  -- * Constants
   ignore
 
   -- Instances of Bounded, Enum, Eq, Ord, Bits, Num, Real, Floating,
@@ -127,20 +103,16 @@
 
 ) where
 
--- avoid clashes with Prelude functions
-import Prelude  hiding (
-  (!!), replicate, zip, unzip, map, scanl, scanl1, scanr, scanr1, zipWith,
-  filter, max, min, not, fst, snd, curry, uncurry, null, truncate, round, floor,
-  ceiling, fromIntegral)
-
 -- standard libraries
-import Data.Bits (Bits((.&.), (.|.), xor, complement))
+import Prelude ( Bounded, Enum, Num, Real, Integral, Floating, Fractional,
+  RealFloat, RealFrac, Eq, Ord, Bool, Char, Float, Double, (.), ($), id, error )
+import Data.Bits ( Bits((.&.), (.|.), xor, complement) )
+import qualified Prelude                                as P
 
 -- friends
 import Data.Array.Accelerate.Type
-import Data.Array.Accelerate.Tuple
 import Data.Array.Accelerate.Smart
-import Data.Array.Accelerate.Array.Sugar                hiding ((!), ignore, shape, size, toIndex, fromIndex)
+import Data.Array.Accelerate.Array.Sugar                hiding ((!), ignore, shape, size, toIndex, fromIndex, intersect)
 import qualified Data.Array.Accelerate.Array.Sugar      as Sugar
 
 
@@ -338,7 +310,7 @@
        -> Exp a
        -> Acc (Vector a)
        -> (Acc (Vector a), Acc (Scalar a))
-scanl' = unlift . Acc $$$ Scanl'
+scanl' = unatup2 . Acc $$$ Scanl'
 
 -- | Data.List style left-to-right scan without an initial value (aka inclusive
 -- scan).  Again, the first argument needs to be an /associative/ function.
@@ -368,7 +340,7 @@
        -> Exp a
        -> Acc (Vector a)
        -> (Acc (Vector a), Acc (Scalar a))
-scanr' = unlift . Acc $$$ Scanr'
+scanr' = unatup2 . Acc $$$ Scanr'
 
 -- | Right-to-left variant of 'scanl1'.
 --
@@ -381,13 +353,14 @@
 -- Permutations
 -- ------------
 
--- | Forward permutation specified by an index mapping.  The result array is
+-- | Forward permutation specified by an index mapping. The result array is
 -- initialised with the given defaults and any further values that are permuted
 -- into the result array are added to the current value using the given
 -- combination function.
 --
--- The combination function must be /associative/.  Elements that are mapped to
--- the magic value 'ignore' by the permutation function are dropped.
+-- The combination function must be /associative/ and /commutative/. Elements
+-- that are mapped to the magic value 'ignore' by the permutation function are
+-- dropped.
 --
 permute :: (Shape ix, Shape ix', Elt a)
         => (Exp a -> Exp a -> Exp a)    -- ^combination function
@@ -435,6 +408,7 @@
 type Stencil3x5x5 a = (Stencil3x5 a, Stencil3x5 a, Stencil3x5 a, Stencil3x5 a, Stencil3x5 a)
 type Stencil5x5x5 a = (Stencil5x5 a, Stencil5x5 a, Stencil5x5 a, Stencil5x5 a, Stencil5x5 a)
 
+
 -- |Map a stencil over an array.  In contrast to 'map', the domain of a stencil function is an
 --  entire /neighbourhood/ of each array element.  Neighbourhoods are sub-arrays centred around a
 --  focal point.  They are not necessarily rectangular, but they are symmetric in each dimension
@@ -554,482 +528,25 @@
 
 -- | An array-level if-then-else construct.
 --
-cond :: (Arrays a)
-     => Exp Bool          -- ^if-condition
-     -> Acc a             -- ^then-array
-     -> Acc a             -- ^else-array
-     -> Acc a
-cond = Acc $$$ Acond
-
--- | Infix version of 'cond'.
---
-infix 0 ?|
-(?|) :: (Arrays a) => Exp Bool -> (Acc a, Acc a) -> Acc a
-c ?| (t, e) = cond c t e
-
-
--- Lifting surface expressions
--- ---------------------------
-
--- | The class of types @e@ which can be lifted into @c@.
-class Lift c e where
-  -- | An associated-type (i.e. a type-level function) that strips all
-  --   instances of surface type constructors @c@ from the input type @e@.
-  --
-  --   For example, the tuple types @(Exp Int, Int)@ and @(Int, Exp
-  --   Int)@ have the same \"Plain\" representation.  That is, the
-  --   following type equality holds:
-  --
-  --    @Plain (Exp Int, Int) ~ (Int,Int) ~ Plain (Int, Exp Int)@
-  type Plain e
-
-  -- | Lift the given value into a surface type 'c' --- either 'Exp' for scalar
-  -- expressions or 'Acc' for array computations. The value may already contain
-  -- subexpressions in 'c'.
-  --
-  lift :: e -> c (Plain e)
-
--- | A limited subset of types which can be lifted, can also be unlifted.
-class Lift c e => Unlift c e where
-
-  -- | Unlift the outermost constructor through the surface type. This is only
-  -- possible if the constructor is fully determined by its type - i.e., it is a
-  -- singleton.
-  --
-  unlift :: c (Plain e) -> e
-
--- instances for indices
-
-instance Lift Exp () where
-  type Plain () = ()
-  lift _ = Exp $ Tuple NilTup
-
-instance Unlift Exp () where
-  unlift _ = ()
-
-instance Lift Exp Z where
-  type Plain Z = Z
-  lift _ = Exp $ IndexNil
-
-instance Unlift Exp Z where
-  unlift _ = Z
-
-instance (Slice (Plain ix), Lift Exp ix) => Lift Exp (ix :. Int) where
-  type Plain (ix :. Int) = Plain ix :. Int
-  lift (ix:.i) = Exp $ IndexCons (lift ix) (Exp $ Const i)
-
-instance (Slice (Plain ix), Lift Exp ix) => Lift Exp (ix :. All) where
-  type Plain (ix :. All) = Plain ix :. All
-  lift (ix:.i) = Exp $ IndexCons (lift ix) (Exp $ Const i)
-
-instance (Elt e, Slice (Plain ix), Lift Exp ix) => Lift Exp (ix :. Exp e) where
-  type Plain (ix :. Exp e) = Plain ix :. e
-  lift (ix:.i) = Exp $ IndexCons (lift ix) i
-
-instance (Elt e, Slice (Plain ix), Unlift Exp ix) => Unlift Exp (ix :. Exp e) where
-  unlift e = unlift (Exp $ IndexTail e) :. Exp (IndexHead e)
-
-instance (Elt e, Slice ix) => Unlift Exp (Exp ix :. Exp e) where
-  unlift e = (Exp $ IndexTail e) :. Exp (IndexHead e)
-
-instance Shape sh => Lift Exp (Any sh) where
- type Plain (Any sh) = Any sh
- lift Any = Exp $ IndexAny
-
--- instances for numeric types
-
-instance Lift Exp Int where
-  type Plain Int = Int
-  lift = Exp . Const
-
-instance Lift Exp Int8 where
-  type Plain Int8 = Int8
-  lift = Exp . Const
-
-instance Lift Exp Int16 where
-  type Plain Int16 = Int16
-  lift = Exp . Const
-
-instance Lift Exp Int32 where
-  type Plain Int32 = Int32
-  lift = Exp . Const
-
-instance Lift Exp Int64 where
-  type Plain Int64 = Int64
-  lift = Exp . Const
-
-instance Lift Exp Word where
-  type Plain Word = Word
-  lift = Exp . Const
-
-instance Lift Exp Word8 where
-  type Plain Word8 = Word8
-  lift = Exp . Const
-
-instance Lift Exp Word16 where
-  type Plain Word16 = Word16
-  lift = Exp . Const
-
-instance Lift Exp Word32 where
-  type Plain Word32 = Word32
-  lift = Exp . Const
-
-instance Lift Exp Word64 where
-  type Plain Word64 = Word64
-  lift = Exp . Const
-
-{-
-instance Lift Exp CShort where
-  type Plain CShort = CShort
-  lift = Exp . Const
-
-instance Lift Exp CUShort where
-  type Plain CUShort = CUShort
-  lift = Exp . Const
-
-instance Lift Exp CInt where
-  type Plain CInt = CInt
-  lift = Exp . Const
-
-instance Lift Exp CUInt where
-  type Plain CUInt = CUInt
-  lift = Exp . Const
-
-instance Lift Exp CLong where
-  type Plain CLong = CLong
-  lift = Exp . Const
-
-instance Lift Exp CULong where
-  type Plain CULong = CULong
-  lift = Exp . Const
-
-instance Lift Exp CLLong where
-  type Plain CLLong = CLLong
-  lift = Exp . Const
-
-instance Lift Exp CULLong where
-  type Plain CULLong = CULLong
-  lift = Exp . Const
- -}
-
-instance Lift Exp Float where
-  type Plain Float = Float
-  lift = Exp . Const
-
-instance Lift Exp Double where
-  type Plain Double = Double
-  lift = Exp . Const
-
-{-
-instance Lift Exp CFloat where
-  type Plain CFloat = CFloat
-  lift = Exp . Const
-
-instance Lift Exp CDouble where
-  type Plain CDouble = CDouble
-  lift = Exp . Const
- -}
-
-instance Lift Exp Bool where
-  type Plain Bool = Bool
-  lift = Exp . Const
-
-instance Lift Exp Char where
-  type Plain Char = Char
-  lift = Exp . Const
-
-{-
-instance Lift Exp CChar where
-  type Plain CChar = CChar
-  lift = Exp . Const
-
-instance Lift Exp CSChar where
-  type Plain CSChar = CSChar
-  lift = Exp . Const
-
-instance Lift Exp CUChar where
-
-type Plain CUChar = CUChar
-  lift = Exp . Const
- -}
-
--- Instances for tuples
-
-instance (Lift Exp a, Lift Exp b, Elt (Plain a), Elt (Plain b)) => Lift Exp (a, b) where
-  type Plain (a, b) = (Plain a, Plain b)
-  lift (x, y) = tup2 (lift x, lift y)
-
-instance (Elt a, Elt b) => Unlift Exp (Exp a, Exp b) where
-  unlift = untup2
-
-instance (Lift Exp a, Lift Exp b, Lift Exp c,
-          Elt (Plain a), Elt (Plain b), Elt (Plain c))
-  => Lift Exp (a, b, c) where
-  type Plain (a, b, c) = (Plain a, Plain b, Plain c)
-  lift (x, y, z) = tup3 (lift x, lift y, lift z)
-
-instance (Elt a, Elt b, Elt c) => Unlift Exp (Exp a, Exp b, Exp c) where
-  unlift = untup3
-
-instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d,
-          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d))
-  => Lift Exp (a, b, c, d) where
-  type Plain (a, b, c, d) = (Plain a, Plain b, Plain c, Plain d)
-  lift (x, y, z, u) = tup4 (lift x, lift y, lift z, lift u)
-
-instance (Elt a, Elt b, Elt c, Elt d) => Unlift Exp (Exp a, Exp b, Exp c, Exp d) where
-  unlift = untup4
-
-instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e,
-          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e))
-  => Lift Exp (a, b, c, d, e) where
-  type Plain (a, b, c, d, e) = (Plain a, Plain b, Plain c, Plain d, Plain e)
-  lift (x, y, z, u, v) = tup5 (lift x, lift y, lift z, lift u, lift v)
-
-instance (Elt a, Elt b, Elt c, Elt d, Elt e)
-  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e) where
-  unlift = untup5
-
-instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e, Lift Exp f,
-          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f))
-  => Lift Exp (a, b, c, d, e, f) where
-  type Plain (a, b, c, d, e, f) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f)
-  lift (x, y, z, u, v, w) = tup6 (lift x, lift y, lift z, lift u, lift v, lift w)
-
-instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)
-  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f) where
-  unlift = untup6
-
-instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e, Lift Exp f, Lift Exp g,
-          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f),
-          Elt (Plain g))
-  => Lift Exp (a, b, c, d, e, f, g) where
-  type Plain (a, b, c, d, e, f, g) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g)
-  lift (x, y, z, u, v, w, r) = tup7 (lift x, lift y, lift z, lift u, lift v, lift w, lift r)
-
-instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)
-  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g) where
-  unlift = untup7
-
-instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e, Lift Exp f, Lift Exp g, Lift Exp h,
-          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f),
-          Elt (Plain g), Elt (Plain h))
-  => Lift Exp (a, b, c, d, e, f, g, h) where
-  type Plain (a, b, c, d, e, f, g, h)
-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h)
-  lift (x, y, z, u, v, w, r, s)
-    = tup8 (lift x, lift y, lift z, lift u, lift v, lift w, lift r, lift s)
-
-instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)
-  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h) where
-  unlift = untup8
-
-instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e,
-          Lift Exp f, Lift Exp g, Lift Exp h, Lift Exp i,
-          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e),
-          Elt (Plain f), Elt (Plain g), Elt (Plain h), Elt (Plain i))
-  => Lift Exp (a, b, c, d, e, f, g, h, i) where
-  type Plain (a, b, c, d, e, f, g, h, i)
-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i)
-  lift (x, y, z, u, v, w, r, s, t)
-    = tup9 (lift x, lift y, lift z, lift u, lift v, lift w, lift r, lift s, lift t)
-
-instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)
-  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i) where
-  unlift = untup9
-
--- Instance for scalar Accelerate expressions
-
-instance Lift Exp (Exp e) where
-  type Plain (Exp e) = e
-  lift = id
-
-
--- Instance for Accelerate array computations
-
-instance Lift Acc (Acc a) where
-  type Plain (Acc a) = a
-  lift = id
-
--- Instances for Arrays class
-
---instance Lift Acc () where
---  type Plain () = ()
---  lift _ = Acc (Atuple NilAtup)
-
-instance (Shape sh, Elt e) => Lift Acc (Array sh e) where
-  type Plain (Array sh e) = Array sh e
-  lift = Acc . Use
-
-instance (Lift Acc a, Lift Acc b, Arrays (Plain a), Arrays (Plain b)) => Lift Acc (a, b) where
-  type Plain (a, b) = (Plain a, Plain b)
-  lift (x, y) = atup2 (lift x, lift y)
-
-instance (Arrays a, Arrays b) => Unlift Acc (Acc a, Acc b) where
-  unlift = unatup2
-
-instance (Lift Acc a, Lift Acc b, Lift Acc c,
-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c))
-  => Lift Acc (a, b, c) where
-  type Plain (a, b, c) = (Plain a, Plain b, Plain c)
-  lift (x, y, z) = atup3 (lift x, lift y, lift z)
-
-instance (Arrays a, Arrays b, Arrays c) => Unlift Acc (Acc a, Acc b, Acc c) where
-  unlift = unatup3
-
-instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d,
-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d))
-  => Lift Acc (a, b, c, d) where
-  type Plain (a, b, c, d) = (Plain a, Plain b, Plain c, Plain d)
-  lift (x, y, z, u) = atup4 (lift x, lift y, lift z, lift u)
-
-instance (Arrays a, Arrays b, Arrays c, Arrays d) => Unlift Acc (Acc a, Acc b, Acc c, Acc d) where
-  unlift = unatup4
-
-instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e,
-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e))
-  => Lift Acc (a, b, c, d, e) where
-  type Plain (a, b, c, d, e) = (Plain a, Plain b, Plain c, Plain d, Plain e)
-  lift (x, y, z, u, v) = atup5 (lift x, lift y, lift z, lift u, lift v)
-
-instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e)
-  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e) where
-  unlift = unatup5
-
-instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e, Lift Acc f,
-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f))
-  => Lift Acc (a, b, c, d, e, f) where
-  type Plain (a, b, c, d, e, f) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f)
-  lift (x, y, z, u, v, w) = atup6 (lift x, lift y, lift z, lift u, lift v, lift w)
-
-instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f)
-  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f) where
-  unlift = unatup6
-
-instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e, Lift Acc f, Lift Acc g,
-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f),
-          Arrays (Plain g))
-  => Lift Acc (a, b, c, d, e, f, g) where
-  type Plain (a, b, c, d, e, f, g) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g)
-  lift (x, y, z, u, v, w, r) = atup7 (lift x, lift y, lift z, lift u, lift v, lift w, lift r)
-
-instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g)
-  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g) where
-  unlift = unatup7
-
-instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e, Lift Acc f, Lift Acc g, Lift Acc h,
-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f),
-          Arrays (Plain g), Arrays (Plain h))
-  => Lift Acc (a, b, c, d, e, f, g, h) where
-  type Plain (a, b, c, d, e, f, g, h)
-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h)
-  lift (x, y, z, u, v, w, r, s)
-    = atup8 (lift x, lift y, lift z, lift u, lift v, lift w, lift r, lift s)
-
-instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h)
-  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h) where
-  unlift = unatup8
-
-instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e,
-          Lift Acc f, Lift Acc g, Lift Acc h, Lift Acc i,
-          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e),
-          Arrays (Plain f), Arrays (Plain g), Arrays (Plain h), Arrays (Plain i))
-  => Lift Acc (a, b, c, d, e, f, g, h, i) where
-  type Plain (a, b, c, d, e, f, g, h, i)
-    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i)
-  lift (x, y, z, u, v, w, r, s, t)
-    = atup9 (lift x, lift y, lift z, lift u, lift v, lift w, lift r, lift s, lift t)
-
-instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i)
-  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i) where
-  unlift = unatup9
-
-
--- Helpers to lift functions
-
--- |Lift a unary function into 'Exp'.
---
-lift1 :: (Unlift Exp e1, Lift Exp e2)
-      => (e1 -> e2)
-      -> Exp (Plain e1)
-      -> Exp (Plain e2)
-lift1 f = lift . f . unlift
-
--- |Lift a binary function into 'Exp'.
---
-lift2 :: (Unlift Exp e1, Unlift Exp e2, Lift Exp e3)
-      => (e1 -> e2 -> e3)
-      -> Exp (Plain e1)
-      -> Exp (Plain e2)
-      -> Exp (Plain e3)
-lift2 f x y = lift $ f (unlift x) (unlift y)
-
--- |Lift a unary function to a computation over rank-1 indices.
---
-ilift1 :: (Exp Int -> Exp Int) -> Exp DIM1 -> Exp DIM1
-ilift1 f = lift1 (\(Z:.i) -> Z :. f i)
+acond :: Arrays a
+      => Exp Bool               -- ^ if-condition
+      -> Acc a                  -- ^ then-array
+      -> Acc a                  -- ^ else-array
+      -> Acc a
+acond = Acc $$$ Acond
 
--- |Lift a binary function to a computation over rank-1 indices.
+-- | An array-level while construct
 --
-ilift2 :: (Exp Int -> Exp Int -> Exp Int) -> Exp DIM1 -> Exp DIM1 -> Exp DIM1
-ilift2 f = lift2 (\(Z:.i) (Z:.j) -> Z :. f i j)
+awhile :: (Arrays a)
+       => (Acc a -> Acc (Scalar Bool))
+       -> (Acc a -> Acc a)
+       -> Acc a
+       -> Acc a
+awhile = Acc $$$ Awhile
 
 
--- Helpers to lift tuples
-
--- |Extract the first component of a pair.
---
-fst :: forall f a b. Unlift f (f a, f b) => f (Plain (f a), Plain (f b)) -> f a
-fst e = let (x, _:: f b) = unlift e in x
-
--- |Extract the second component of a pair.
---
-snd :: forall f a b. Unlift f (f a, f b) => f (Plain (f a), Plain (f b)) -> f b
-snd e = let (_::f a, y) = unlift e in y
-
--- |Converts an uncurried function to a curried function.
---
-curry :: Lift f (f a, f b) => (f (Plain (f a), Plain (f b)) -> f c) -> f a -> f b -> f c
-curry f x y = f (lift (x, y))
-
--- |Converts a curried function to a function on pairs.
---
-uncurry :: Unlift f (f a, f b) => (f a -> f b -> f c) -> f (Plain (f a), Plain (f b)) -> f c
-uncurry f t = let (x, y) = unlift t in f x y
-
--- Helpers to lift shapes and indices
-
--- |The one index for a rank-0 array.
---
-index0 :: Exp Z
-index0 = lift Z
-
--- |Turn an 'Int' expression into a rank-1 indexing expression.
---
-index1 :: Elt i => Exp i -> Exp (Z :. i)
-index1 i = lift (Z :. i)
-
--- |Turn a rank-1 indexing expression into an 'Int' expression.
---
-unindex1 :: Elt i => Exp (Z :. i) -> Exp i
-unindex1 ix = let Z :. i = unlift ix in i
-
--- | Creates a rank-2 index from two Exp Int`s
---
-index2 :: (Elt i, Slice (Z :. i))
-       => Exp i
-       -> Exp i
-       -> Exp (Z :. i :. i)
-index2 i j = lift (Z :. i :. j)
-
--- | Destructs a rank-2 index to an Exp tuple of two Int`s.
---
-unindex2 :: forall i. (Elt i, Slice (Z :. i))
-         => Exp (Z :. i :. i)
-         -> Exp (i, i)
-unindex2 ix
-  = let Z :. i :. j = unlift ix :: Z :. Exp i :. Exp i
-    in  lift (i, j)
+-- Shapes and indices
+-- ------------------
 
 -- | Get the outermost dimension of a shape
 --
@@ -1052,18 +569,35 @@
 fromIndex :: Shape sh => Exp sh -> Exp Int -> Exp sh
 fromIndex = Exp $$ FromIndex
 
+-- | Intersection of two shapes
+--
+intersect :: Shape sh => Exp sh -> Exp sh -> Exp sh
+intersect = Exp $$ Intersect
 
--- Conditional expressions
--- -----------------------
 
--- |Conditional expression. If the predicate evaluates to 'True', the first
--- component of the tuple is returned, else the second.
+-- Flow-control
+-- ------------
+
+-- | A scalar-level if-then-else construct.
 --
-infix 0 ?
-(?) :: Elt t => Exp Bool -> (Exp t, Exp t) -> Exp t
-c ? (t, e) = Exp $ Cond c t e
+cond :: Elt t
+     => Exp Bool                -- ^ condition
+     -> Exp t                   -- ^ then-expression
+     -> Exp t                   -- ^ else-expression
+     -> Exp t
+cond = Exp $$$ Cond
 
+-- | While construct. Continue to apply the given function, starting with the
+-- initial value, until the test function evaluates to true.
+--
+while :: Elt e
+      => (Exp e -> Exp Bool)
+      -> (Exp e -> Exp e)
+      -> Exp e
+      -> Exp e
+while = Exp $$$ While
 
+
 -- Array operations with a scalar result
 -- -------------------------------------
 
@@ -1071,23 +605,13 @@
 --
 infixl 9 !
 (!) :: (Shape ix, Elt e) => Acc (Array ix e) -> Exp ix -> Exp e
-(!) arr ix = Exp $ Index arr ix
+(!) = Exp $$ Index
 
 -- |Expression form that extracts a scalar from an array at a linear index
 --
 infixl 9 !!
 (!!) :: (Shape ix, Elt e) => Acc (Array ix e) -> Exp Int -> Exp e
-(!!) arr i = Exp $ LinearIndex arr i
-
--- |Extraction of the element in a singleton array
---
-the :: Elt e => Acc (Scalar e) -> Exp e
-the = (!index0)
-
--- |Test whether an array is empty
---
-null :: (Shape ix, Elt e) => Acc (Array ix e) -> Exp Bool
-null arr = size arr ==* 0
+(!!) = Exp $$ LinearIndex
 
 -- |Expression form that yields the shape of an array
 --
@@ -1123,7 +647,9 @@
 
 instance (Elt t, IsScalar t) => Prelude.Ord (Exp t) where
   -- FIXME: instance makes no sense with standard signatures
-  compare     = error "Prelude.Ord.compare applied to EDSL types"
+  compare       = error "Prelude.Ord.compare applied to EDSL types"
+  min           = mkMin
+  max           = mkMax
 
 instance (Elt t, IsNum t, IsIntegral t) => Bits (Exp t) where
   (.&.)      = mkBAnd
@@ -1139,7 +665,10 @@
 -- otherwise.
 --
 shift :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t
-shift  x i = i ==* 0 ? (x, i <* 0 ? (x `shiftR` (-i), x `shiftL` i))
+shift  x i
+  = cond (i ==* 0) x
+  $ cond (i <*  0) (x `shiftR` (-i))
+                   (x `shiftL` i)
 
 -- | Shift the argument left by the specified number of bits
 -- (which must be non-negative).
@@ -1161,7 +690,10 @@
 -- @-i@ bits otherwise.
 --
 rotate :: (Elt t, IsIntegral t) => Exp t -> Exp Int -> Exp t
-rotate x i = i ==* 0 ? (x, i <* 0 ? (x `rotateR` (-i), x `rotateL` i))
+rotate x i
+  = cond (i ==* 0) x
+  $ cond (i <*  0) (x `rotateR` (-i))
+                   (x `rotateL` i)
 
 -- | Rotate the argument left by the specified number of bits
 -- (which must be non-negative).
@@ -1208,7 +740,7 @@
   negate      = mkNeg
   abs         = mkAbs
   signum      = mkSig
-  fromInteger = constant . fromInteger
+  fromInteger = constant . P.fromInteger
 
 instance (Elt t, IsNum t) => Real (Exp t)
   -- FIXME: Why did we include this class?  We won't need `toRational' until
@@ -1243,7 +775,7 @@
 instance (Elt t, IsFloating t) => Fractional (Exp t) where
   (/)          = mkFDiv
   recip        = mkRecip
-  fromRational = constant . fromRational
+  fromRational = constant . P.fromRational
 
 instance (Elt t, IsFloating t) => RealFrac (Exp t)
   -- FIXME: add other ops
@@ -1291,16 +823,6 @@
 (<=*) :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp Bool
 (<=*) = mkLtEq
 
--- |Determine the maximum of two scalars.
---
-max :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp t
-max = mkMax
-
--- |Determine the minimum of two scalars.
---
-min :: (Elt t, IsScalar t) => Exp t -> Exp t -> Exp t
-min = mkMin
-
 -- Conversions from the RealFrac class
 --
 
@@ -1324,6 +846,16 @@
 --
 ceiling :: (Elt a, Elt b, IsFloating a, IsIntegral b) => Exp a -> Exp b
 ceiling = mkCeiling
+
+-- | return if the integer is even
+--
+even :: (Elt a, IsIntegral a) => Exp a -> Exp Bool
+even x = x .&. 1 ==* 0
+
+-- | return if the integer is odd
+--
+odd :: (Elt a, IsIntegral a) => Exp a -> Exp Bool
+odd x = x .&. 1 ==* 1
 
 
 -- Non-overloaded standard functions, where we need other signatures
diff --git a/Data/Array/Accelerate/Prelude.hs b/Data/Array/Accelerate/Prelude.hs
--- a/Data/Array/Accelerate/Prelude.hs
+++ b/Data/Array/Accelerate/Prelude.hs
@@ -1,4 +1,10 @@
-{-# LANGUAGE TypeOperators, ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverlappingInstances  #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE TypeOperators         #-}
 -- |
 -- Module      : Data.Array.Accelerate.Prelude
 -- Copyright   : [2010..2011] Manuel M T Chakravarty, Gabriele Keller, Ben Lever
@@ -9,18 +15,18 @@
 -- Stability   : experimental
 -- Portability : non-portable (GHC extensions)
 --
--- Standard functions that are not part of the core set (directly represented in the AST), but are
--- instead implemented in terms of the core set.
+-- Standard functions that are not part of the core set (directly represented in
+-- the AST), but are instead implemented in terms of the core set.
 --
 
 module Data.Array.Accelerate.Prelude (
 
   -- * Zipping
-  zipWith3, zipWith4,
-  zip, zip3, zip4,
+  zipWith3, zipWith4, zipWith5, zipWith6, zipWith7, zipWith8, zipWith9,
+  zip, zip3, zip4, zip5, zip6, zip7, zip8, zip9,
 
   -- * Unzipping
-  unzip, unzip3, unzip4,
+  unzip, unzip3, unzip4, unzip5, unzip6, unzip7, unzip8, unzip9,
 
   -- * Reductions
   foldAll, fold1All,
@@ -41,6 +47,9 @@
   -- * Enumeration and filling
   fill, enumFromN, enumFromStepN,
 
+  -- * Concatenation
+  (++),
+
   -- * Working with predicates
   -- ** Filtering
   filter,
@@ -52,29 +61,56 @@
   -- * Permutations
   reverse, transpose,
 
-  -- * Extracting sub-vectors
-  init, tail, take, drop, slit
+  --  Extracting sub-vectors
+  init, tail, take, drop, slit,
 
+  -- * Array-level flow control
+  (?|),
+
+  -- * Expression-level flow control
+  (?),
+
+  -- * Scalar iteration
+  iterate,
+
+  -- * Scalar reduction
+  sfoldl, -- sfoldr,
+
+  -- * Lifting and unlifting
+  Lift(..), Unlift(..),
+  lift1, lift2, ilift1, ilift2,
+
+  -- ** Tuple construction and destruction
+  fst, snd, curry, uncurry,
+
+  -- ** Index construction and destruction
+  index0, index1, unindex1, index2, unindex2,
+
+  -- * Array operations with a scalar result
+  the, null,
+
 ) where
 
 -- avoid clashes with Prelude functions
 --
 import Data.Bits
 import Data.Bool
-import Prelude ((.), ($), (+), (-), (*), const, subtract, id)
+import Prelude ((.), ($), (+), (-), (*), const, subtract, id, min, max, Float,
+  Double, Char)
 import qualified Prelude as P
 
 -- friends
-import Data.Array.Accelerate.Array.Sugar hiding ((!), ignore, shape, size)
+import Data.Array.Accelerate.Array.Sugar hiding ((!), ignore, shape, size, intersect)
 import Data.Array.Accelerate.Language
 import Data.Array.Accelerate.Smart
+import Data.Array.Accelerate.Tuple
 import Data.Array.Accelerate.Type
 
 
 -- Map-like composites
 -- -------------------
 
--- | Zip three arrays with the given function
+-- | Zip three arrays with the given function, analogous to 'zipWith'.
 --
 zipWith3 :: (Shape sh, Elt a, Elt b, Elt c, Elt d)
          => (Exp a -> Exp b -> Exp c -> Exp d)
@@ -83,10 +119,10 @@
          -> Acc (Array sh c)
          -> Acc (Array sh d)
 zipWith3 f as bs cs
-  = map (\x -> let (a,b,c) = unlift x in f a b c)
-  $ zip3 as bs cs
+  = generate (shape as `intersect` shape bs `intersect` shape cs)
+             (\ix -> f (as ! ix) (bs ! ix) (cs ! ix))
 
--- | Zip four arrays with the given function
+-- | Zip four arrays with the given function, analogous to 'zipWith'.
 --
 zipWith4 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e)
          => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e)
@@ -96,9 +132,102 @@
          -> Acc (Array sh d)
          -> Acc (Array sh e)
 zipWith4 f as bs cs ds
-  = map (\x -> let (a,b,c,d) = unlift x in f a b c d)
-  $ zip4 as bs cs ds
+  = generate (shape as `intersect` shape bs `intersect`
+              shape cs `intersect` shape ds)
+             (\ix -> f (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix))
 
+-- | Zip five arrays with the given function, analogous to 'zipWith'.
+--
+zipWith5 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)
+         => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f)
+         -> Acc (Array sh a)
+         -> Acc (Array sh b)
+         -> Acc (Array sh c)
+         -> Acc (Array sh d)
+         -> Acc (Array sh e)
+         -> Acc (Array sh f)
+zipWith5 f as bs cs ds es
+  = generate (shape as `intersect` shape bs `intersect` shape cs
+                       `intersect` shape ds `intersect` shape es)
+             (\ix -> f (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix))
+
+-- | Zip six arrays with the given function, analogous to 'zipWith'.
+--
+zipWith6 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)
+         => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g)
+         -> Acc (Array sh a)
+         -> Acc (Array sh b)
+         -> Acc (Array sh c)
+         -> Acc (Array sh d)
+         -> Acc (Array sh e)
+         -> Acc (Array sh f)
+         -> Acc (Array sh g)
+zipWith6 f as bs cs ds es fs
+  = generate (shape as `intersect` shape bs `intersect` shape cs
+                       `intersect` shape ds `intersect` shape es
+                       `intersect` shape fs)
+             (\ix -> f (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix) (fs ! ix))
+
+-- | Zip seven arrays with the given function, analogous to 'zipWith'.
+--
+zipWith7 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)
+         => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h)
+         -> Acc (Array sh a)
+         -> Acc (Array sh b)
+         -> Acc (Array sh c)
+         -> Acc (Array sh d)
+         -> Acc (Array sh e)
+         -> Acc (Array sh f)
+         -> Acc (Array sh g)
+         -> Acc (Array sh h)
+zipWith7 f as bs cs ds es fs gs
+  = generate (shape as `intersect` shape bs `intersect` shape cs
+                       `intersect` shape ds `intersect` shape es
+                       `intersect` shape fs `intersect` shape gs)
+             (\ix -> f (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix) (fs ! ix) (gs ! ix))
+
+-- | Zip eight arrays with the given function, analogous to 'zipWith'.
+--
+zipWith8 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)
+         => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h -> Exp i)
+         -> Acc (Array sh a)
+         -> Acc (Array sh b)
+         -> Acc (Array sh c)
+         -> Acc (Array sh d)
+         -> Acc (Array sh e)
+         -> Acc (Array sh f)
+         -> Acc (Array sh g)
+         -> Acc (Array sh h)
+         -> Acc (Array sh i)
+zipWith8 f as bs cs ds es fs gs hs
+  = generate (shape as `intersect` shape bs `intersect` shape cs
+                       `intersect` shape ds `intersect` shape es
+                       `intersect` shape fs `intersect` shape gs
+                       `intersect` shape hs)
+             (\ix -> f (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix) (fs ! ix) (gs ! ix) (hs ! ix))
+
+-- | Zip nine arrays with the given function, analogous to 'zipWith'.
+--
+zipWith9 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i, Elt j)
+         => (Exp a -> Exp b -> Exp c -> Exp d -> Exp e -> Exp f -> Exp g -> Exp h -> Exp i -> Exp j)
+         -> Acc (Array sh a)
+         -> Acc (Array sh b)
+         -> Acc (Array sh c)
+         -> Acc (Array sh d)
+         -> Acc (Array sh e)
+         -> Acc (Array sh f)
+         -> Acc (Array sh g)
+         -> Acc (Array sh h)
+         -> Acc (Array sh i)
+         -> Acc (Array sh j)
+zipWith9 f as bs cs ds es fs gs hs is
+  = generate (shape as `intersect` shape bs `intersect` shape cs
+                       `intersect` shape ds `intersect` shape es
+                       `intersect` shape fs `intersect` shape gs
+                       `intersect` shape hs `intersect` shape is)
+             (\ix -> f (as ! ix) (bs ! ix) (cs ! ix) (ds ! ix) (es ! ix) (fs ! ix) (gs ! ix) (hs ! ix) (is ! ix))
+
+
 -- | Combine the elements of two arrays pairwise.  The shape of the result is
 -- the intersection of the two argument shapes.
 --
@@ -110,27 +239,89 @@
 
 -- | Take three arrays and return an array of triples, analogous to zip.
 --
-zip3 :: forall sh. forall a. forall b. forall c. (Shape sh, Elt a, Elt b, Elt c)
+zip3 :: (Shape sh, Elt a, Elt b, Elt c)
      => Acc (Array sh a)
      -> Acc (Array sh b)
      -> Acc (Array sh c)
      -> Acc (Array sh (a, b, c))
-zip3 as bs cs
-  = zipWith (\a bc -> let (b, c) = unlift bc :: (Exp b, Exp c) in lift (a, b, c)) as
-  $ zip bs cs
+zip3 = zipWith3 (\a b c -> lift (a,b,c))
 
 -- | Take four arrays and return an array of quadruples, analogous to zip.
 --
-zip4 :: forall sh. forall a. forall b. forall c. forall d. (Shape sh, Elt a, Elt b, Elt c, Elt d)
+zip4 :: (Shape sh, Elt a, Elt b, Elt c, Elt d)
      => Acc (Array sh a)
      -> Acc (Array sh b)
      -> Acc (Array sh c)
      -> Acc (Array sh d)
      -> Acc (Array sh (a, b, c, d))
-zip4 as bs cs ds
-  = zipWith (\a bcd -> let (b, c, d) = unlift bcd :: (Exp b, Exp c, Exp d) in lift (a, b, c, d)) as
-  $ zip3 bs cs ds
+zip4 = zipWith4 (\a b c d -> lift (a,b,c,d))
 
+-- | Take five arrays and return an array of five-tuples, analogous to zip.
+--
+zip5 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e)
+     => Acc (Array sh a)
+     -> Acc (Array sh b)
+     -> Acc (Array sh c)
+     -> Acc (Array sh d)
+     -> Acc (Array sh e)
+     -> Acc (Array sh (a, b, c, d, e))
+zip5 = zipWith5 (\a b c d e -> lift (a,b,c,d,e))
+
+-- | Take six arrays and return an array of six-tuples, analogous to zip.
+--
+zip6 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)
+     => Acc (Array sh a)
+     -> Acc (Array sh b)
+     -> Acc (Array sh c)
+     -> Acc (Array sh d)
+     -> Acc (Array sh e)
+     -> Acc (Array sh f)
+     -> Acc (Array sh (a, b, c, d, e, f))
+zip6 = zipWith6 (\a b c d e f -> lift (a,b,c,d,e,f))
+
+-- | Take seven arrays and return an array of seven-tuples, analogous to zip.
+--
+zip7 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)
+     => Acc (Array sh a)
+     -> Acc (Array sh b)
+     -> Acc (Array sh c)
+     -> Acc (Array sh d)
+     -> Acc (Array sh e)
+     -> Acc (Array sh f)
+     -> Acc (Array sh g)
+     -> Acc (Array sh (a, b, c, d, e, f, g))
+zip7 = zipWith7 (\a b c d e f g -> lift (a,b,c,d,e,f,g))
+
+-- | Take seven arrays and return an array of seven-tuples, analogous to zip.
+--
+zip8 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)
+     => Acc (Array sh a)
+     -> Acc (Array sh b)
+     -> Acc (Array sh c)
+     -> Acc (Array sh d)
+     -> Acc (Array sh e)
+     -> Acc (Array sh f)
+     -> Acc (Array sh g)
+     -> Acc (Array sh h)
+     -> Acc (Array sh (a, b, c, d, e, f, g, h))
+zip8 = zipWith8 (\a b c d e f g h -> lift (a,b,c,d,e,f,g,h))
+
+-- | Take seven arrays and return an array of seven-tuples, analogous to zip.
+--
+zip9 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)
+     => Acc (Array sh a)
+     -> Acc (Array sh b)
+     -> Acc (Array sh c)
+     -> Acc (Array sh d)
+     -> Acc (Array sh e)
+     -> Acc (Array sh f)
+     -> Acc (Array sh g)
+     -> Acc (Array sh h)
+     -> Acc (Array sh i)
+     -> Acc (Array sh (a, b, c, d, e, f, g, h, i))
+zip9 = zipWith9 (\a b c d e f g h i -> lift (a,b,c,d,e,f,g,h,i))
+
+
 -- | The converse of 'zip', but the shape of the two results is identical to the
 -- shape of the argument.
 --
@@ -146,14 +337,9 @@
        -> (Acc (Array sh a), Acc (Array sh b), Acc (Array sh c))
 unzip3 xs = (map get1 xs, map get2 xs, map get3 xs)
   where
-    get1 :: forall a b c. (Elt a, Elt b, Elt c) => Exp (a,b,c) -> Exp a
-    get1 x = let (a, _ :: Exp b, _ :: Exp c) = unlift x in a
-
-    get2 :: forall a b c. (Elt a, Elt b, Elt c) => Exp (a,b,c) -> Exp b
-    get2 x = let (_ :: Exp a, b, _ :: Exp c) = unlift x in b
-
-    get3 :: forall a b c. (Elt a, Elt b, Elt c) => Exp (a,b,c) -> Exp c
-    get3 x = let (_ :: Exp a, _ :: Exp b, c) = unlift x in c
+    get1 x = let (a,_,_) = untup3 x in a
+    get2 x = let (_,b,_) = untup3 x in b
+    get3 x = let (_,_,c) = untup3 x in c
 
 
 -- | Take an array of quadruples and return four arrays, analogous to unzip.
@@ -163,19 +349,100 @@
        -> (Acc (Array sh a), Acc (Array sh b), Acc (Array sh c), Acc (Array sh d))
 unzip4 xs = (map get1 xs, map get2 xs, map get3 xs, map get4 xs)
   where
-    get1 :: forall a b c d. (Elt a, Elt b, Elt c, Elt d) => Exp (a,b,c,d) -> Exp a
-    get1 x = let (a, _ :: Exp b, _ :: Exp c, _ :: Exp d) = unlift x in a
+    get1 x = let (a,_,_,_) = untup4 x in a
+    get2 x = let (_,b,_,_) = untup4 x in b
+    get3 x = let (_,_,c,_) = untup4 x in c
+    get4 x = let (_,_,_,d) = untup4 x in d
 
-    get2 :: forall a b c d. (Elt a, Elt b, Elt c, Elt d) => Exp (a,b,c,d) -> Exp b
-    get2 x = let (_ :: Exp a, b, _ :: Exp c, _ :: Exp d) = unlift x in b
+-- | Take an array of 5-tuples and return five arrays, analogous to unzip.
+--
+unzip5 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e)
+       => Acc (Array sh (a, b, c, d, e))
+       -> (Acc (Array sh a), Acc (Array sh b), Acc (Array sh c), Acc (Array sh d), Acc (Array sh e))
+unzip5 xs = (map get1 xs, map get2 xs, map get3 xs, map get4 xs, map get5 xs)
+  where
+    get1 x = let (a,_,_,_,_) = untup5 x in a
+    get2 x = let (_,b,_,_,_) = untup5 x in b
+    get3 x = let (_,_,c,_,_) = untup5 x in c
+    get4 x = let (_,_,_,d,_) = untup5 x in d
+    get5 x = let (_,_,_,_,e) = untup5 x in e
 
-    get3 :: forall a b c d. (Elt a, Elt b, Elt c, Elt d) => Exp (a,b,c,d) -> Exp c
-    get3 x = let (_ :: Exp a, _ :: Exp b, c, _ :: Exp d) = unlift x in c
+-- | Take an array of 6-tuples and return six arrays, analogous to unzip.
+--
+unzip6 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)
+       => Acc (Array sh (a, b, c, d, e, f))
+       -> ( Acc (Array sh a), Acc (Array sh b), Acc (Array sh c)
+          , Acc (Array sh d), Acc (Array sh e), Acc (Array sh f))
+unzip6 xs = (map get1 xs, map get2 xs, map get3 xs, map get4 xs, map get5 xs, map get6 xs)
+  where
+    get1 x = let (a,_,_,_,_,_) = untup6 x in a
+    get2 x = let (_,b,_,_,_,_) = untup6 x in b
+    get3 x = let (_,_,c,_,_,_) = untup6 x in c
+    get4 x = let (_,_,_,d,_,_) = untup6 x in d
+    get5 x = let (_,_,_,_,e,_) = untup6 x in e
+    get6 x = let (_,_,_,_,_,f) = untup6 x in f
 
-    get4 :: forall a b c d. (Elt a, Elt b, Elt c, Elt d) => Exp (a,b,c,d) -> Exp d
-    get4 x = let (_ :: Exp a, _ :: Exp b, _ :: Exp c, d) = unlift x in d
+-- | Take an array of 7-tuples and return seven arrays, analogous to unzip.
+--
+unzip7 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)
+       => Acc (Array sh (a, b, c, d, e, f, g))
+       -> ( Acc (Array sh a), Acc (Array sh b), Acc (Array sh c)
+          , Acc (Array sh d), Acc (Array sh e), Acc (Array sh f)
+          , Acc (Array sh g))
+unzip7 xs = ( map get1 xs, map get2 xs, map get3 xs
+            , map get4 xs, map get5 xs, map get6 xs
+            , map get7 xs )
+  where
+    get1 x = let (a,_,_,_,_,_,_) = untup7 x in a
+    get2 x = let (_,b,_,_,_,_,_) = untup7 x in b
+    get3 x = let (_,_,c,_,_,_,_) = untup7 x in c
+    get4 x = let (_,_,_,d,_,_,_) = untup7 x in d
+    get5 x = let (_,_,_,_,e,_,_) = untup7 x in e
+    get6 x = let (_,_,_,_,_,f,_) = untup7 x in f
+    get7 x = let (_,_,_,_,_,_,g) = untup7 x in g
 
+-- | Take an array of 8-tuples and return eight arrays, analogous to unzip.
+--
+unzip8 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)
+       => Acc (Array sh (a, b, c, d, e, f, g, h))
+       -> ( Acc (Array sh a), Acc (Array sh b), Acc (Array sh c)
+          , Acc (Array sh d), Acc (Array sh e), Acc (Array sh f)
+          , Acc (Array sh g), Acc (Array sh h) )
+unzip8 xs = ( map get1 xs, map get2 xs, map get3 xs
+            , map get4 xs, map get5 xs, map get6 xs
+            , map get7 xs, map get8 xs )
+  where
+    get1 x = let (a,_,_,_,_,_,_,_) = untup8 x in a
+    get2 x = let (_,b,_,_,_,_,_,_) = untup8 x in b
+    get3 x = let (_,_,c,_,_,_,_,_) = untup8 x in c
+    get4 x = let (_,_,_,d,_,_,_,_) = untup8 x in d
+    get5 x = let (_,_,_,_,e,_,_,_) = untup8 x in e
+    get6 x = let (_,_,_,_,_,f,_,_) = untup8 x in f
+    get7 x = let (_,_,_,_,_,_,g,_) = untup8 x in g
+    get8 x = let (_,_,_,_,_,_,_,h) = untup8 x in h
 
+-- | Take an array of 8-tuples and return eight arrays, analogous to unzip.
+--
+unzip9 :: (Shape sh, Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)
+       => Acc (Array sh (a, b, c, d, e, f, g, h, i))
+       -> ( Acc (Array sh a), Acc (Array sh b), Acc (Array sh c)
+          , Acc (Array sh d), Acc (Array sh e), Acc (Array sh f)
+          , Acc (Array sh g), Acc (Array sh h), Acc (Array sh i))
+unzip9 xs = ( map get1 xs, map get2 xs, map get3 xs
+            , map get4 xs, map get5 xs, map get6 xs
+            , map get7 xs, map get8 xs, map get9 xs )
+  where
+    get1 x = let (a,_,_,_,_,_,_,_,_) = untup9 x in a
+    get2 x = let (_,b,_,_,_,_,_,_,_) = untup9 x in b
+    get3 x = let (_,_,c,_,_,_,_,_,_) = untup9 x in c
+    get4 x = let (_,_,_,d,_,_,_,_,_) = untup9 x in d
+    get5 x = let (_,_,_,_,e,_,_,_,_) = untup9 x in e
+    get6 x = let (_,_,_,_,_,f,_,_,_) = untup9 x in f
+    get7 x = let (_,_,_,_,_,_,g,_,_) = untup9 x in g
+    get8 x = let (_,_,_,_,_,_,_,h,_) = untup9 x in h
+    get9 x = let (_,_,_,_,_,_,_,_,i) = untup9 x in i
+
+
 -- Reductions
 -- ----------
 
@@ -628,7 +895,26 @@
   $ generate (index1 $ shapeSize sh)
              (\ix -> (fromIntegral (unindex1 ix :: Exp Int) * y) + x)
 
+-- Concatenation
+-- -------------
 
+-- | Concatenate outermost component of two arrays. The extent of the lower
+--   dimensional component is the intersection of the two arrays.
+--
+infixr 5 ++
+(++) :: forall sh e. (Slice sh, Shape sh, Elt e)
+     => Acc (Array (sh :. Int) e)
+     -> Acc (Array (sh :. Int) e)
+     -> Acc (Array (sh :. Int) e)
+(++) xs ys
+  = let sh1 :. n        = unlift (shape xs)     :: Exp sh :. Exp Int
+        sh2 :. m        = unlift (shape ys)     :: Exp sh :. Exp Int
+    in
+    generate (lift (intersect sh1 sh2 :. n + m))
+             (\ix -> let sh :. i = unlift ix    :: Exp sh :. Exp Int
+                     in  i <* n ? ( xs ! ix, ys ! lift (sh :. i-n)) )
+
+
 -- Filtering
 -- ---------
 
@@ -832,4 +1118,531 @@
   let i' = the (unit i)
       n' = the (unit n)
   in  backpermute (index1 n') (ilift1 (+ i'))
+
+
+-- Flow control
+-- ------------
+
+-- | Infix version of 'acond'. If the predicate evaluates to 'True', the first
+-- component of the tuple is returned, else the second.
+--
+infix 0 ?|
+(?|) :: (Arrays a) => Exp Bool -> (Acc a, Acc a) -> Acc a
+c ?| (t, e) = acond c t e
+
+-- | An infix version of 'cond'. If the predicate evaluates to 'True', the first
+-- component of the tuple is returned, else the second.
+--
+infix 0 ?
+(?) :: Elt t => Exp Bool -> (Exp t, Exp t) -> Exp t
+c ? (t, e) = cond c t e
+
+
+-- Scalar iteration
+-- ----------------
+
+-- | Repeatedly apply a function a fixed number of times
+--
+iterate :: forall a. Elt a
+        => Exp Int
+        -> (Exp a -> Exp a)
+        -> Exp a
+        -> Exp a
+iterate n f z
+  = let step :: (Exp Int, Exp a) -> (Exp Int, Exp a)
+        step (i, acc)   = ( i+1, f acc )
+    in
+    snd $ while (\v -> fst v <* n) (lift1 step) (lift (constant 0, z))
+
+
+-- Scalar bulk operations
+-- ----------------------
+
+-- | Reduce along an innermost slice of an array /sequentially/, by applying a
+-- binary operator to a starting value and the array from left to right.
+--
+sfoldl :: forall sh a b. (Shape sh, Slice sh, Elt a, Elt b)
+       => (Exp a -> Exp b -> Exp a)
+       -> Exp a
+       -> Exp sh
+       -> Acc (Array (sh :. Int) b)
+       -> Exp a
+sfoldl f z ix xs
+  = let step :: (Exp Int, Exp a) -> (Exp Int, Exp a)
+        step (i, acc)   = ( i+1, acc `f` (xs ! lift (ix :. i)) )
+        (_ :. n)        = unlift (shape xs)     :: Exp sh :. Exp Int
+    in
+    snd $ while (\v -> fst v <* n) (lift1 step) (lift (constant 0, z))
+
+
+-- Lifting surface expressions
+-- ---------------------------
+
+-- | The class of types @e@ which can be lifted into @c@.
+class Lift c e where
+  -- | An associated-type (i.e. a type-level function) that strips all
+  --   instances of surface type constructors @c@ from the input type @e@.
+  --
+  --   For example, the tuple types @(Exp Int, Int)@ and @(Int, Exp
+  --   Int)@ have the same \"Plain\" representation.  That is, the
+  --   following type equality holds:
+  --
+  --    @Plain (Exp Int, Int) ~ (Int,Int) ~ Plain (Int, Exp Int)@
+  type Plain e
+
+  -- | Lift the given value into a surface type 'c' --- either 'Exp' for scalar
+  -- expressions or 'Acc' for array computations. The value may already contain
+  -- subexpressions in 'c'.
+  --
+  lift :: e -> c (Plain e)
+
+-- | A limited subset of types which can be lifted, can also be unlifted.
+class Lift c e => Unlift c e where
+
+  -- | Unlift the outermost constructor through the surface type. This is only
+  -- possible if the constructor is fully determined by its type - i.e., it is a
+  -- singleton.
+  --
+  unlift :: c (Plain e) -> e
+
+-- instances for indices
+
+instance Lift Exp () where
+  type Plain () = ()
+  lift _ = Exp $ Tuple NilTup
+
+instance Unlift Exp () where
+  unlift _ = ()
+
+instance Lift Exp Z where
+  type Plain Z = Z
+  lift _ = Exp $ IndexNil
+
+instance Unlift Exp Z where
+  unlift _ = Z
+
+instance (Slice (Plain ix), Lift Exp ix) => Lift Exp (ix :. Int) where
+  type Plain (ix :. Int) = Plain ix :. Int
+  lift (ix:.i) = Exp $ IndexCons (lift ix) (Exp $ Const i)
+
+instance (Slice (Plain ix), Lift Exp ix) => Lift Exp (ix :. All) where
+  type Plain (ix :. All) = Plain ix :. All
+  lift (ix:.i) = Exp $ IndexCons (lift ix) (Exp $ Const i)
+
+instance (Elt e, Slice (Plain ix), Lift Exp ix) => Lift Exp (ix :. Exp e) where
+  type Plain (ix :. Exp e) = Plain ix :. e
+  lift (ix:.i) = Exp $ IndexCons (lift ix) i
+
+instance (Elt e, Slice (Plain ix), Unlift Exp ix) => Unlift Exp (ix :. Exp e) where
+  unlift e = unlift (Exp $ IndexTail e) :. Exp (IndexHead e)
+
+instance (Elt e, Slice ix) => Unlift Exp (Exp ix :. Exp e) where
+  unlift e = (Exp $ IndexTail e) :. Exp (IndexHead e)
+
+instance Shape sh => Lift Exp (Any sh) where
+ type Plain (Any sh) = Any sh
+ lift Any = Exp $ IndexAny
+
+-- instances for numeric types
+
+instance Lift Exp Int where
+  type Plain Int = Int
+  lift = Exp . Const
+
+instance Lift Exp Int8 where
+  type Plain Int8 = Int8
+  lift = Exp . Const
+
+instance Lift Exp Int16 where
+  type Plain Int16 = Int16
+  lift = Exp . Const
+
+instance Lift Exp Int32 where
+  type Plain Int32 = Int32
+  lift = Exp . Const
+
+instance Lift Exp Int64 where
+  type Plain Int64 = Int64
+  lift = Exp . Const
+
+instance Lift Exp Word where
+  type Plain Word = Word
+  lift = Exp . Const
+
+instance Lift Exp Word8 where
+  type Plain Word8 = Word8
+  lift = Exp . Const
+
+instance Lift Exp Word16 where
+  type Plain Word16 = Word16
+  lift = Exp . Const
+
+instance Lift Exp Word32 where
+  type Plain Word32 = Word32
+  lift = Exp . Const
+
+instance Lift Exp Word64 where
+  type Plain Word64 = Word64
+  lift = Exp . Const
+
+instance Lift Exp CShort where
+  type Plain CShort = CShort
+  lift = Exp . Const
+
+instance Lift Exp CUShort where
+  type Plain CUShort = CUShort
+  lift = Exp . Const
+
+instance Lift Exp CInt where
+  type Plain CInt = CInt
+  lift = Exp . Const
+
+instance Lift Exp CUInt where
+  type Plain CUInt = CUInt
+  lift = Exp . Const
+
+instance Lift Exp CLong where
+  type Plain CLong = CLong
+  lift = Exp . Const
+
+instance Lift Exp CULong where
+  type Plain CULong = CULong
+  lift = Exp . Const
+
+instance Lift Exp CLLong where
+  type Plain CLLong = CLLong
+  lift = Exp . Const
+
+instance Lift Exp CULLong where
+  type Plain CULLong = CULLong
+  lift = Exp . Const
+
+instance Lift Exp Float where
+  type Plain Float = Float
+  lift = Exp . Const
+
+instance Lift Exp Double where
+  type Plain Double = Double
+  lift = Exp . Const
+
+instance Lift Exp CFloat where
+  type Plain CFloat = CFloat
+  lift = Exp . Const
+
+instance Lift Exp CDouble where
+  type Plain CDouble = CDouble
+  lift = Exp . Const
+
+instance Lift Exp Bool where
+  type Plain Bool = Bool
+  lift = Exp . Const
+
+instance Lift Exp Char where
+  type Plain Char = Char
+  lift = Exp . Const
+
+instance Lift Exp CChar where
+  type Plain CChar = CChar
+  lift = Exp . Const
+
+instance Lift Exp CSChar where
+  type Plain CSChar = CSChar
+  lift = Exp . Const
+
+instance Lift Exp CUChar where
+  type Plain CUChar = CUChar
+  lift = Exp . Const
+
+-- Instances for tuples
+
+instance (Lift Exp a, Lift Exp b, Elt (Plain a), Elt (Plain b)) => Lift Exp (a, b) where
+  type Plain (a, b) = (Plain a, Plain b)
+  lift (x, y) = tup2 (lift x, lift y)
+
+instance (Elt a, Elt b) => Unlift Exp (Exp a, Exp b) where
+  unlift = untup2
+
+instance (Lift Exp a, Lift Exp b, Lift Exp c,
+          Elt (Plain a), Elt (Plain b), Elt (Plain c))
+  => Lift Exp (a, b, c) where
+  type Plain (a, b, c) = (Plain a, Plain b, Plain c)
+  lift (x, y, z) = tup3 (lift x, lift y, lift z)
+
+instance (Elt a, Elt b, Elt c) => Unlift Exp (Exp a, Exp b, Exp c) where
+  unlift = untup3
+
+instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d,
+          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d))
+  => Lift Exp (a, b, c, d) where
+  type Plain (a, b, c, d) = (Plain a, Plain b, Plain c, Plain d)
+  lift (x, y, z, u) = tup4 (lift x, lift y, lift z, lift u)
+
+instance (Elt a, Elt b, Elt c, Elt d) => Unlift Exp (Exp a, Exp b, Exp c, Exp d) where
+  unlift = untup4
+
+instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e,
+          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e))
+  => Lift Exp (a, b, c, d, e) where
+  type Plain (a, b, c, d, e) = (Plain a, Plain b, Plain c, Plain d, Plain e)
+  lift (x, y, z, u, v) = tup5 (lift x, lift y, lift z, lift u, lift v)
+
+instance (Elt a, Elt b, Elt c, Elt d, Elt e)
+  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e) where
+  unlift = untup5
+
+instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e, Lift Exp f,
+          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f))
+  => Lift Exp (a, b, c, d, e, f) where
+  type Plain (a, b, c, d, e, f) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f)
+  lift (x, y, z, u, v, w) = tup6 (lift x, lift y, lift z, lift u, lift v, lift w)
+
+instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f)
+  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f) where
+  unlift = untup6
+
+instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e, Lift Exp f, Lift Exp g,
+          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f),
+          Elt (Plain g))
+  => Lift Exp (a, b, c, d, e, f, g) where
+  type Plain (a, b, c, d, e, f, g) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g)
+  lift (x, y, z, u, v, w, r) = tup7 (lift x, lift y, lift z, lift u, lift v, lift w, lift r)
+
+instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g)
+  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g) where
+  unlift = untup7
+
+instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e, Lift Exp f, Lift Exp g, Lift Exp h,
+          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e), Elt (Plain f),
+          Elt (Plain g), Elt (Plain h))
+  => Lift Exp (a, b, c, d, e, f, g, h) where
+  type Plain (a, b, c, d, e, f, g, h)
+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h)
+  lift (x, y, z, u, v, w, r, s)
+    = tup8 (lift x, lift y, lift z, lift u, lift v, lift w, lift r, lift s)
+
+instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h)
+  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h) where
+  unlift = untup8
+
+instance (Lift Exp a, Lift Exp b, Lift Exp c, Lift Exp d, Lift Exp e,
+          Lift Exp f, Lift Exp g, Lift Exp h, Lift Exp i,
+          Elt (Plain a), Elt (Plain b), Elt (Plain c), Elt (Plain d), Elt (Plain e),
+          Elt (Plain f), Elt (Plain g), Elt (Plain h), Elt (Plain i))
+  => Lift Exp (a, b, c, d, e, f, g, h, i) where
+  type Plain (a, b, c, d, e, f, g, h, i)
+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i)
+  lift (x, y, z, u, v, w, r, s, t)
+    = tup9 (lift x, lift y, lift z, lift u, lift v, lift w, lift r, lift s, lift t)
+
+instance (Elt a, Elt b, Elt c, Elt d, Elt e, Elt f, Elt g, Elt h, Elt i)
+  => Unlift Exp (Exp a, Exp b, Exp c, Exp d, Exp e, Exp f, Exp g, Exp h, Exp i) where
+  unlift = untup9
+
+-- Instance for scalar Accelerate expressions
+
+instance Lift Exp (Exp e) where
+  type Plain (Exp e) = e
+  lift = id
+
+
+-- Instance for Accelerate array computations
+
+instance Lift Acc (Acc a) where
+  type Plain (Acc a) = a
+  lift = id
+
+-- Instances for Arrays class
+
+--instance Lift Acc () where
+--  type Plain () = ()
+--  lift _ = Acc (Atuple NilAtup)
+
+instance (Shape sh, Elt e) => Lift Acc (Array sh e) where
+  type Plain (Array sh e) = Array sh e
+  lift = Acc . Use
+
+instance (Lift Acc a, Lift Acc b, Arrays (Plain a), Arrays (Plain b)) => Lift Acc (a, b) where
+  type Plain (a, b) = (Plain a, Plain b)
+  lift (x, y) = atup2 (lift x, lift y)
+
+instance (Arrays a, Arrays b) => Unlift Acc (Acc a, Acc b) where
+  unlift = unatup2
+
+instance (Lift Acc a, Lift Acc b, Lift Acc c,
+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c))
+  => Lift Acc (a, b, c) where
+  type Plain (a, b, c) = (Plain a, Plain b, Plain c)
+  lift (x, y, z) = atup3 (lift x, lift y, lift z)
+
+instance (Arrays a, Arrays b, Arrays c) => Unlift Acc (Acc a, Acc b, Acc c) where
+  unlift = unatup3
+
+instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d,
+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d))
+  => Lift Acc (a, b, c, d) where
+  type Plain (a, b, c, d) = (Plain a, Plain b, Plain c, Plain d)
+  lift (x, y, z, u) = atup4 (lift x, lift y, lift z, lift u)
+
+instance (Arrays a, Arrays b, Arrays c, Arrays d) => Unlift Acc (Acc a, Acc b, Acc c, Acc d) where
+  unlift = unatup4
+
+instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e,
+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e))
+  => Lift Acc (a, b, c, d, e) where
+  type Plain (a, b, c, d, e) = (Plain a, Plain b, Plain c, Plain d, Plain e)
+  lift (x, y, z, u, v) = atup5 (lift x, lift y, lift z, lift u, lift v)
+
+instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e)
+  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e) where
+  unlift = unatup5
+
+instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e, Lift Acc f,
+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f))
+  => Lift Acc (a, b, c, d, e, f) where
+  type Plain (a, b, c, d, e, f) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f)
+  lift (x, y, z, u, v, w) = atup6 (lift x, lift y, lift z, lift u, lift v, lift w)
+
+instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f)
+  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f) where
+  unlift = unatup6
+
+instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e, Lift Acc f, Lift Acc g,
+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f),
+          Arrays (Plain g))
+  => Lift Acc (a, b, c, d, e, f, g) where
+  type Plain (a, b, c, d, e, f, g) = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g)
+  lift (x, y, z, u, v, w, r) = atup7 (lift x, lift y, lift z, lift u, lift v, lift w, lift r)
+
+instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g)
+  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g) where
+  unlift = unatup7
+
+instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e, Lift Acc f, Lift Acc g, Lift Acc h,
+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e), Arrays (Plain f),
+          Arrays (Plain g), Arrays (Plain h))
+  => Lift Acc (a, b, c, d, e, f, g, h) where
+  type Plain (a, b, c, d, e, f, g, h)
+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h)
+  lift (x, y, z, u, v, w, r, s)
+    = atup8 (lift x, lift y, lift z, lift u, lift v, lift w, lift r, lift s)
+
+instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h)
+  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h) where
+  unlift = unatup8
+
+instance (Lift Acc a, Lift Acc b, Lift Acc c, Lift Acc d, Lift Acc e,
+          Lift Acc f, Lift Acc g, Lift Acc h, Lift Acc i,
+          Arrays (Plain a), Arrays (Plain b), Arrays (Plain c), Arrays (Plain d), Arrays (Plain e),
+          Arrays (Plain f), Arrays (Plain g), Arrays (Plain h), Arrays (Plain i))
+  => Lift Acc (a, b, c, d, e, f, g, h, i) where
+  type Plain (a, b, c, d, e, f, g, h, i)
+    = (Plain a, Plain b, Plain c, Plain d, Plain e, Plain f, Plain g, Plain h, Plain i)
+  lift (x, y, z, u, v, w, r, s, t)
+    = atup9 (lift x, lift y, lift z, lift u, lift v, lift w, lift r, lift s, lift t)
+
+instance (Arrays a, Arrays b, Arrays c, Arrays d, Arrays e, Arrays f, Arrays g, Arrays h, Arrays i)
+  => Unlift Acc (Acc a, Acc b, Acc c, Acc d, Acc e, Acc f, Acc g, Acc h, Acc i) where
+  unlift = unatup9
+
+
+
+-- |Lift a unary function into 'Exp'.
+--
+lift1 :: (Unlift Exp e1, Lift Exp e2)
+      => (e1 -> e2)
+      -> Exp (Plain e1)
+      -> Exp (Plain e2)
+lift1 f = lift . f . unlift
+
+-- |Lift a binary function into 'Exp'.
+--
+lift2 :: (Unlift Exp e1, Unlift Exp e2, Lift Exp e3)
+      => (e1 -> e2 -> e3)
+      -> Exp (Plain e1)
+      -> Exp (Plain e2)
+      -> Exp (Plain e3)
+lift2 f x y = lift $ f (unlift x) (unlift y)
+
+-- |Lift a unary function to a computation over rank-1 indices.
+--
+ilift1 :: (Exp Int -> Exp Int) -> Exp DIM1 -> Exp DIM1
+ilift1 f = lift1 (\(Z:.i) -> Z :. f i)
+
+-- |Lift a binary function to a computation over rank-1 indices.
+--
+ilift2 :: (Exp Int -> Exp Int -> Exp Int) -> Exp DIM1 -> Exp DIM1 -> Exp DIM1
+ilift2 f = lift2 (\(Z:.i) (Z:.j) -> Z :. f i j)
+
+
+-- Tuples
+-- ------
+
+-- |Extract the first component of a pair.
+--
+fst :: forall f a b. Unlift f (f a, f b) => f (Plain (f a), Plain (f b)) -> f a
+fst e = let (x, _:: f b) = unlift e in x
+
+-- |Extract the second component of a pair.
+--
+snd :: forall f a b. Unlift f (f a, f b) => f (Plain (f a), Plain (f b)) -> f b
+snd e = let (_::f a, y) = unlift e in y
+
+-- |Converts an uncurried function to a curried function.
+--
+curry :: Lift f (f a, f b) => (f (Plain (f a), Plain (f b)) -> f c) -> f a -> f b -> f c
+curry f x y = f (lift (x, y))
+
+-- |Converts a curried function to a function on pairs.
+--
+uncurry :: Unlift f (f a, f b) => (f a -> f b -> f c) -> f (Plain (f a), Plain (f b)) -> f c
+uncurry f t = let (x, y) = unlift t in f x y
+
+
+-- Shapes and indices
+-- ------------------
+
+-- |The one index for a rank-0 array.
+--
+index0 :: Exp Z
+index0 = lift Z
+
+-- |Turn an 'Int' expression into a rank-1 indexing expression.
+--
+index1 :: Elt i => Exp i -> Exp (Z :. i)
+index1 i = lift (Z :. i)
+
+-- |Turn a rank-1 indexing expression into an 'Int' expression.
+--
+unindex1 :: Elt i => Exp (Z :. i) -> Exp i
+unindex1 ix = let Z :. i = unlift ix in i
+
+-- | Creates a rank-2 index from two Exp Int`s
+--
+index2 :: (Elt i, Slice (Z :. i))
+       => Exp i
+       -> Exp i
+       -> Exp (Z :. i :. i)
+index2 i j = lift (Z :. i :. j)
+
+-- | Destructs a rank-2 index to an Exp tuple of two Int`s.
+--
+unindex2 :: forall i. (Elt i, Slice (Z :. i))
+         => Exp (Z :. i :. i)
+         -> Exp (i, i)
+unindex2 ix
+  = let Z :. i :. j = unlift ix :: Z :. Exp i :. Exp i
+    in  lift (i, j)
+
+-- Array operations with a scalar result
+-- -------------------------------------
+
+-- |Extraction of the element in a singleton array
+--
+the :: Elt e => Acc (Scalar e) -> Exp e
+the = (!index0)
+
+-- |Test whether an array is empty
+--
+null :: (Shape ix, Elt e) => Acc (Array ix e) -> Exp Bool
+null arr = size arr ==* 0
 
diff --git a/Data/Array/Accelerate/Pretty.hs b/Data/Array/Accelerate/Pretty.hs
--- a/Data/Array/Accelerate/Pretty.hs
+++ b/Data/Array/Accelerate/Pretty.hs
@@ -39,9 +39,22 @@
 wide :: Style
 wide = style { lineLength = 150 }
 
-instance Kit acc => Show (acc aenv a) where
+-- Explicitly enumerate Show instances for the Accelerate array AST types. If we
+-- instead use a generic instance of the form:
+--
+--   instance Kit acc => Show (acc aenv a) where
+--
+-- This matches any type of kind (* -> * -> *), which can cause problems
+-- interacting with other packages. See Issue #108.
+--
+instance Show (OpenAcc aenv a) where
   show c = renderStyle wide $ prettyAcc 0 noParens c
 
+instance Show (DelayedOpenAcc aenv a) where
+  show c = renderStyle wide $ prettyAcc 0 noParens c
+
+-- These parameterised instances are fine because there is a concrete kind
+--
 instance Kit acc => Show (PreOpenAfun acc aenv f) where
   show f = renderStyle wide $ prettyPreAfun prettyAcc 0 f
 
diff --git a/Data/Array/Accelerate/Pretty/HTML.hs b/Data/Array/Accelerate/Pretty/HTML.hs
--- a/Data/Array/Accelerate/Pretty/HTML.hs
+++ b/Data/Array/Accelerate/Pretty/HTML.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP                 #-}
 {-# LANGUAGE GADTs               #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -20,12 +19,7 @@
 ) where
 
 -- standard libraries
-#if !MIN_VERSION_base(4,6,0)
-import Prelude                                                  hiding ( catch )
-import System.IO.Error                                          hiding ( catch )
-#else
 import System.IO.Error
-#endif
 import Control.Exception
 import Data.String
 import Data.Monoid
diff --git a/Data/Array/Accelerate/Pretty/Print.hs b/Data/Array/Accelerate/Pretty/Print.hs
--- a/Data/Array/Accelerate/Pretty/Print.hs
+++ b/Data/Array/Accelerate/Pretty/Print.hs
@@ -52,137 +52,88 @@
 prettyOpenAcc alvl wrap (OpenAcc acc) = prettyPreAcc prettyOpenAcc alvl wrap acc
 
 prettyPreAcc
-    :: forall acc aenv a.
+    :: forall acc aenv arrs.
        PrettyAcc acc
-    -> Int
-    -> (Doc -> Doc)
-    -> PreOpenAcc acc aenv a
+    -> Int                                      -- level of array variables
+    -> (Doc -> Doc)                             -- apply to compound expressions
+    -> PreOpenAcc acc aenv arrs
     -> Doc
-prettyPreAcc pp alvl wrap (Alet acc1 acc2)
-  | not (isAlet acc1') && isAlet acc2'
-  = wrap $ sep [ text "let" <+> a <+> equals <+> acc1' <+> text "in"
-               , acc2' ]
-  --
-  | otherwise
-  = wrap $ sep [ hang (text "let" <+> a <+> equals) 2 acc1'
-               , text "in" <+> acc2' ]
+prettyPreAcc prettyAcc alvl wrap = pp
   where
-    -- TLM: derp, can't unwrap into a PreOpenAcc to pattern match on Alet
-    --
-    isAlet doc  = "let" `isPrefixOf` render doc
+    ppE :: PreOpenExp acc env aenv e -> Doc
+    ppE = prettyPreExp prettyAcc 0 alvl parens
 
-    acc1'       = pp alvl     noParens acc1
-    acc2'       = pp (alvl+1) noParens acc2
-    a           = char 'a' <> int alvl
+    ppF :: PreOpenFun acc env aenv f -> Doc
+    ppF = parens . prettyPreFun prettyAcc alvl
 
+    ppA :: acc aenv a -> Doc
+    ppA = prettyAcc alvl parens
 
-prettyPreAcc _  alvl _    (Avar idx)
-  = text $ 'a' : show (alvl - idxToInt idx - 1)
-prettyPreAcc pp alvl wrap (Aprj ix arrs)
-  = wrap $ char '#' <> prettyTupleIdx ix <+> pp alvl parens arrs
-prettyPreAcc pp alvl _    (Atuple tup)
-  = prettyAtuple pp alvl tup
-prettyPreAcc pp alvl wrap (Apply afun acc)
-  = wrap $ sep [parens (prettyPreAfun pp alvl afun), pp alvl parens acc]
-prettyPreAcc pp alvl wrap (Acond e acc1 acc2)
-  = wrap $ prettyArrOp "cond" [prettyPreExp pp 0 alvl parens e, pp alvl parens acc1, pp alvl parens acc2]
-prettyPreAcc _  _    wrap (Use arr)
-  = wrap $ prettyArrOp "use" [prettyArrays (arrays (undefined::a)) arr]
-prettyPreAcc pp alvl wrap (Unit e)
-  = wrap $ prettyArrOp "unit" [prettyPreExp pp 0 alvl parens e]
-prettyPreAcc pp alvl wrap (Generate sh f)
-  = wrap
-  $ prettyArrOp "generate" [prettyPreExp pp 0 alvl parens sh, parens (prettyPreFun pp alvl f)]
-prettyPreAcc pp alvl wrap (Transform sh ix f acc)
-  = wrap
-  $ prettyArrOp "transform" [ prettyPreExp pp 0 alvl parens sh
-                            , parens (prettyPreFun pp alvl ix)
-                            , parens (prettyPreFun pp alvl f)
-                            , pp alvl parens acc ]
-prettyPreAcc pp alvl wrap (Reshape sh acc)
-  = wrap $ prettyArrOp "reshape" [prettyPreExp pp 0 alvl parens sh, pp alvl parens acc]
-prettyPreAcc pp alvl wrap (Replicate _ty ix acc)
-  = wrap $ prettyArrOp "replicate" [prettyPreExp pp 0 alvl noParens ix, pp alvl parens acc]
-prettyPreAcc pp alvl wrap (Slice _ty acc ix)
-  = wrap $ sep [pp alvl parens acc, char '!', prettyPreExp pp 0 alvl noParens ix]
-prettyPreAcc pp alvl wrap (Map f acc)
-  = wrap $ prettyArrOp "map" [parens (prettyPreFun pp alvl f), pp alvl parens acc]
-prettyPreAcc pp alvl wrap (ZipWith f acc1 acc2)
-  = wrap
-  $ prettyArrOp "zipWith"
-      [parens (prettyPreFun pp alvl f), pp alvl parens acc1, pp alvl parens acc2]
-prettyPreAcc pp alvl wrap (Fold f e acc)
-  = wrap
-  $ prettyArrOp "fold" [parens (prettyPreFun pp alvl f), prettyPreExp pp 0 alvl parens e,
-                        pp alvl parens acc]
-prettyPreAcc pp alvl wrap (Fold1 f acc)
-  = wrap $ prettyArrOp "fold1" [parens (prettyPreFun pp alvl f), pp alvl parens acc]
-prettyPreAcc pp alvl wrap (FoldSeg f e acc1 acc2)
-  = wrap
-  $ prettyArrOp "foldSeg" [parens (prettyPreFun pp alvl f), prettyPreExp pp 0 alvl parens e,
-                           pp alvl parens acc1, pp alvl parens acc2]
-prettyPreAcc pp alvl wrap (Fold1Seg f acc1 acc2)
-  = wrap
-  $ prettyArrOp "fold1Seg" [parens (prettyPreFun pp alvl f), pp alvl parens acc1,
-                            pp alvl parens acc2]
-prettyPreAcc pp alvl wrap (Scanl f e acc)
-  = wrap
-  $ prettyArrOp "scanl" [parens (prettyPreFun pp alvl f), prettyPreExp pp 0 alvl parens e,
-                         pp alvl parens acc]
-prettyPreAcc pp alvl wrap (Scanl' f e acc)
-  = wrap
-  $ prettyArrOp "scanl'" [parens (prettyPreFun pp alvl f), prettyPreExp pp 0 alvl parens e,
-                          pp alvl parens acc]
-prettyPreAcc pp alvl wrap (Scanl1 f acc)
-  = wrap
-  $ prettyArrOp "scanl1" [parens (prettyPreFun pp alvl f), pp alvl parens acc]
-prettyPreAcc pp alvl wrap (Scanr f e acc)
-  = wrap
-  $ prettyArrOp "scanr" [parens (prettyPreFun pp alvl f), prettyPreExp pp 0 alvl parens e,
-                         pp alvl parens acc]
-prettyPreAcc pp alvl wrap (Scanr' f e acc)
-  = wrap
-  $ prettyArrOp "scanr'" [parens (prettyPreFun pp alvl f), prettyPreExp pp 0 alvl parens e,
-                          pp alvl parens acc]
-prettyPreAcc pp alvl wrap (Scanr1 f acc)
-  = wrap
-  $ prettyArrOp "scanr1" [parens (prettyPreFun pp alvl f), pp alvl parens acc]
-prettyPreAcc pp alvl wrap (Permute f dfts p acc)
-  = wrap
-  $ prettyArrOp "permute" [parens (prettyPreFun pp alvl f), pp alvl parens dfts,
-                           parens (prettyPreFun pp alvl p), pp alvl parens acc]
-prettyPreAcc pp alvl wrap (Backpermute sh p acc)
-  = wrap
-  $ prettyArrOp "backpermute" [prettyPreExp pp 0 alvl parens sh,
-                               parens (prettyPreFun pp alvl p),
-                               pp alvl parens acc]
-prettyPreAcc pp alvl wrap (Stencil sten bndy acc)
-  = wrap
-  $ prettyArrOp "stencil" [parens (prettyPreFun pp alvl sten),
-                           prettyBoundary acc bndy,
-                           pp alvl parens acc]
-prettyPreAcc pp alvl wrap (Stencil2 sten bndy1 acc1 bndy2 acc2)
-  = wrap
-  $ prettyArrOp "stencil2" [parens (prettyPreFun pp alvl sten),
-                            prettyBoundary acc1 bndy1,
-                            pp alvl parens acc1,
-                            prettyBoundary acc2 bndy2,
-                            pp alvl parens acc2]
-prettyPreAcc pp alvl wrap (Aforeign ff afun acc)
-  = wrap $ prettyArrOp "aforeign" [text (strForeign ff),
-                                   parens (prettyPreAfun pp alvl afun),
-                                   pp alvl parens acc]
+    ppAF :: PreOpenAfun acc aenv f -> Doc
+    ppAF = parens . prettyPreAfun prettyAcc alvl
 
-prettyBoundary :: forall acc aenv dim e. Elt e
-               => {-dummy-}acc aenv (Array dim e) -> Boundary (EltRepr e) -> Doc
-prettyBoundary _ Clamp        = text "Clamp"
-prettyBoundary _ Mirror       = text "Mirror"
-prettyBoundary _ Wrap         = text "Wrap"
-prettyBoundary _ (Constant e) = parens $ text "Constant" <+> text (show (toElt e :: e))
+    ppB :: forall sh e. Elt e
+        => {-dummy-} acc aenv (Array sh e)
+        -> Boundary (EltRepr e)
+        -> Doc
+    ppB _ Clamp        = text "Clamp"
+    ppB _ Mirror       = text "Mirror"
+    ppB _ Wrap         = text "Wrap"
+    ppB _ (Constant e) = parens $ text "Constant" <+> text (show (toElt e :: e))
 
-prettyArrOp :: String -> [Doc] -> Doc
-prettyArrOp name docs = hang (text name) 2 $ sep docs
+    -- pretty print a named array operation with its arguments
+    name .$ docs = wrap $ hang (text name) 2 (sep docs)
 
+    -- The main pretty-printer
+    -- -----------------------
+    --
+    pp :: PreOpenAcc acc aenv arrs -> Doc
+    pp (Alet acc1 acc2)
+      | not (isAlet acc1') && isAlet acc2'
+      = wrap $ vcat [ text "let" <+> a <+> equals <+> acc1' <+> text "in", acc2' ]
+      | otherwise
+      = wrap $ vcat [ hang (text "let" <+> a <+> equals) 2 acc1', text "in" <+> acc2' ]
+      where
+        -- TLM: derp, can't unwrap into a PreOpenAcc to pattern match on Alet
+        isAlet doc  = "let" `isPrefixOf` render doc
+        acc1'       = prettyAcc alvl     noParens acc1
+        acc2'       = prettyAcc (alvl+1) noParens acc2
+        a           = char 'a' <> int alvl
+
+    pp (Awhile p afun acc)      = "awhile" .$ [ppAF p, ppAF afun, ppA acc]
+    pp (Atuple tup)             = prettyAtuple prettyAcc alvl tup
+    pp (Avar idx)               = text $ 'a' : show (alvl - idxToInt idx - 1)
+    pp (Aprj ix arrs)           = wrap $ char '#' <> prettyTupleIdx ix <+> ppA arrs
+    pp (Apply afun acc)         = wrap $ sep [ ppAF afun, ppA acc ]
+    pp (Acond e acc1 acc2)      = wrap $ sep [ ppE e, text "?|", tuple [ppA acc1, ppA acc2] ]
+    pp (Slice _ty acc ix)       = wrap $ sep [ ppA acc, char '!', prettyPreExp prettyAcc 0 alvl noParens ix ]
+    pp (Use arrs)               = "use"         .$ [ prettyArrays (arrays (undefined :: arrs)) arrs ]
+    pp (Unit e)                 = "unit"        .$ [ ppE e ]
+    pp (Generate sh f)          = "generate"    .$ [ ppE sh, ppF f ]
+    pp (Transform sh ix f acc)  = "transform"   .$ [ ppE sh, ppF ix, ppF f, ppA acc ]
+    pp (Reshape sh acc)         = "reshape"     .$ [ ppE sh, ppA acc ]
+    pp (Replicate _ty ix acc)   = "replicate"   .$ [ prettyPreExp prettyAcc 0 alvl noParens ix, ppA acc ]
+    pp (Map f acc)              = "map"         .$ [ ppF f, ppA acc ]
+    pp (ZipWith f acc1 acc2)    = "zipWith"     .$ [ ppF f, ppA acc1, ppA acc2 ]
+    pp (Fold f e acc)           = "fold"        .$ [ ppF f, ppE e, ppA acc ]
+    pp (Fold1 f acc)            = "fold1"       .$ [ ppF f, ppA acc ]
+    pp (FoldSeg f e acc1 acc2)  = "foldSeg"     .$ [ ppF f, ppE e, ppA acc1, ppA acc2 ]
+    pp (Fold1Seg f acc1 acc2)   = "fold1Seg"    .$ [ ppF f, ppA acc1, ppA acc2 ]
+    pp (Scanl f e acc)          = "scanl"       .$ [ ppF f, ppE e, ppA acc ]
+    pp (Scanl' f e acc)         = "scanl'"      .$ [ ppF f, ppE e, ppA acc ]
+    pp (Scanl1 f acc)           = "scanl1"      .$ [ ppF f, ppA acc ]
+    pp (Scanr f e acc)          = "scanr"       .$ [ ppF f, ppE e, ppA acc ]
+    pp (Scanr' f e acc)         = "scanr'"      .$ [ ppF f, ppE e, ppA acc ]
+    pp (Scanr1 f acc)           = "scanr1"      .$ [ ppF f, ppA acc ]
+    pp (Permute f dfts p acc)   = "permute"     .$ [ ppF f, ppA dfts, ppF p, ppA acc ]
+    pp (Backpermute sh p acc)   = "backpermute" .$ [ ppE sh, ppF p, ppA acc ]
+    pp (Aforeign ff _afun acc)  = "aforeign"    .$ [ text (strForeign ff), {- ppAf afun, -} ppA acc ]
+    pp (Stencil sten bndy acc)  = "stencil"     .$ [ ppF sten, ppB acc bndy, ppA acc ]
+    pp (Stencil2 sten bndy1 acc1 bndy2 acc2)
+                                = "stencil2"    .$ [ ppF sten, ppB acc1 bndy1, ppA acc1,
+                                                               ppB acc2 bndy2, ppA acc2 ]
+
+
 -- Pretty print a function over array computations.
 --
 prettyAfun :: Int -> OpenAfun aenv t -> Doc
@@ -225,93 +176,81 @@
 prettyExp :: Int -> Int -> (Doc -> Doc) -> OpenExp env aenv t -> Doc
 prettyExp = prettyPreExp prettyOpenAcc
 
-prettyPreExp :: forall acc t env aenv.
-                PrettyAcc acc -> Int -> Int -> (Doc -> Doc) -> PreOpenExp acc env aenv t -> Doc
-prettyPreExp pp lvl alvl wrap (Let e1 e2)
-  | not (isLet e1) && isLet e2
-  = wrap $ sep [ text "let" <+> x <+> equals <+> e1' <+> text "in"
-               , e2' ]
-  --
-  | otherwise
-  = wrap $ sep [ hang (text "let" <+> x <+> equals) 2 e1'
-               , text "in" <+> e2' ]
+prettyPreExp
+    :: forall acc t env aenv.
+       PrettyAcc acc
+    -> Int                                      -- level of scalar variables
+    -> Int                                      -- level of array variables
+    -> (Doc -> Doc)                             -- apply to compound expressions
+    -> PreOpenExp acc env aenv t
+    -> Doc
+prettyPreExp prettyAcc lvl alvl wrap = pp
   where
-    isLet (Let _ _)     = True
-    isLet _             = False
-    e1'                 = prettyPreExp pp lvl     alvl noParens e1
-    e2'                 = prettyPreExp pp (lvl+1) alvl noParens e2
-    x                   = char 'x' <> int lvl
+    ppE, ppE' :: PreOpenExp acc env aenv e -> Doc
+    ppE  = prettyPreExp prettyAcc lvl alvl parens
+    ppE' = prettyPreExp prettyAcc lvl alvl noParens
 
-prettyPreExp _pp lvl _ _ (Var idx)
-  = text $ 'x' : show (lvl - idxToInt idx - 1)
-prettyPreExp _pp _ _ _ (Const v)
-  = text $ show (toElt v :: t)
-prettyPreExp pp lvl alvl _ (Tuple tup)
-  = prettyTuple pp lvl alvl tup
-prettyPreExp pp lvl alvl wrap (Prj idx e)
-  = wrap $ char '#' <> prettyTupleIdx idx <+> prettyPreExp pp lvl alvl parens e
-prettyPreExp _pp _lvl _alvl _wrap IndexNil
-  = char 'Z'
-prettyPreExp pp lvl alvl wrap (IndexCons t h)
-  = wrap $ prettyPreExp pp lvl alvl noParens t <+> text ":." <+> prettyPreExp pp lvl alvl noParens h
-prettyPreExp pp lvl alvl wrap (IndexHead ix)
-  = wrap $ text "indexHead" <+> prettyPreExp pp lvl alvl parens ix
-prettyPreExp pp lvl alvl wrap (IndexTail ix)
-  = wrap $ text "indexTail" <+> prettyPreExp pp lvl alvl parens ix
-prettyPreExp _ _ _ wrap (IndexAny)
-  = wrap $ text "indexAny"
-prettyPreExp pp lvl alvl wrap (IndexSlice _ slix sh)
-  = wrap $ text "indexSlice" <+> sep [ prettyPreExp pp lvl alvl parens slix
-                                     , prettyPreExp pp lvl alvl parens sh ]
-prettyPreExp pp lvl alvl wrap (IndexFull _ slix sl)
-  = wrap $ text "indexFull" <+> sep [ prettyPreExp pp lvl alvl parens slix
-                                    , prettyPreExp pp lvl alvl parens sl ]
-prettyPreExp pp lvl alvl wrap (ToIndex sh ix)
-  = wrap $ text "toIndex" <+> sep [ prettyPreExp pp lvl alvl parens sh
-                                  , prettyPreExp pp lvl alvl parens ix ]
-prettyPreExp pp lvl alvl wrap (FromIndex sh ix)
-  = wrap $ text "fromIndex" <+> sep [ prettyPreExp pp lvl alvl parens sh
-                                    , prettyPreExp pp lvl alvl parens ix ]
-prettyPreExp pp lvl alvl wrap (Cond c t e)
-  = wrap $ sep [ prettyPreExp pp lvl alvl parens c <+> char '?',
-                 tuple [ prettyPreExp pp lvl alvl noParens t
-                       , prettyPreExp pp lvl alvl noParens e ] ]
-prettyPreExp pp lvl alvl wrap (Iterate i fun a)
-  = wrap $ text "iterate" <>  brackets (prettyPreExp pp lvl alvl id i)
-                          <+> sep [ wrap   (prettyPreExp pp lvl alvl parens a)
-                                  , parens (prettyPreOpenFun pp lvl alvl (Lam (Body fun))) ]
-prettyPreExp pp lvl alvl wrap (Foreign ff f e)
-  = wrap $ text "foreign" <+> text (strForeign ff)
-                          <+> prettyPreFun pp alvl f
-                          <+> prettyPreExp pp lvl alvl parens e
+    ppF :: PreOpenFun acc env aenv f -> Doc
+    ppF = parens . prettyPreOpenFun prettyAcc lvl alvl
 
-prettyPreExp _pp _ _ _ (PrimConst a)
- = prettyConst a
-prettyPreExp pp lvl alvl wrap (PrimApp p a)
-  | infixOp, Tuple (NilTup `SnocTup` x `SnocTup` y) <- a
-  = wrap $ prettyPreExp pp lvl alvl parens x <+> f <+> prettyPreExp pp lvl alvl parens y
+    ppA :: acc aenv a -> Doc
+    ppA = prettyAcc alvl parens
 
-  | otherwise
-  = wrap $ f' <+> prettyPreExp pp lvl alvl parens a
-  where
-    -- sometimes the infix function arguments are obstructed by. If so, add
-    -- parentheses and print prefix.
+    -- pretty print a named array operation with its arguments
+    name .$ docs = wrap $ text name <+> sep docs
+
+    -- The main pretty-printer
+    -- -----------------------
     --
-    (infixOp, f) = prettyPrim p
-    f'           = if infixOp then parens f else f
+    pp :: PreOpenExp acc env aenv t -> Doc
+    pp (Let e1 e2)
+      | not (isLet e1) && isLet e2
+      = wrap $ vcat [ text "let" <+> x <+> equals <+> e1' <+> text "in", e2' ]
+      | otherwise
+      = wrap $ vcat [ hang (text "let" <+> x <+> equals) 2 e1', text "in" <+> e2' ]
+      where
+        isLet (Let _ _)     = True
+        isLet _             = False
+        e1'                 = prettyPreExp prettyAcc lvl     alvl noParens e1
+        e2'                 = prettyPreExp prettyAcc (lvl+1) alvl noParens e2
+        x                   = char 'x' <> int lvl
 
-prettyPreExp pp lvl alvl wrap (Index idx i)
-  = wrap $ cat [pp alvl parens idx, char '!', prettyPreExp pp lvl alvl parens i]
-prettyPreExp pp lvl alvl wrap (LinearIndex idx i)
-  = wrap $ cat [pp alvl parens idx, text "!!", prettyPreExp pp lvl alvl parens i]
-prettyPreExp pp _lvl alvl wrap (Shape idx)
-  = wrap $ text "shape" <+> pp alvl parens idx
-prettyPreExp pp lvl alvl wrap (ShapeSize idx)
-  = wrap $ text "shapeSize" <+> parens (prettyPreExp pp lvl alvl parens idx)
-prettyPreExp pp lvl alvl wrap (Intersect sh1 sh2)
-  = wrap $ text "intersect" <+> sep [ prettyPreExp pp lvl alvl parens sh1
-                                    , prettyPreExp pp lvl alvl parens sh2 ]
+    pp (PrimApp p a)
+      | infixOp, Tuple (NilTup `SnocTup` x `SnocTup` y) <- a
+      = wrap $ ppE x <+> f <+> ppE y
+      | otherwise
+      = wrap $ f' <+> ppE a
+      where
+        -- sometimes the infix function arguments are obstructed. If so, add
+        -- parentheses and print prefix.
+        --
+        (infixOp, f) = prettyPrim p
+        f'           = if infixOp then parens f else f
 
+    pp (PrimConst a)            = prettyConst a
+    pp (Tuple tup)              = prettyTuple prettyAcc lvl alvl tup
+    pp (Var idx)                = text $ 'x' : show (lvl - idxToInt idx - 1)
+    pp (Const v)                = text $ show (toElt v :: t)
+    pp (Prj idx e)              = wrap $ char '#' <> prettyTupleIdx idx <+> ppE e
+    pp (Cond c t e)             = wrap $ sep [ ppE c, char '?' , tuple [ ppE' t, ppE' e ]]
+    pp IndexNil                 = char 'Z'
+    pp (IndexAny)               = text "indexAny"
+    pp (IndexCons t h)          = wrap $ ppE' t <+> text ":." <+> ppE' h
+    pp (IndexHead ix)           = "indexHead"  .$ [ ppE ix ]
+    pp (IndexTail ix)           = "indexTail"  .$ [ ppE ix ]
+    pp (IndexSlice _ slix sh)   = "indexSlice" .$ [ ppE slix, ppE sh ]
+    pp (IndexFull _ slix sl)    = "indexFull"  .$ [ ppE slix, ppE sl ]
+    pp (ToIndex sh ix)          = "toIndex"    .$ [ ppE sh, ppE ix ]
+    pp (FromIndex sh ix)        = "fromIndex"  .$ [ ppE sh, ppE ix ]
+    pp (While p f x)            = "while"      .$ [ ppF p, ppF f, ppE x ]
+    pp (Foreign ff _f e)        = "foreign"    .$ [ text (strForeign ff), {- ppF f, -} ppE e ]
+    pp (Shape idx)              = "shape"      .$ [ ppA idx ]
+    pp (ShapeSize idx)          = "shapeSize"  .$ [ parens (ppE idx) ]
+    pp (Intersect sh1 sh2)      = "intersect"  .$ [ ppE sh1, ppE sh2 ]
+    pp (Index idx i)            = wrap $ cat [ ppA idx, char '!',  ppE i ]
+    pp (LinearIndex idx i)      = wrap $ cat [ ppA idx, text "!!", ppE i ]
+
+
 -- Pretty print nested pairs as a proper tuple.
 --
 prettyAtuple :: forall acc aenv t.
@@ -454,7 +393,7 @@
   case ds of
     []  -> left <> right
     [d] -> left <> d <> right
-    _   -> left <> sep (punctuate p ds) <> right
+    _   -> cat (zipWith (<>) (left : repeat p) ds) <> right
 
 
 -- Auxiliary ops
diff --git a/Data/Array/Accelerate/Pretty/Traverse.hs b/Data/Array/Accelerate/Pretty/Traverse.hs
--- a/Data/Array/Accelerate/Pretty/Traverse.hs
+++ b/Data/Array/Accelerate/Pretty/Traverse.hs
@@ -43,6 +43,7 @@
     travAcc' (Apply afun acc)                      = combine "Apply" [travAfun f c l afun, travAcc f c l acc]
     travAcc' (Aforeign ff afun acc)                = combine ("Aforeign " ++ strForeign ff) [travAfun f c l afun, travAcc f c l acc]
     travAcc' (Acond e acc1 acc2)                   = combine "Acond" [travExp f c l e, travAcc f c l acc1, travAcc f c l acc2]
+    travAcc' (Awhile cond body acc)                = combine "Awhile" [travAfun f c l cond, travAfun f c l body, travAcc f c l acc]
     travAcc' (Atuple tup)                          = combine "Atuple" [ travAtuple f c l tup ]
     travAcc' (Aprj idx a)                          = combine ("Aprj " `cat` tupleIdxToInt idx) [ travAcc f c l a ]
     travAcc' (Use arr)                             = combine "Use" [ travArrays f c l (arrays (undefined::a)) arr ]
@@ -99,7 +100,7 @@
     travExp' (ToIndex sh ix)            = combine "ToIndex" [ travExp f c l sh, travExp f c l ix ]
     travExp' (FromIndex sh ix)          = combine "FromIndex" [ travExp f c l sh, travExp f c l ix ]
     travExp' (Cond cond thn els)        = combine "Cond" [travExp f c l cond, travExp f c l thn, travExp f c l els]
-    travExp' (Iterate _ fun x)          = combine "Iterate" [ travFun f c l (Lam (Body fun)), travExp f c l x ]
+    travExp' (While cond body x)        = combine "While" [ travFun f c l cond, travFun f c l body, travExp f c l x ]
     travExp' (PrimConst a)              = leaf ("PrimConst " `cat` labelForConst a)
     travExp' (PrimApp p a)              = combine "PrimApp" [ l (primFunFormat f) (labelForPrimFun p), travExp f c l a ]
     travExp' (Index idx i)              = combine "Index" [ travAcc f c l idx, travExp f c l i]
diff --git a/Data/Array/Accelerate/Smart.hs b/Data/Array/Accelerate/Smart.hs
--- a/Data/Array/Accelerate/Smart.hs
+++ b/Data/Array/Accelerate/Smart.hs
@@ -99,168 +99,174 @@
 --
 data PreAcc acc exp as where
     -- Needed for conversion to de Bruijn form
-  Atag        :: Arrays as
-              => Level                      -- environment size at defining occurrence
-              -> PreAcc acc exp as
+  Atag          :: Arrays as
+                => Level                        -- environment size at defining occurrence
+                -> PreAcc acc exp as
 
-  Pipe        :: (Arrays as, Arrays bs, Arrays cs)
-              => (Acc as -> Acc bs)         -- see comment above on why 'Acc' and not 'acc'
-              -> (Acc bs -> Acc cs)
-              -> acc as
-              -> PreAcc acc exp cs
+  Pipe          :: (Arrays as, Arrays bs, Arrays cs)
+                => (Acc as -> Acc bs)           -- see comment above on why 'Acc' and not 'acc'
+                -> (Acc bs -> Acc cs)
+                -> acc as
+                -> PreAcc acc exp cs
 
-  Aforeign    :: (Arrays arrs, Arrays a, Foreign f)
-              => f arrs a
-              -> (Acc arrs -> Acc a)
-              -> acc arrs
-              -> PreAcc acc exp a
+  Aforeign      :: (Arrays arrs, Arrays a, Foreign f)
+                => f arrs a
+                -> (Acc arrs -> Acc a)
+                -> acc arrs
+                -> PreAcc acc exp a
 
-  Acond       :: (Arrays as)
-              => exp Bool
-              -> acc as
-              -> acc as
-              -> PreAcc acc exp as
+  Acond         :: Arrays as
+                => exp Bool
+                -> acc as
+                -> acc as
+                -> PreAcc acc exp as
 
-  Atuple      :: (Arrays arrs, IsTuple arrs)
-              => Tuple.Atuple acc (TupleRepr arrs)
-              -> PreAcc acc exp arrs
+  Awhile        :: Arrays arrs
+                => (Acc arrs -> acc (Scalar Bool))
+                -> (Acc arrs -> acc arrs)
+                -> acc arrs
+                -> PreAcc acc exp arrs
 
-  Aprj        :: (Arrays arrs, IsTuple arrs, Arrays a)
-              => TupleIdx (TupleRepr arrs) a
-              ->        acc     arrs
-              -> PreAcc acc exp a
+  Atuple        :: (Arrays arrs, IsTuple arrs)
+                => Tuple.Atuple acc (TupleRepr arrs)
+                -> PreAcc acc exp arrs
 
-  Use         :: Arrays arrs
-              => arrs
-              -> PreAcc acc exp arrs
+  Aprj          :: (Arrays arrs, IsTuple arrs, Arrays a)
+                => TupleIdx (TupleRepr arrs) a
+                ->        acc     arrs
+                -> PreAcc acc exp a
 
-  Unit        :: Elt e
-              => exp e
-              -> PreAcc acc exp (Scalar e)
+  Use           :: Arrays arrs
+                => arrs
+                -> PreAcc acc exp arrs
 
-  Generate    :: (Shape sh, Elt e)
-              => exp sh
-              -> (Exp sh -> exp e)
-              -> PreAcc acc exp (Array sh e)
+  Unit          :: Elt e
+                => exp e
+                -> PreAcc acc exp (Scalar e)
 
-  Reshape     :: (Shape sh, Shape sh', Elt e)
-              => exp sh
-              -> acc (Array sh' e)
-              -> PreAcc acc exp (Array sh e)
+  Generate      :: (Shape sh, Elt e)
+                => exp sh
+                -> (Exp sh -> exp e)
+                -> PreAcc acc exp (Array sh e)
 
-  Replicate   :: (Slice slix, Elt e,
-                  Typeable (SliceShape slix), Typeable (FullShape slix))
-                  -- the Typeable constraints shouldn't be necessary as they are implied by
-                  -- 'SliceIx slix' — unfortunately, the (old) type checker doesn't grok that
-              => exp slix
-              -> acc            (Array (SliceShape slix) e)
-              -> PreAcc acc exp (Array (FullShape  slix) e)
+  Reshape       :: (Shape sh, Shape sh', Elt e)
+                => exp sh
+                -> acc (Array sh' e)
+                -> PreAcc acc exp (Array sh e)
 
-  Slice       :: (Slice slix, Elt e,
-                  Typeable (SliceShape slix), Typeable (FullShape slix))
-                  -- the Typeable constraints shouldn't be necessary as they are implied by
-                  -- 'SliceIx slix' — unfortunately, the (old) type checker doesn't grok that
-              => acc            (Array (FullShape  slix) e)
-              -> exp slix
-              -> PreAcc acc exp (Array (SliceShape slix) e)
+  Replicate     :: (Slice slix, Elt e,
+                    Typeable (SliceShape slix), Typeable (FullShape slix))
+                    -- the Typeable constraints shouldn't be necessary as they are implied by
+                    -- 'SliceIx slix' — unfortunately, the (old) type checker doesn't grok that
+                => exp slix
+                -> acc            (Array (SliceShape slix) e)
+                -> PreAcc acc exp (Array (FullShape  slix) e)
 
-  Map         :: (Shape sh, Elt e, Elt e')
-              => (Exp e -> exp e')
-              -> acc (Array sh e)
-              -> PreAcc acc exp (Array sh e')
+  Slice         :: (Slice slix, Elt e,
+                    Typeable (SliceShape slix), Typeable (FullShape slix))
+                    -- the Typeable constraints shouldn't be necessary as they are implied by
+                    -- 'SliceIx slix' — unfortunately, the (old) type checker doesn't grok that
+                => acc            (Array (FullShape  slix) e)
+                -> exp slix
+                -> PreAcc acc exp (Array (SliceShape slix) e)
 
-  ZipWith     :: (Shape sh, Elt e1, Elt e2, Elt e3)
-              => (Exp e1 -> Exp e2 -> exp e3)
-              -> acc (Array sh e1)
-              -> acc (Array sh e2)
-              -> PreAcc acc exp (Array sh e3)
+  Map           :: (Shape sh, Elt e, Elt e')
+                => (Exp e -> exp e')
+                -> acc (Array sh e)
+                -> PreAcc acc exp (Array sh e')
 
-  Fold        :: (Shape sh, Elt e)
-              => (Exp e -> Exp e -> exp e)
-              -> exp e
-              -> acc (Array (sh:.Int) e)
-              -> PreAcc acc exp (Array sh e)
+  ZipWith       :: (Shape sh, Elt e1, Elt e2, Elt e3)
+                => (Exp e1 -> Exp e2 -> exp e3)
+                -> acc (Array sh e1)
+                -> acc (Array sh e2)
+                -> PreAcc acc exp (Array sh e3)
 
-  Fold1       :: (Shape sh, Elt e)
-              => (Exp e -> Exp e -> exp e)
-              -> acc (Array (sh:.Int) e)
-              -> PreAcc acc exp (Array sh e)
+  Fold          :: (Shape sh, Elt e)
+                => (Exp e -> Exp e -> exp e)
+                -> exp e
+                -> acc (Array (sh:.Int) e)
+                -> PreAcc acc exp (Array sh e)
 
-  FoldSeg     :: (Shape sh, Elt e, Elt i, IsIntegral i)
-              => (Exp e -> Exp e -> exp e)
-              -> exp e
-              -> acc (Array (sh:.Int) e)
-              -> acc (Segments i)
-              -> PreAcc acc exp (Array (sh:.Int) e)
+  Fold1         :: (Shape sh, Elt e)
+                => (Exp e -> Exp e -> exp e)
+                -> acc (Array (sh:.Int) e)
+                -> PreAcc acc exp (Array sh e)
 
-  Fold1Seg    :: (Shape sh, Elt e, Elt i, IsIntegral i)
-              => (Exp e -> Exp e -> exp e)
-              -> acc (Array (sh:.Int) e)
-              -> acc (Segments i)
-              -> PreAcc acc exp (Array (sh:.Int) e)
+  FoldSeg       :: (Shape sh, Elt e, Elt i, IsIntegral i)
+                => (Exp e -> Exp e -> exp e)
+                -> exp e
+                -> acc (Array (sh:.Int) e)
+                -> acc (Segments i)
+                -> PreAcc acc exp (Array (sh:.Int) e)
 
-  Scanl       :: Elt e
-              => (Exp e -> Exp e -> exp e)
-              -> exp e
-              -> acc (Vector e)
-              -> PreAcc acc exp (Vector e)
+  Fold1Seg      :: (Shape sh, Elt e, Elt i, IsIntegral i)
+                => (Exp e -> Exp e -> exp e)
+                -> acc (Array (sh:.Int) e)
+                -> acc (Segments i)
+                -> PreAcc acc exp (Array (sh:.Int) e)
 
-  Scanl'      :: Elt e
-              => (Exp e -> Exp e -> exp e)
-              -> exp e
-              -> acc (Vector e)
-              -> PreAcc acc exp (Vector e, Scalar e)
+  Scanl         :: Elt e
+                => (Exp e -> Exp e -> exp e)
+                -> exp e
+                -> acc (Vector e)
+                -> PreAcc acc exp (Vector e)
 
-  Scanl1      :: Elt e
-              => (Exp e -> Exp e -> exp e)
-              -> acc (Vector e)
-              -> PreAcc acc exp (Vector e)
+  Scanl'        :: Elt e
+                => (Exp e -> Exp e -> exp e)
+                -> exp e
+                -> acc (Vector e)
+                -> PreAcc acc exp (Vector e, Scalar e)
 
-  Scanr       :: Elt e
-              => (Exp e -> Exp e -> exp e)
-              -> exp e
-              -> acc (Vector e)
-              -> PreAcc acc exp (Vector e)
+  Scanl1        :: Elt e
+                => (Exp e -> Exp e -> exp e)
+                -> acc (Vector e)
+                -> PreAcc acc exp (Vector e)
 
-  Scanr'      :: Elt e
-              => (Exp e -> Exp e -> exp e)
-              -> exp e
-              -> acc (Vector e)
-              -> PreAcc acc exp (Vector e, Scalar e)
+  Scanr         :: Elt e
+                => (Exp e -> Exp e -> exp e)
+                -> exp e
+                -> acc (Vector e)
+                -> PreAcc acc exp (Vector e)
 
-  Scanr1      :: Elt e
-              => (Exp e -> Exp e -> exp e)
-              -> acc (Vector e)
-              -> PreAcc acc exp (Vector e)
+  Scanr'        :: Elt e
+                => (Exp e -> Exp e -> exp e)
+                -> exp e
+                -> acc (Vector e)
+                -> PreAcc acc exp (Vector e, Scalar e)
 
-  Permute     :: (Shape sh, Shape sh', Elt e)
-              => (Exp e -> Exp e -> exp e)
-              -> acc (Array sh' e)
-              -> (Exp sh -> exp sh')
-              -> acc (Array sh e)
-              -> PreAcc acc exp (Array sh' e)
+  Scanr1        :: Elt e
+                => (Exp e -> Exp e -> exp e)
+                -> acc (Vector e)
+                -> PreAcc acc exp (Vector e)
 
-  Backpermute :: (Shape sh, Shape sh', Elt e)
-              => exp sh'
-              -> (Exp sh' -> exp sh)
-              -> acc (Array sh e)
-              -> PreAcc acc exp (Array sh' e)
+  Permute       :: (Shape sh, Shape sh', Elt e)
+                => (Exp e -> Exp e -> exp e)
+                -> acc (Array sh' e)
+                -> (Exp sh -> exp sh')
+                -> acc (Array sh e)
+                -> PreAcc acc exp (Array sh' e)
 
-  Stencil     :: (Shape sh, Elt a, Elt b, Stencil sh a stencil)
-              => (stencil -> exp b)
-              -> Boundary a
-              -> acc (Array sh a)
-              -> PreAcc acc exp (Array sh b)
+  Backpermute   :: (Shape sh, Shape sh', Elt e)
+                => exp sh'
+                -> (Exp sh' -> exp sh)
+                -> acc (Array sh e)
+                -> PreAcc acc exp (Array sh' e)
 
-  Stencil2    :: (Shape sh, Elt a, Elt b, Elt c,
-                 Stencil sh a stencil1, Stencil sh b stencil2)
-              => (stencil1 -> stencil2 -> exp c)
-              -> Boundary a
-              -> acc (Array sh a)
-              -> Boundary b
-              -> acc (Array sh b)
-              -> PreAcc acc exp (Array sh c)
+  Stencil       :: (Shape sh, Elt a, Elt b, Stencil sh a stencil)
+                => (stencil -> exp b)
+                -> Boundary a
+                -> acc (Array sh a)
+                -> PreAcc acc exp (Array sh b)
 
+  Stencil2      :: (Shape sh, Elt a, Elt b, Elt c,
+                   Stencil sh a stencil1, Stencil sh b stencil2)
+                => (stencil1 -> stencil2 -> exp c)
+                -> Boundary a
+                -> acc (Array sh a)
+                -> Boundary b
+                -> acc (Array sh b)
+                -> PreAcc acc exp (Array sh c)
+
 -- |Array-valued collective computations
 --
 newtype Acc a = Acc (PreAcc Acc Exp a)
@@ -282,51 +288,102 @@
 --
 data PreExp acc exp t where
     -- Needed for conversion to de Bruijn form
-  Tag         :: Elt t
-              => Level                          -> PreExp acc exp t
-                 -- environment size at defining occurrence
+  Tag           :: Elt t
+                => Level                        -- environment size at defining occurrence
+                -> PreExp acc exp t
 
   -- All the same constructors as 'AST.Exp'
-  Const       :: Elt t
-              => t                              -> PreExp acc exp t
+  Const         :: Elt t
+                => t
+                -> PreExp acc exp t
 
-  Tuple       :: (Elt t, IsTuple t)
-              => Tuple.Tuple exp (TupleRepr t)  -> PreExp acc exp t
-  Prj         :: (Elt t, IsTuple t, Elt e)
-              => TupleIdx (TupleRepr t) e
-              -> exp t                          -> PreExp acc exp e
-  IndexNil    ::                                   PreExp acc exp Z
-  IndexCons   :: (Slice sl, Elt a)
-              => exp sl -> exp a                -> PreExp acc exp (sl:.a)
-  IndexHead   :: (Slice sl, Elt a)
-              => exp (sl:.a)                    -> PreExp acc exp a
-  IndexTail   :: (Slice sl, Elt a)
-              => exp (sl:.a)                    -> PreExp acc exp sl
-  IndexAny    :: Shape sh
-              =>                                   PreExp acc exp (Any sh)
-  ToIndex     :: Shape sh
-              => exp sh -> exp sh               -> PreExp acc exp Int
-  FromIndex   :: Shape sh
-              => exp sh -> exp Int              -> PreExp acc exp sh
-  Cond        :: Elt t
-              => exp Bool -> exp t -> exp t     -> PreExp acc exp t
-  PrimConst   :: Elt t
-              => PrimConst t                    -> PreExp acc exp t
-  PrimApp     :: (Elt a, Elt r)
-              => PrimFun (a -> r) -> exp a      -> PreExp acc exp r
-  Index       :: (Shape sh, Elt t)
-              => acc (Array sh t) -> exp sh     -> PreExp acc exp t
-  LinearIndex :: (Shape sh, Elt t)
-              => acc (Array sh t) -> exp Int    -> PreExp acc exp t
-  Shape       :: (Shape sh, Elt e)
-              => acc (Array sh e)               -> PreExp acc exp sh
-  ShapeSize   :: Shape sh
-              => exp sh                         -> PreExp acc exp Int
-  Foreign     :: (Elt x, Elt y, Foreign f)
-              => f x y
-              -> (Exp x -> Exp y) -- RCE: Using Exp instead of exp to aid in sharing recovery.
-              -> exp x                          -> PreExp acc exp y
+  Tuple         :: (Elt t, IsTuple t)
+                => Tuple.Tuple exp (TupleRepr t)
+                -> PreExp acc exp t
 
+  Prj           :: (Elt t, IsTuple t, Elt e)
+                => TupleIdx (TupleRepr t) e
+                -> exp t
+                -> PreExp acc exp e
+
+  IndexNil      :: PreExp acc exp Z
+
+  IndexCons     :: (Slice sl, Elt a)
+                => exp sl
+                -> exp a
+                -> PreExp acc exp (sl:.a)
+
+  IndexHead     :: (Slice sl, Elt a)
+                => exp (sl:.a)
+                -> PreExp acc exp a
+
+  IndexTail     :: (Slice sl, Elt a)
+                => exp (sl:.a)
+                -> PreExp acc exp sl
+
+  IndexAny      :: Shape sh
+                => PreExp acc exp (Any sh)
+
+  ToIndex       :: Shape sh
+                => exp sh
+                -> exp sh
+                -> PreExp acc exp Int
+
+  FromIndex     :: Shape sh
+                => exp sh
+                -> exp Int
+                -> PreExp acc exp sh
+
+  Cond          :: Elt t
+                => exp Bool
+                -> exp t
+                -> exp t
+                -> PreExp acc exp t
+
+  While         :: Elt t
+                => (Exp t -> exp Bool)
+                -> (Exp t -> exp t)
+                -> exp t
+                -> PreExp acc exp t
+
+  PrimConst     :: Elt t
+                => PrimConst t
+                -> PreExp acc exp t
+
+  PrimApp       :: (Elt a, Elt r)
+                => PrimFun (a -> r)
+                -> exp a
+                -> PreExp acc exp r
+
+  Index         :: (Shape sh, Elt t)
+                => acc (Array sh t)
+                -> exp sh
+                -> PreExp acc exp t
+
+  LinearIndex   :: (Shape sh, Elt t)
+                => acc (Array sh t)
+                -> exp Int
+                -> PreExp acc exp t
+
+  Shape         :: (Shape sh, Elt e)
+                => acc (Array sh e)
+                -> PreExp acc exp sh
+
+  ShapeSize     :: Shape sh
+                => exp sh
+                -> PreExp acc exp Int
+
+  Intersect     :: Shape sh
+                => exp sh
+                -> exp sh
+                -> PreExp acc exp sh
+
+  Foreign       :: (Elt x, Elt y, Foreign f)
+                => f x y
+                -> (Exp x -> Exp y) -- RCE: Using Exp instead of exp to aid in sharing recovery.
+                -> exp x
+                -> PreExp acc exp y
+
 -- | Scalar expressions for plain array computations.
 --
 newtype Exp t = Exp (PreExp Acc Exp t)
@@ -988,6 +1045,7 @@
 showPreAccOp (Use a)            = "Use "  ++ showArrays a
 showPreAccOp Pipe{}             = "Pipe"
 showPreAccOp Acond{}            = "Acond"
+showPreAccOp Awhile{}           = "Awhile"
 showPreAccOp Atuple{}           = "Atuple"
 showPreAccOp Aprj{}             = "Aprj"
 showPreAccOp Unit{}             = "Unit"
@@ -1036,7 +1094,7 @@
 
 showPreExpOp :: PreExp acc exp t -> String
 showPreExpOp (Const c)          = "Const " ++ show c
-showPreExpOp Tag{}              = "Tag"
+showPreExpOp (Tag i)            = "Tag" ++ show i
 showPreExpOp Tuple{}            = "Tuple"
 showPreExpOp Prj{}              = "Prj"
 showPreExpOp IndexNil           = "IndexNil"
@@ -1047,11 +1105,13 @@
 showPreExpOp ToIndex{}          = "ToIndex"
 showPreExpOp FromIndex{}        = "FromIndex"
 showPreExpOp Cond{}             = "Cond"
+showPreExpOp While{}            = "While"
 showPreExpOp PrimConst{}        = "PrimConst"
 showPreExpOp PrimApp{}          = "PrimApp"
 showPreExpOp Index{}            = "Index"
 showPreExpOp LinearIndex{}      = "LinearIndex"
 showPreExpOp Shape{}            = "Shape"
 showPreExpOp ShapeSize{}        = "ShapeSize"
+showPreExpOp Intersect{}        = "Intersect"
 showPreExpOp Foreign{}          = "Foreign"
 
diff --git a/Data/Array/Accelerate/Trafo.hs b/Data/Array/Accelerate/Trafo.hs
--- a/Data/Array/Accelerate/Trafo.hs
+++ b/Data/Array/Accelerate/Trafo.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP                  #-}
 {-# LANGUAGE FlexibleContexts     #-}
 {-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE RecordWildCards      #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# OPTIONS_HADDOCK hide #-}
@@ -84,7 +85,11 @@
   , convertOffsetOfSegment = False
   }
 
+when :: (a -> a) -> Bool -> a -> a
+when f True  = f
+when _ False = id
 
+
 -- HOAS -> de Bruijn conversion
 -- ----------------------------
 
@@ -95,14 +100,11 @@
 convertAcc = convertAccWith phases
 
 convertAccWith :: Arrays arrs => Phase -> Acc arrs -> DelayedAcc arrs
-convertAccWith ok acc
-  = Fusion.convertAcc    -- `when` enableAccFusion
+convertAccWith Phase{..} acc
+  = Fusion.convertAcc enableAccFusion
   $ Rewrite.convertSegments `when` convertOffsetOfSegment
-  $ Sharing.convertAcc (recoverAccSharing ok) (recoverExpSharing ok) (floatOutAccFromExp ok) acc
-  where
-    when f phase
-      | phase ok        = f
-      | otherwise       = id
+  $ Sharing.convertAcc recoverAccSharing recoverExpSharing floatOutAccFromExp
+  $ acc
 
 
 -- | Convert a unary function over array computations, incorporating sharing
@@ -112,14 +114,11 @@
 convertAfun = convertAfunWith phases
 
 convertAfunWith :: Afunction f => Phase -> f -> DelayedAfun (AfunctionR f)
-convertAfunWith ok acc
-  = Fusion.convertAfun       -- `when` enableAccFusion
+convertAfunWith Phase{..} acc
+  = Fusion.convertAfun enableAccFusion
   $ Rewrite.convertSegmentsAfun `when` convertOffsetOfSegment
-  $ Sharing.convertAfun (recoverAccSharing ok) (recoverExpSharing ok) (floatOutAccFromExp ok) acc
-  where
-    when f phase
-      | phase ok        = f
-      | otherwise       = id
+  $ Sharing.convertAfun recoverAccSharing recoverExpSharing floatOutAccFromExp
+  $ acc
 
 
 -- | Convert a closed scalar expression, incorporating sharing observation and
diff --git a/Data/Array/Accelerate/Trafo/Fusion.hs b/Data/Array/Accelerate/Trafo/Fusion.hs
--- a/Data/Array/Accelerate/Trafo/Fusion.hs
+++ b/Data/Array/Accelerate/Trafo/Fusion.hs
@@ -4,7 +4,6 @@
 {-# LANGUAGE IncoherentInstances  #-}
 {-# LANGUAGE PatternGuards        #-}
 {-# LANGUAGE RankNTypes           #-}
-{-# LANGUAGE RecordWildCards      #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
 {-# LANGUAGE TypeOperators        #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -67,13 +66,13 @@
 
 -- | Apply the fusion transformation to a closed de Bruijn AST
 --
-convertAcc :: Arrays arrs => Acc arrs -> DelayedAcc arrs
-convertAcc = withSimplStats . quenchAcc . annealAcc
+convertAcc :: Arrays arrs => Bool -> Acc arrs -> DelayedAcc arrs
+convertAcc fuseAcc = withSimplStats . convertOpenAcc fuseAcc
 
 -- | Apply the fusion transformation to a function of array arguments
 --
-convertAfun :: Afun f -> DelayedAfun f
-convertAfun = withSimplStats . quenchAfun . annealAfun
+convertAfun :: Bool -> Afun f -> DelayedAfun f
+convertAfun fuseAcc = withSimplStats . convertOpenAfun fuseAcc
 
 withSimplStats :: a -> a
 #ifdef ACCELERATE_DEBUG
@@ -83,58 +82,60 @@
 #endif
 
 
--- | An optional second phase of the fusion transformation that makes the
--- representation of fused consumer/producer terms explicit. Note that quenching
--- happens after annealing.
+-- | Apply the fusion transformation to an AST. This consists of two phases:
 --
--- TODO: integrate this with the first phase?
+--    1. A bottom-up traversal that converts nodes into the internal delayed
+--       representation, merging adjacent producer/producer pairs.
 --
-quenchAcc :: Arrays arrs => OpenAcc aenv arrs -> DelayedOpenAcc aenv arrs
-quenchAcc = cvtA
+--    2. A top-down traversal that makes the representation of fused
+--       consumer/producer pairs explicit as a 'DelayedAcc' of manifest and
+--       delayed nodes.
+--
+-- TLM: Note that there really is no ambiguity as to which state an array will
+--      be in following this process: an array will be either delayed or
+--      manifest, and the two helper functions are even named as such! We should
+--      encode this property in the type somehow...
+--
+convertOpenAcc :: Arrays arrs => Bool -> OpenAcc aenv arrs -> DelayedOpenAcc aenv arrs
+convertOpenAcc fuseAcc = manifest . computeAcc . embedOpenAcc fuseAcc
   where
     -- Convert array computations into an embeddable delayed representation.
-    -- This is essentially the reverse of 'compute'.
+    -- Reapply the embedding function from the first pass and unpack the
+    -- representation. It is safe to match on BaseEnv because the first pass
+    -- will put producers adjacent to the term consuming it.
     --
-    embed :: (Shape sh, Elt e) => OpenAcc aenv (Array sh e) -> DelayedOpenAcc aenv (Array sh e)
-    embed (OpenAcc pacc) =
-      case pacc of
-        Avar v
-          -> Delayed (arrayShape v) (indexArray v) (linearIndex v)
-
-        Generate (cvtE -> sh) (cvtF -> f)
-          -> Delayed sh f (f `compose` fromIndex sh)
-
-        Map (cvtF -> f) (embed -> Delayed{..})
-          -> Delayed extentD (f `compose` indexD) (f `compose` linearIndexD)
-
-        Backpermute (cvtE -> sh) (cvtF -> p) (embed -> Delayed{..})
-          -> let p' = indexD `compose` p
-             in  Delayed sh p'(p' `compose` fromIndex sh)
-
-        Transform (cvtE -> sh) (cvtF -> p) (cvtF -> f) (embed -> Delayed{..})
-          -> let f' = f `compose` indexD `compose` p
-             in  Delayed sh f' (f' `compose` fromIndex sh)
-
-        _ -> INTERNAL_ERROR(error) "quench" "tried to consume a non-embeddable term"
+    delayed :: (Shape sh, Elt e) => OpenAcc aenv (Array sh e) -> DelayedOpenAcc aenv (Array sh e)
+    delayed (embedOpenAcc fuseAcc -> Embed BaseEnv cc) =
+      case cc of
+        Done v                                -> Delayed (arrayShape v) (indexArray v) (linearIndex v)
+        Yield (cvtE -> sh) (cvtF -> f)        -> Delayed sh f (f `compose` fromIndex sh)
+        Step  (cvtE -> sh) (cvtF -> p) (cvtF -> f) v
+          | Just REFL <- match sh (arrayShape v)
+          , Just REFL <- isIdentity p
+          -> Delayed sh (f `compose` indexArray v) (f `compose` linearIndex v)
 
-    fusionError = INTERNAL_ERROR(error) "quench" "unexpected fusible materials"
+          | f'        <- f `compose` indexArray v `compose` p
+          -> Delayed sh f' (f' `compose` fromIndex sh)
 
     -- Convert array programs as manifest terms.
     --
-    cvtA :: OpenAcc aenv a -> DelayedOpenAcc aenv a
-    cvtA (OpenAcc pacc) = Manifest $
-      case pacc of
+    manifest :: OpenAcc aenv a -> DelayedOpenAcc aenv a
+    manifest (OpenAcc pacc) =
+      let fusionError = INTERNAL_ERROR(error) "manifest" "unexpected fusible materials"
+      in
+      Manifest $ case pacc of
         -- Non-fusible terms
         -- -----------------
         Avar ix                 -> Avar ix
         Use arr                 -> Use arr
         Unit e                  -> Unit (cvtE e)
-        Alet bnd body           -> Alet (cvtA bnd) (cvtA body)
-        Acond p t e             -> Acond (cvtE p) (cvtA t) (cvtA e)
+        Alet bnd body           -> alet (manifest bnd) (manifest body)
+        Acond p t e             -> Acond (cvtE p) (manifest t) (manifest e)
+        Awhile p f a            -> Awhile (cvtAF p) (cvtAF f) (manifest a)
         Atuple tup              -> Atuple (cvtAT tup)
-        Aprj ix tup             -> Aprj ix (cvtA tup)
-        Apply f a               -> Apply (cvtAF f) (cvtA a)
-        Aforeign ff f a         -> Aforeign ff (cvtAF f) (cvtA a)
+        Aprj ix tup             -> Aprj ix (manifest tup)
+        Apply f a               -> Apply (cvtAF f) (manifest a)
+        Aforeign ff f a         -> Aforeign ff (cvtAF f) (manifest a)
 
         -- Producers
         -- ---------
@@ -144,12 +145,12 @@
         -- result of a let-binding to be used multiple times. The input array
         -- here should be an array variable, else something went wrong.
         --
-        Map f a                 -> Map (cvtF f) (embed a)
+        Map f a                 -> Map (cvtF f) (delayed a)
         Generate sh f           -> Generate (cvtE sh) (cvtF f)
-        Transform sh p f a      -> Transform (cvtE sh) (cvtF p) (cvtF f) (embed a)
-        Backpermute sh p a      -> backpermute (cvtE sh) (cvtF p) (embed a) a
+        Transform sh p f a      -> Transform (cvtE sh) (cvtF p) (cvtF f) (delayed a)
+        Backpermute sh p a      -> Backpermute (cvtE sh) (cvtF p) (delayed a)
+        Reshape sl a            -> Reshape (cvtE sl) (manifest a)
 
-        Reshape{}               -> fusionError
         Replicate{}             -> fusionError
         Slice{}                 -> fusionError
         ZipWith{}               -> fusionError
@@ -162,42 +163,38 @@
         -- argument array multiple times, we are careful not to duplicate work
         -- and instead force the argument to be a manifest array.
         --
-        Fold f z a              -> Fold     (cvtF f) (cvtE z) (embed a)
-        Fold1 f a               -> Fold1    (cvtF f) (embed a)
-        FoldSeg f z a s         -> FoldSeg  (cvtF f) (cvtE z) (embed a) (embed s)
-        Fold1Seg f a s          -> Fold1Seg (cvtF f) (embed a) (embed s)
-        Scanl f z a             -> Scanl    (cvtF f) (cvtE z) (embed a)
-        Scanl1 f a              -> Scanl1   (cvtF f) (embed a)
-        Scanl' f z a            -> Scanl'   (cvtF f) (cvtE z) (embed a)
-        Scanr f z a             -> Scanr    (cvtF f) (cvtE z) (embed a)
-        Scanr1 f a              -> Scanr1   (cvtF f) (embed a)
-        Scanr' f z a            -> Scanr'   (cvtF f) (cvtE z) (embed a)
-        Permute f d p a         -> Permute  (cvtF f) (cvtA d) (cvtF p) (embed a)
-        Stencil f x a           -> Stencil  (cvtF f) x (cvtA a)
-        Stencil2 f x a y b      -> Stencil2 (cvtF f) x (cvtA a) y (cvtA b)
+        Fold f z a              -> Fold     (cvtF f) (cvtE z) (delayed a)
+        Fold1 f a               -> Fold1    (cvtF f) (delayed a)
+        FoldSeg f z a s         -> FoldSeg  (cvtF f) (cvtE z) (delayed a) (delayed s)
+        Fold1Seg f a s          -> Fold1Seg (cvtF f) (delayed a) (delayed s)
+        Scanl f z a             -> Scanl    (cvtF f) (cvtE z) (delayed a)
+        Scanl1 f a              -> Scanl1   (cvtF f) (delayed a)
+        Scanl' f z a            -> Scanl'   (cvtF f) (cvtE z) (delayed a)
+        Scanr f z a             -> Scanr    (cvtF f) (cvtE z) (delayed a)
+        Scanr1 f a              -> Scanr1   (cvtF f) (delayed a)
+        Scanr' f z a            -> Scanr'   (cvtF f) (cvtE z) (delayed a)
+        Permute f d p a         -> Permute  (cvtF f) (manifest d) (cvtF p) (delayed a)
+        Stencil f x a           -> Stencil  (cvtF f) x (manifest a)
+        Stencil2 f x a y b      -> Stencil2 (cvtF f) x (manifest a) y (manifest b)
 
-    -- A backwards permutation at this stage might be further simplified as a
-    -- reshape operation, which can be executed in constant time without
-    -- actually executing any array operations.
-    --
-    -- This requires that the argument of reshape be a manifest array, which is
-    -- an exception to the rule of having all array inputs in delayed form.
+    -- Flatten needless let-binds, which can be introduced by the conversion to
+    -- the internal embeddable representation.
     --
-    backpermute sh p a x
-      | OpenAcc (Avar v)        <- x
-      , Just REFL               <- match p (simplify $ reindex (arrayShape v) sh)
-      = Reshape sh (Manifest (Avar v))
+    alet bnd body
+      | Manifest (Avar ZeroIdx) <- body
+      , Manifest x              <- bnd
+      = x
 
       | otherwise
-      = Backpermute sh p a
+      = Alet bnd body
 
     cvtAT :: Atuple (OpenAcc aenv) a -> Atuple (DelayedOpenAcc aenv) a
     cvtAT NilAtup        = NilAtup
-    cvtAT (SnocAtup t a) = cvtAT t `SnocAtup` cvtA a
+    cvtAT (SnocAtup t a) = cvtAT t `SnocAtup` manifest a
 
     cvtAF :: OpenAfun aenv f -> PreOpenAfun DelayedOpenAcc aenv f
     cvtAF (Alam f)  = Alam  (cvtAF f)
-    cvtAF (Abody b) = Abody (cvtA b)
+    cvtAF (Abody b) = Abody (manifest b)
 
     -- Conversions for closed scalar functions and expressions
     --
@@ -223,12 +220,12 @@
         ToIndex sh ix           -> ToIndex (cvtE sh) (cvtE ix)
         FromIndex sh ix         -> FromIndex (cvtE sh) (cvtE ix)
         Cond p t e              -> Cond (cvtE p) (cvtE t) (cvtE e)
-        Iterate n f x           -> Iterate (cvtE n) (cvtE f) (cvtE x)
+        While p f x             -> While (cvtF p) (cvtF f) (cvtE x)
         PrimConst c             -> PrimConst c
         PrimApp f x             -> PrimApp f (cvtE x)
-        Index a sh              -> Index (cvtA a) (cvtE sh)
-        LinearIndex a i         -> LinearIndex (cvtA a) (cvtE i)
-        Shape a                 -> Shape (cvtA a)
+        Index a sh              -> Index (manifest a) (cvtE sh)
+        LinearIndex a i         -> LinearIndex (manifest a) (cvtE i)
+        Shape a                 -> Shape (manifest a)
         ShapeSize sh            -> ShapeSize (cvtE sh)
         Intersect s t           -> Intersect (cvtE s) (cvtE t)
         Foreign ff f e          -> Foreign ff (cvtF f) (cvtE e)
@@ -238,63 +235,61 @@
     cvtT (SnocTup t e) = cvtT t `SnocTup` cvtE e
 
 
-quenchAfun :: OpenAfun aenv f -> DelayedOpenAfun aenv f
-quenchAfun (Alam  f) = Alam  (quenchAfun f)
-quenchAfun (Abody b) = Abody (quenchAcc b)
+convertOpenAfun :: Bool -> OpenAfun aenv f -> DelayedOpenAfun aenv f
+convertOpenAfun c (Alam  f) = Alam  (convertOpenAfun c f)
+convertOpenAfun c (Abody b) = Abody (convertOpenAcc  c b)
 
 
 -- | Apply the fusion transformation to the AST to combine and simplify terms.
--- This combines producer/producer terms and makes consumer/producer nodes
--- adjacent.
+-- This converts terms into the internal delayed array representation and merges
+-- adjacent producer/producer terms. Using the reduced internal form limits the
+-- number of combinations that need to be considered.
 --
-annealAcc :: Arrays arrs => OpenAcc aenv arrs -> OpenAcc aenv arrs
-annealAcc = computeAcc . delayAcc
-  where
-    delayAcc :: Arrays a => OpenAcc aenv a -> Delayed OpenAcc aenv a
-    delayAcc (OpenAcc pacc) = delayPreAcc delayAcc elimAcc pacc
-
-    countAcc :: UsesOfAcc OpenAcc
-    countAcc ok idx (OpenAcc pacc) = usesOfPreAcc ok countAcc idx pacc
+type EmbedAcc acc = forall aenv arrs. Arrays arrs => acc aenv arrs -> Embed acc aenv arrs
+type ElimAcc  acc = forall aenv s t. acc aenv s -> acc (aenv,s) t -> Bool
 
+embedOpenAcc :: Arrays arrs => Bool -> OpenAcc aenv arrs -> Embed OpenAcc aenv arrs
+embedOpenAcc fuseAcc (OpenAcc pacc) =
+  embedPreAcc fuseAcc (embedOpenAcc fuseAcc) elimOpenAcc pacc
+  where
     -- When does the cost of re-computation outweigh that of memory access? For
     -- the moment only do the substitution on a single use of the bound array
     -- into the use site, but it is likely advantageous to be far more
     -- aggressive here. SEE: [Sharing vs. Fusion]
     --
-    elimAcc :: Idx aenv s -> OpenAcc aenv t -> Bool
-    elimAcc v acc = countAcc False v acc <= lIMIT
+    -- As a special case, look for the definition of 'unzip' applied to manifest
+    -- data, which is defined in the prelude as a map projecting out the
+    -- appropriate element.
+    --
+    elimOpenAcc :: ElimAcc OpenAcc
+    elimOpenAcc bnd body
+      | Map f a                 <- extract bnd
+      , Avar _                  <- extract a
+      , Lam (Body (Prj _ _))    <- f
+      = Stats.ruleFired "unzipD" True
+
+      | count False ZeroIdx body <= lIMIT
+      = True
+
+      | otherwise
+      = False
       where
         lIMIT = 1
 
-
-annealAfun :: OpenAfun aenv f -> OpenAfun aenv f
-annealAfun (Alam  f) = Alam  (annealAfun f)
-annealAfun (Abody b) = Abody (annealAcc b)
+        count :: UsesOfAcc OpenAcc
+        count ok idx (OpenAcc pacc) = usesOfPreAcc ok count idx pacc
 
 
--- | Recast terms into the internal fusion delayed array representation to be
--- forged into combined terms. Using the reduced internal form limits the number
--- of combinations that need to be considered.
---
-type DelayAcc acc = forall aenv arrs. Arrays arrs => acc aenv arrs -> Delayed acc aenv arrs
-type ElimAcc  acc = forall aenv s t. Idx aenv s -> acc aenv t -> Bool
-
-{-# SPECIALISE
-      delayPreAcc :: Arrays a
-                  => DelayAcc   OpenAcc
-                  -> ElimAcc    OpenAcc
-                  -> PreOpenAcc OpenAcc aenv a
-                  -> Delayed    OpenAcc aenv a
- #-}
-
-delayPreAcc
+embedPreAcc
     :: forall acc aenv arrs. (Kit acc, Arrays arrs)
-    => DelayAcc   acc
+    => Bool
+    -> EmbedAcc   acc
     -> ElimAcc    acc
     -> PreOpenAcc acc aenv arrs
-    -> Delayed    acc aenv arrs
-delayPreAcc delayAcc elimAcc pacc =
-  case pacc of
+    -> Embed      acc aenv arrs
+embedPreAcc fuseAcc embedAcc elimAcc pacc
+  = unembed
+  $ case pacc of
 
     -- Non-fusible terms
     -- -----------------
@@ -305,9 +300,10 @@
     -- want to fuse past array let bindings, as this would imply work
     -- duplication. SEE: [Sharing vs. Fusion]
     --
-    Alet bnd body       -> aletD delayAcc elimAcc bnd body
-    Acond p at ae       -> acondD delayAcc (cvtE p) at ae
-    Aprj ix tup         -> aprjD delayAcc ix tup
+    Alet bnd body       -> aletD embedAcc elimAcc bnd body
+    Acond p at ae       -> acondD embedAcc (cvtE p) at ae
+    Aprj ix tup         -> aprjD embedAcc ix tup
+    Awhile p f a        -> done $ Awhile (cvtAF p) (cvtAF f) (cvtA a)
     Atuple tup          -> done $ Atuple (cvtAT tup)
     Apply f a           -> done $ Apply (cvtAF f) (cvtA a)
     Aforeign ff f a     -> done $ Aforeign ff (cvtAF f) (cvtA a)
@@ -339,7 +335,7 @@
     Backpermute sl p a  -> fuse  (into2 backpermuteD      (cvtE sl) (cvtF p)) a
     Slice slix a sl     -> fuse  (into  (sliceD slix)     (cvtE sl)) a
     Replicate slix sh a -> fuse  (into  (replicateD slix) (cvtE sh)) a
-    Reshape sl a        -> fuse  (into  reshapeD          (cvtE sl)) a
+    Reshape sl a        -> reshapeD (embedAcc a) (cvtE sl)
 
     -- Consumers
     -- ---------
@@ -372,8 +368,15 @@
     Stencil2 f x a y b  -> embed2 (into (stencil2 x y) (cvtF f)) a b
 
   where
+    -- If fusion is not enabled, force terms to the manifest representation
+    --
+    unembed :: Embed acc aenv arrs -> Embed acc aenv arrs
+    unembed x
+      | fuseAcc         = x
+      | otherwise       = done (compute x)
+
     cvtA :: Arrays a => acc aenv' a -> acc aenv' a
-    cvtA = computeAcc . delayAcc
+    cvtA = computeAcc . embedAcc
 
     cvtAT :: Atuple (acc aenv') a -> Atuple (acc aenv') a
     cvtAT NilAtup          = NilAtup
@@ -396,7 +399,7 @@
     cvtF :: PreFun acc aenv t -> PreFun acc aenv t
     cvtF = cvtF' . simplify
 
-    cvtE :: PreExp acc aenv t -> PreExp acc aenv t
+    cvtE :: PreExp acc aenv' t -> PreExp acc aenv' t
     cvtE = cvtE' . simplify
 
     -- Conversions for scalar functions and expressions without
@@ -424,7 +427,7 @@
         ToIndex sh ix           -> ToIndex (cvtE' sh) (cvtE' ix)
         FromIndex sh ix         -> FromIndex (cvtE' sh) (cvtE' ix)
         Cond p t e              -> Cond (cvtE' p) (cvtE' t) (cvtE' e)
-        Iterate n f x           -> Iterate (cvtE' n) (cvtE' f) (cvtE' x)
+        While p f x             -> While (cvtF' p) (cvtF' f) (cvtE' x)
         PrimConst c             -> PrimConst c
         PrimApp f x             -> PrimApp f (cvtE' x)
         Index a sh              -> Index a (cvtE' sh)
@@ -453,45 +456,38 @@
 
     fuse :: Arrays as
          => (forall aenv'. Extend acc aenv aenv' -> Cunctation acc aenv' as -> Cunctation acc aenv' bs)
-         ->         acc aenv as
-         -> Delayed acc aenv bs
-    fuse op (delayAcc -> Term env cc) = Term env (op env cc)
+         ->       acc aenv as
+         -> Embed acc aenv bs
+    fuse op (embedAcc -> Embed env cc) = Embed env (op env cc)
 
     fuse2 :: (Arrays as, Arrays bs)
           => (forall aenv'. Extend acc aenv aenv' -> Cunctation acc aenv' as -> Cunctation acc aenv' bs -> Cunctation acc aenv' cs)
-          ->         acc aenv as
-          ->         acc aenv bs
-          -> Delayed acc aenv cs
+          ->       acc aenv as
+          ->       acc aenv bs
+          -> Embed acc aenv cs
     fuse2 op a1 a0
-      | Term env1 cc1   <- delayAcc a1
-      , Term env0 cc0   <- delayAcc (sink env1 a0)
+      | Embed env1 cc1  <- embedAcc a1
+      , Embed env0 cc0  <- embedAcc (sink env1 a0)
       , env             <- env1 `join` env0
-      = Term env (op env (sink env0 cc1) cc0)
+      = Embed env (op env (sink env0 cc1) cc0)
 
     embed :: (Arrays as, Arrays bs)
           => (forall aenv'. Extend acc aenv aenv' -> acc aenv' as -> PreOpenAcc acc aenv' bs)
-          ->         acc aenv as
-          -> Delayed acc aenv bs
-    embed op (delayAcc -> Term env cc) = case cc of
-      Done v        -> Term (env `PushEnv` op env (avarIn v)) (Done ZeroIdx)
-      Step sh p f v -> Term (env `PushEnv` op env (computeAcc (Term BaseEnv (Step sh p f v)))) (Done ZeroIdx)
-      Yield sh f    -> Term (env `PushEnv` op env (computeAcc (Term BaseEnv (Yield sh f)))) (Done ZeroIdx)
+          ->       acc aenv as
+          -> Embed acc aenv bs
+    embed op (embedAcc -> Embed env cc)
+      = Embed (env `PushEnv` op env (inject (compute' cc))) (Done ZeroIdx)
 
     embed2 :: forall aenv as bs cs. (Arrays as, Arrays bs, Arrays cs)
            => (forall aenv'. Extend acc aenv aenv' -> acc aenv' as -> acc aenv' bs -> PreOpenAcc acc aenv' cs)
-           ->         acc aenv as
-           ->         acc aenv bs
-           -> Delayed acc aenv cs
-    embed2 op (delayAcc -> Term env1 cc1) a0 = case cc1 of
-      Done v        -> inner env1 v a0
-      Step sh p f v -> inner (env1 `PushEnv` compute (Term BaseEnv (Step sh p f v))) ZeroIdx a0
-      Yield sh f    -> inner (env1 `PushEnv` compute (Term BaseEnv (Yield sh f))) ZeroIdx a0
-      where
-        inner :: Extend acc aenv aenv' -> Idx aenv' as -> acc aenv bs -> Delayed acc aenv cs
-        inner env1 v1 (delayAcc . sink env1 -> Term env0 cc0) = case cc0 of
-          Done v0       -> let env = env1 `join` env0 in Term (env `PushEnv` op env (avarIn (sink env0 v1)) (avarIn v0)) (Done ZeroIdx)
-          Step sh p f v -> let env = env1 `join` env0 in Term (env `PushEnv` op env (avarIn (sink env0 v1)) (computeAcc (Term BaseEnv (Step sh p f v)))) (Done ZeroIdx)
-          Yield sh f    -> let env = env1 `join` env0 in Term (env `PushEnv` op env (avarIn (sink env0 v1)) (computeAcc (Term BaseEnv (Yield sh f)))) (Done ZeroIdx)
+           ->       acc aenv as
+           ->       acc aenv bs
+           -> Embed acc aenv cs
+    embed2 op (embedAcc -> Embed env1 cc1) (embedAcc . sink env1 -> Embed env0 cc0)
+      | env     <- env1 `join` env0
+      , acc1    <- inject . compute' $ sink env0 cc1
+      , acc0    <- inject . compute' $ cc0
+      = Embed (env `PushEnv` op env acc1 acc0) (Done ZeroIdx)
 
 
 -- Internal representation
@@ -524,10 +520,10 @@
 -- of the fusion algorithm for an AST of N terms becomes O(r^n), where r is the
 -- number of different rules we have for combining terms.
 --
-data Delayed acc aenv a where
-  Term  :: Extend     acc aenv aenv'
+data Embed acc aenv a where
+  Embed :: Extend     acc aenv aenv'
         -> Cunctation acc      aenv' a
-        -> Delayed    acc aenv       a
+        -> Embed      acc aenv       a
 
 
 -- Cunctation (n): the action or an instance of delaying; a tardy action.
@@ -542,7 +538,9 @@
 
   -- The base case is just a real (manifest) array term. No fusion happens here.
   -- Note that the array is referenced by an index into the extended
-  -- environment, making the term non-recursive.
+  -- environment, ensuring that the array is manifest and making the term
+  -- non-recursive in 'acc'. Also note that the return type is a general
+  -- instance of Arrays and not restricted to a single Array.
   --
   Done  :: Arrays a
         => Idx            aenv a
@@ -570,12 +568,18 @@
         -> Cunctation acc aenv (Array sh' b)
 
 
+instance Kit acc => Simplify (Cunctation acc aenv a) where
+  simplify (Done v)        = Done v
+  simplify (Yield sh f)    = Yield (simplify sh) (simplify f)
+  simplify (Step sh p f v) = Step (simplify sh) (simplify p) (simplify f) v
+
+
 -- Convert a real AST node into the internal representation
 --
-done :: Arrays a => PreOpenAcc acc aenv a -> Delayed acc aenv a
+done :: Arrays a => PreOpenAcc acc aenv a -> Embed acc aenv a
 done pacc
-  | Avar v <- pacc      = Term BaseEnv                  (Done v)
-  | otherwise           = Term (BaseEnv `PushEnv` pacc) (Done ZeroIdx)
+  | Avar v <- pacc      = Embed BaseEnv                  (Done v)
+  | otherwise           = Embed (BaseEnv `PushEnv` pacc) (Done ZeroIdx)
 
 
 -- Recast a cunctation into a mapping from indices to elements.
@@ -615,8 +619,7 @@
   | Yield sh _           <- yield cc    = sh
 
 
--- Reified type of a delayed array representation. This way we don't require
--- additional class constraints on 'step' and 'yield'.
+-- Reified type of a delayed array representation.
 --
 accType' :: forall acc aenv a. Arrays a => Cunctation acc aenv a -> ArraysR (ArrRepr' a)
 accType' _ = arrays' (undefined :: a)
@@ -668,55 +671,48 @@
 -- bindings have come into scope according to the witness and no old things have
 -- vanished.
 --
+sink :: Sink f => Extend acc env env' -> f env t -> f env' t
+sink env = weaken (k env)
+  where
+    k :: Extend acc env env' -> Idx env t -> Idx env' t
+    k BaseEnv       = Stats.substitution "sink" id
+    k (PushEnv e _) = SuccIdx . k e
+
+sink1 :: Sink f => Extend acc env env' -> f (env,s) t -> f (env',s) t
+sink1 env = weaken (k env)
+  where
+    k :: Extend acc env env' -> Idx (env,s) t -> Idx (env',s) t
+    k BaseEnv       = Stats.substitution "sink1" id
+    k (PushEnv e _) = split . k e
+    --
+    split :: Idx (env,s) t -> Idx ((env,u),s) t
+    split ZeroIdx      = ZeroIdx
+    split (SuccIdx ix) = SuccIdx (SuccIdx ix)
+
+
 class Sink f where
-  sink :: Extend acc env env' -> f env t -> f env' t
+  weaken :: env :> env' -> f env t -> f env' t
 
 instance Sink Idx where
-  sink BaseEnv       = Stats.substitution "sink" id
-  sink (PushEnv e _) = SuccIdx . sink e
+  weaken k = k
 
 instance Kit acc => Sink (PreOpenExp acc env) where
-  sink env = weakenEA rebuildAcc (sink env)
+  weaken k = weakenEA rebuildAcc k
 
 instance Kit acc => Sink (PreOpenFun acc env) where
-  sink env = weakenFA rebuildAcc (sink env)
+  weaken k = weakenFA rebuildAcc k
 
 instance Kit acc => Sink (PreOpenAcc acc) where
-  sink env = weakenA rebuildAcc (sink env)
+  weaken k = weakenA rebuildAcc k
 
-instance Kit acc => Sink acc where      -- overlapping, undecidable, incoherent
-  sink env = rebuildAcc (Avar . sink env)
+instance Kit acc => Sink acc where
+  weaken k = rebuildAcc (Avar . k)
 
 instance Kit acc => Sink (Cunctation acc) where
-  sink env cc = case cc of
-    Done v              -> Done (sink env v)
-    Step sh p f v       -> Step (sink env sh) (sink env p) (sink env f) (sink env v)
-    Yield sh f          -> Yield (sink env sh) (sink env f)
-
-
-class Sink1 f where
-  sink1 :: Extend acc env env' -> f (env,s) t -> f (env',s) t
-
-instance Sink1 Idx where
-  sink1 BaseEnv         = Stats.substitution "sink1" id
-  sink1 (PushEnv e _)   = split . sink1 e
-    where
-      split :: Idx (env,s) t -> Idx ((env,u),s) t
-      split ZeroIdx      = ZeroIdx
-      split (SuccIdx ix) = SuccIdx (SuccIdx ix)
-
-instance Kit acc => Sink1 (PreOpenExp acc env) where
-  sink1 env = weakenEA rebuildAcc (sink1 env)
-
-instance Kit acc => Sink1 (PreOpenFun acc env) where
-  sink1 env = weakenFA rebuildAcc (sink1 env)
-
-instance Kit acc => Sink1 (PreOpenAcc acc) where
-  sink1 env = weakenA rebuildAcc (sink1 env)
-
-instance Kit acc => Sink1 acc where     -- overlapping, undecidable, incoherent
-  sink1 env = rebuildAcc (Avar . sink1 env)
-
+  weaken k cc = case cc of
+    Done v              -> Done (weaken k v)
+    Step sh p f v       -> Step (weaken k sh) (weaken k p) (weaken k f) (weaken k v)
+    Yield sh f          -> Yield (weaken k sh) (weaken k f)
 
 
 -- Array fusion of a de Bruijn computation AST
@@ -728,40 +724,38 @@
 -- Recast the internal representation of delayed arrays into a real AST node.
 -- Use the most specific version of a combinator whenever possible.
 --
-compute :: (Kit acc, Arrays arrs) => Delayed acc aenv arrs -> PreOpenAcc acc aenv arrs
-compute (Term env cc)
-  = bind env
-  $ case cc of
-      Done v                                    -> Avar v
-      Yield (simplify -> sh) (simplify -> f)    -> Generate sh f
-      Step  (simplify -> sh) (simplify -> p) (simplify -> f) v
-        | Just REFL <- identShape
-        , Just REFL <- isIdentity p
-        , Just REFL <- isIdentity f             -> Avar v
-        | Just REFL <- identShape
-        , Just REFL <- isIdentity p             -> Map f acc
-        | Just REFL <- isIdentity f             -> Backpermute sh p acc
-        | otherwise                             -> Transform sh p f acc
-        where
-          identShape    = match sh (arrayShape v)
-          acc           = avarIn v
+compute :: (Kit acc, Arrays arrs) => Embed acc aenv arrs -> PreOpenAcc acc aenv arrs
+compute (Embed env cc) = bind env (compute' cc)
 
+compute' :: (Kit acc, Arrays arrs) => Cunctation acc aenv arrs -> PreOpenAcc acc aenv arrs
+compute' cc = case simplify cc of
+  Done v                                        -> Avar v
+  Yield sh f                                    -> Generate sh f
+  Step sh p f v
+    | Just REFL <- match sh (arrayShape v)
+    , Just REFL <- isIdentity p
+    , Just REFL <- isIdentity f                 -> Avar v
+    | Just REFL <- match sh (arrayShape v)
+    , Just REFL <- isIdentity p                 -> Map f (avarIn v)
+    | Just REFL <- isIdentity f                 -> Backpermute sh p (avarIn v)
+    | otherwise                                 -> Transform sh p f (avarIn v)
 
+
 -- Evaluate a delayed computation and tie the recursive knot
 --
-computeAcc :: (Kit acc, Arrays arrs) => Delayed acc aenv arrs -> acc aenv arrs
+computeAcc :: (Kit acc, Arrays arrs) => Embed acc aenv arrs -> acc aenv arrs
 computeAcc = inject . compute
 
 
 -- Representation of a generator as a delayed array
 --
 generateD :: (Shape sh, Elt e)
-          => PreExp  acc aenv sh
-          -> PreFun  acc aenv (sh -> e)
-          -> Delayed acc aenv (Array sh e)
+          => PreExp acc aenv sh
+          -> PreFun acc aenv (sh -> e)
+          -> Embed  acc aenv (Array sh e)
 generateD sh f
   = Stats.ruleFired "generateD"
-  $ Term BaseEnv (Yield sh f)
+  $ Embed BaseEnv (Yield sh f)
 
 
 -- Fuse a unary function into a delayed array.
@@ -838,24 +832,26 @@
 
 -- Reshape an array
 --
--- For delayed arrays this is implemented as an index space transformation.
--- However for manifest arrays this can be done in constant time. However, if
--- the reshaped array is later consumed, for example in foldAll, this won't be
--- fused into the consumer. At this point always convert into a delayed
--- representation, and attempt to recover the reshape operation in the final
--- quenching phase.
+-- For delayed arrays this is implemented as an index space transformation. For
+-- manifest arrays this can be done with the standard Reshape operation in
+-- constant time without executing any array operations. This does not affect
+-- the fusion process since the term is already manifest.
 --
 -- TLM: there was a runtime check to ensure the old and new shapes contained the
 --      same number of elements: this has been lost for the delayed cases!
 --
 reshapeD
-    :: (Kit acc, Shape sh, Shape sl)
-    => PreExp     acc aenv sl
-    -> Cunctation acc aenv (Array sh e)
-    -> Cunctation acc aenv (Array sl e)
-reshapeD sl cc
+    :: (Kit acc, Shape sh, Shape sl, Elt e)
+    => Embed  acc aenv (Array sh e)
+    -> PreExp acc aenv sl
+    -> Embed  acc aenv (Array sl e)
+reshapeD (Embed env cc) (sink env -> sl)
+  | Done v      <- cc
+  = Embed (env `PushEnv` Reshape sl (avarIn v)) (Done ZeroIdx)
+
+  | otherwise
   = Stats.ruleFired "reshapeD"
-  $ backpermuteD sl (reindex (shape cc) sl) cc
+  $ Embed env (backpermuteD sl (reindex (shape cc) sl) cc)
 
 
 -- Combine two arrays element-wise with a binary function to produce a delayed
@@ -956,13 +952,35 @@
 -- the cost of completely evaluating the array and subsequently retrieving the
 -- data from memory.
 --
-aletD :: forall acc aenv arrs brrs. (Kit acc, Arrays arrs, Arrays brrs)
-      => DelayAcc acc
+-- let-binding:
+-- ------------
+--
+-- Ultimately, we might not want to eliminate the binding. If so, evaluate it
+-- and add it to a _clean_ Extend environment for the body. If not, the Extend
+-- list effectively _flattens_ all bindings, so any terms required for the bound
+-- term get lifted out to the same scope as the body. This increases their
+-- lifetime and hence raises the maximum memory used. If we don't do this, we
+-- get terms such as:
+--
+--   let a0  = <terms for binding> in
+--   let bnd = <bound term> in
+--   <body term>
+--
+-- rather than the following, where the scope of a0 is clearly only availably
+-- when evaluating the bound term, as it should be:
+--
+--   let bnd =
+--     let a0 = <terms for binding>
+--     in <bound term>
+--   in <body term>
+--
+aletD :: (Kit acc, Arrays arrs, Arrays brrs)
+      => EmbedAcc acc
       -> ElimAcc  acc
       ->          acc aenv        arrs
       ->          acc (aenv,arrs) brrs
-      -> Delayed  acc aenv        brrs
-aletD delayAcc elimAcc (delayAcc -> Term env1 cc1) acc0
+      -> Embed    acc aenv        brrs
+aletD embedAcc elimAcc (embedAcc -> Embed env1 cc1) acc0
 
   -- let-floating
   -- ------------
@@ -972,60 +990,75 @@
   -- that must be later eliminated by shrinking.
   --
   | Done v1             <- cc1
-  , Term env0 cc0       <- delayAcc $ rebuildAcc (subTop (Avar v1) . sink1 env1) acc0
+  , Embed env0 cc0      <- embedAcc $ rebuildAcc (subAtop (Avar v1) . sink1 env1) acc0
   = Stats.ruleFired "aletD/float"
-  $ Term (env1 `join` env0) cc0
+  $ Embed (env1 `join` env0) cc0
 
+  -- Ensure we only call 'embedAcc' once on the body expression
+  --
+  | otherwise
+  = aletD' embedAcc elimAcc (Embed env1 cc1) (embedAcc acc0)
+
+
+aletD' :: forall acc aenv arrs brrs. (Kit acc, Arrays arrs, Arrays brrs)
+       => EmbedAcc acc
+       -> ElimAcc  acc
+       -> Embed    acc aenv         arrs
+       -> Embed    acc (aenv, arrs) brrs
+       -> Embed    acc aenv         brrs
+aletD' embedAcc elimAcc (Embed env1 cc1) (Embed env0 cc0)
+
+  -- let-binding
+  -- -----------
+  --
+  -- Check whether we can eliminate the let-binding. Note that we must inspect
+  -- the entire term, not just the Cunctation that would be produced by
+  -- embedAcc. If we don't we can be left with dead terms that don't get
+  -- eliminated. This problem occurred in the canny program.
+  --
+  | acc1                <- compute (Embed env1 cc1)
+  , False               <- elimAcc (inject acc1) acc0
+  = Stats.ruleFired "aletD/bind"
+  $ Embed (BaseEnv `PushEnv` acc1 `join` env0) cc0
+
+  -- let-elimination
+  -- ---------------
+  --
   -- Handle the remaining cases in a separate function. It turns out that this
   -- is important so we aren't excessively sinking/delaying terms.
   --
-  | otherwise
-  , Term env0 cc0       <- delayAcc $ sink1 env1 acc0
-  = case cc1 of
-      Step{}    -> aletD' env1 cc1 env0 cc0
-      Yield{}   -> aletD' env1 cc1 env0 cc0
+  | acc0'               <- sink1 env1 acc0
+  = Stats.ruleFired "aletD/eliminate"
+  $ case cc1 of
+      Step{}    -> eliminate env1 cc1 acc0'
+      Yield{}   -> eliminate env1 cc1 acc0'
 
   where
-    subTop :: forall aenv s t. Arrays t => PreOpenAcc acc aenv s -> Idx (aenv,s) t -> PreOpenAcc acc aenv t
-    subTop t ZeroIdx       = t
-    subTop _ (SuccIdx idx) = Avar idx
+    acc0 = computeAcc (Embed env0 cc0)
 
     -- The second part of let-elimination. Splitting into two steps exposes the
-    -- extra type variables, and ensures we don't do extra work for the
-    -- let-floating case (which can lead to a complexity blowup.)
+    -- extra type variables, and ensures we don't do extra work manipulating the
+    -- body when not necessary (which can lead to a complexity blowup).
     --
-    aletD' :: forall aenv aenv' aenv'' sh e brrs. (Kit acc, Shape sh, Elt e, Arrays brrs)
-           => Extend     acc aenv                aenv'
-           -> Cunctation acc                     aenv'  (Array sh e)
-           -> Extend     acc (aenv', Array sh e) aenv''
-           -> Cunctation acc                     aenv'' brrs
-           -> Delayed    acc aenv                       brrs
-    aletD' env1 cc1 env0 cc0
-      | not shouldInline         = Term (env1 `PushEnv` bnd `join` env0) cc0
-
-      | Stats.ruleFired "aletD/eliminate" False
-      = undefined
-
-      | Done v1           <- cc1 = eliminate (arrayShape v1) (indexArray v1)
-      | Step sh1 p1 f1 v1 <- cc1 = eliminate sh1 (f1 `compose` indexArray v1 `compose` p1)
-      | Yield sh1 f1      <- cc1 = eliminate sh1 f1
+    eliminate :: forall aenv aenv' sh e brrs. (Kit acc, Shape sh, Elt e, Arrays brrs)
+              => Extend     acc aenv aenv'
+              -> Cunctation acc      aenv' (Array sh e)
+              ->            acc     (aenv', Array sh e) brrs
+              -> Embed      acc aenv                    brrs
+    eliminate env1 cc1 body
+      | Done v1           <- cc1 = elim (arrayShape v1) (indexArray v1)
+      | Step sh1 p1 f1 v1 <- cc1 = elim sh1 (f1 `compose` indexArray v1 `compose` p1)
+      | Yield sh1 f1      <- cc1 = elim sh1 f1
       where
-        -- The main terms, remade manifest. We need to do this so that eliminating
-        -- terms considers not just the main term but any of the environment terms
-        -- (in Extend). This problem occurred in the Canny example program.
-        --
-        shouldInline = elimAcc ZeroIdx body
-        body         = computeAcc (Term env0    cc0)
-        bnd          = compute    (Term BaseEnv cc1)
+        bnd :: PreOpenAcc acc aenv' (Array sh e)
+        bnd = compute' cc1
 
-        eliminate :: PreExp  acc      aenv' sh
-                  -> PreFun  acc      aenv' (sh -> e)
-                  -> Delayed acc aenv       brrs
-        eliminate sh1 f1
-          | sh1'            <- weakenEA rebuildAcc SuccIdx sh1
-          , f1'             <- weakenFA rebuildAcc SuccIdx f1
-          , Term env0' cc0' <- delayAcc $ rebuildAcc (subTop bnd) $ kmap (replaceA sh1' f1' ZeroIdx) body
-          = Term (env1 `join` env0') cc0'
+        elim :: PreExp acc aenv' sh -> PreFun acc aenv' (sh -> e) -> Embed acc aenv brrs
+        elim sh1 f1
+          | sh1'                <- weakenEA rebuildAcc SuccIdx sh1
+          , f1'                 <- weakenFA rebuildAcc SuccIdx f1
+          , Embed env0' cc0'    <- embedAcc $ rebuildAcc (subAtop bnd) $ kmap (replaceA sh1' f1' ZeroIdx) body
+          = Embed (env1 `join` env0') cc0'
 
     -- As part of let-elimination, we need to replace uses of array variables in
     -- scalar expressions with an equivalent expression that generates the
@@ -1058,23 +1091,24 @@
         ToIndex sh ix                   -> ToIndex (cvtE sh) (cvtE ix)
         FromIndex sh i                  -> FromIndex (cvtE sh) (cvtE i)
         Cond p t e                      -> Cond (cvtE p) (cvtE t) (cvtE e)
-        Iterate n f x                   -> Iterate (cvtE n) (replaceE (weakenE SuccIdx sh') (weakenFE SuccIdx f') avar f) (cvtE x)
         PrimConst c                     -> PrimConst c
         PrimApp g x                     -> PrimApp g (cvtE x)
         ShapeSize sh                    -> ShapeSize (cvtE sh)
         Intersect sh sl                 -> Intersect (cvtE sh) (cvtE sl)
+        While p f x                     -> While (replaceF sh' f' avar p) (replaceF sh' f' avar f) (cvtE x)
+
         Shape a
           | Just REFL <- match a a'     -> Stats.substitution "replaceE/shape" sh'
           | otherwise                   -> exp
 
         Index a sh
           | Just REFL    <- match a a'
-          , Lam (Body b) <- f'          -> Stats.substitution "replaceE/!" $ Let sh b
+          , Lam (Body b) <- f'          -> Stats.substitution "replaceE/!" . cvtE $ Let sh b
           | otherwise                   -> Index a (cvtE sh)
 
         LinearIndex a i
           | Just REFL    <- match a a'
-          , Lam (Body b) <- f'          -> Stats.substitution "replaceE/!!" $ Let (Let i (FromIndex (weakenE SuccIdx sh') (Var ZeroIdx))) b
+          , Lam (Body b) <- f'          -> Stats.substitution "replaceE/!!" . cvtE $ Let (Let i (FromIndex (weakenE SuccIdx sh') (Var ZeroIdx))) b
           | otherwise                   -> LinearIndex a (cvtE i)
 
       where
@@ -1117,8 +1151,9 @@
         Acond p at ae           -> Acond (cvtE p) (cvtA at) (cvtA ae)
         Aprj ix tup             -> Aprj ix (cvtA tup)
         Atuple tup              -> Atuple (cvtAT tup)
-        Apply f a               -> Apply f (cvtA a)            -- no sharing between f and a
-        Aforeign ff f a         -> Aforeign ff f (cvtA a)      -- no sharing between f and a
+        Awhile p f a            -> Awhile p f (cvtA a)          -- no sharing between p or f and a
+        Apply f a               -> Apply f (cvtA a)             -- no sharing between f and a
+        Aforeign ff f a         -> Aforeign ff f (cvtA a)       -- no sharing between f and a
         Generate sh f           -> Generate (cvtE sh) (cvtF f)
         Map f a                 -> Map (cvtF f) (cvtA a)
         ZipWith f a b           -> ZipWith (cvtF f) (cvtA a) (cvtA b)
@@ -1167,33 +1202,33 @@
 -- for the branch not taken.
 --
 acondD :: (Kit acc, Arrays arrs)
-       => DelayAcc acc
+       => EmbedAcc acc
        -> PreExp   acc aenv Bool
        ->          acc aenv arrs
        ->          acc aenv arrs
-       -> Delayed  acc aenv arrs
-acondD delayAcc p t e
-  | Const ((),True)  <- p   = Stats.knownBranch "True"      $ delayAcc t
-  | Const ((),False) <- p   = Stats.knownBranch "False"     $ delayAcc e
-  | Just REFL <- match t e  = Stats.knownBranch "redundant" $ delayAcc e
-  | otherwise               = done $ Acond p (computeAcc (delayAcc t))
-                                             (computeAcc (delayAcc e))
+       -> Embed    acc aenv arrs
+acondD embedAcc p t e
+  | Const ((),True)  <- p   = Stats.knownBranch "True"      $ embedAcc t
+  | Const ((),False) <- p   = Stats.knownBranch "False"     $ embedAcc e
+  | Just REFL <- match t e  = Stats.knownBranch "redundant" $ embedAcc e
+  | otherwise               = done $ Acond p (computeAcc (embedAcc t))
+                                             (computeAcc (embedAcc e))
 
 
 -- Array tuple projection. Whenever possible we want to peek underneath the
 -- tuple structure and continue the fusion process.
 --
 aprjD :: forall acc aenv arrs a. (Kit acc, IsTuple arrs, Arrays arrs, Arrays a)
-      => DelayAcc acc
+      => EmbedAcc acc
       -> TupleIdx (TupleRepr arrs) a
-      ->         acc aenv arrs
-      -> Delayed acc aenv a
-aprjD delayAcc ix a
-  | Atuple tup <- extract a = Stats.ruleFired "aprj/Atuple" . delayAcc $ aprjAT ix tup
+      ->       acc aenv arrs
+      -> Embed acc aenv a
+aprjD embedAcc ix a
+  | Atuple tup <- extract a = Stats.ruleFired "aprj/Atuple" . embedAcc $ aprjAT ix tup
   | otherwise               = done $ Aprj ix (cvtA a)
   where
     cvtA :: acc aenv arrs -> acc aenv arrs
-    cvtA = computeAcc . delayAcc
+    cvtA = computeAcc . embedAcc
 
     aprjAT :: TupleIdx atup a -> Atuple (acc aenv) atup -> acc aenv a
     aprjAT ZeroTupIdx      (SnocAtup _ a) = a
diff --git a/Data/Array/Accelerate/Trafo/Rewrite.hs b/Data/Array/Accelerate/Trafo/Rewrite.hs
--- a/Data/Array/Accelerate/Trafo/Rewrite.hs
+++ b/Data/Array/Accelerate/Trafo/Rewrite.hs
@@ -66,6 +66,7 @@
       Apply f a                 -> Apply (cvtAfun f) (cvtA a)
       Aforeign ff afun acc      -> Aforeign ff (cvtAfun afun) (cvtA acc)
       Acond p t e               -> Acond (cvtE p) (cvtA t) (cvtA e)
+      Awhile p f a              -> Awhile (cvtAfun p) (cvtAfun f) (cvtA a)
       Use a                     -> Use a
       Unit e                    -> Unit (cvtE e)
       Reshape e a               -> Reshape (cvtE e) (cvtA a)
diff --git a/Data/Array/Accelerate/Trafo/Sharing.hs b/Data/Array/Accelerate/Trafo/Sharing.hs
--- a/Data/Array/Accelerate/Trafo/Sharing.hs
+++ b/Data/Array/Accelerate/Trafo/Sharing.hs
@@ -38,6 +38,8 @@
 import Data.Typeable
 import qualified Data.HashTable.IO                      as Hash
 import qualified Data.IntMap                            as IntMap
+import qualified Data.HashMap.Strict                    as Map
+import qualified Data.HashSet                           as Set
 import System.IO.Unsafe                                 ( unsafePerformIO )
 import System.Mem.StableName
 
@@ -202,40 +204,50 @@
     => Config
     -> Layout aenv aenv
     -> [StableSharingAcc]
-    -> SharingAcc arrs
+    -> ScopedAcc arrs
     -> AST.OpenAcc aenv arrs
-convertSharingAcc _ alyt aenv (AvarSharing sa)
-  | Just i <- findIndex (matchStableAcc sa) aenv
+convertSharingAcc _ alyt aenv (ScopedAcc lams (AvarSharing sa))
+  | Just i <- findIndex (matchStableAcc sa) aenv'
   = AST.OpenAcc $ AST.Avar (prjIdx (ctxt ++ "; i = " ++ show i) i alyt)
-  | null aenv
+  | null aenv'
   = error $ "Cyclic definition of a value of type 'Acc' (sa = " ++
             show (hashStableNameHeight sa) ++ ")"
   | otherwise
   = INTERNAL_ERROR(error) "convertSharingAcc" err
   where
+    aenv' = lams ++ aenv
     ctxt = "shared 'Acc' tree with stable name " ++ show (hashStableNameHeight sa)
-    err  = "inconsistent valuation @ " ++ ctxt ++ ";\n  aenv = " ++ show aenv
+    err  = "inconsistent valuation @ " ++ ctxt ++ ";\n  aenv = " ++ show aenv'
 
-convertSharingAcc config alyt aenv (AletSharing sa@(StableSharingAcc _ boundAcc) bodyAcc)
+convertSharingAcc config alyt aenv (ScopedAcc lams (AletSharing sa@(StableSharingAcc _ boundAcc) bodyAcc))
   = AST.OpenAcc
   $ let alyt' = incLayout alyt `PushLayout` ZeroIdx
+        aenv' = lams ++ aenv
     in
-    AST.Alet (convertSharingAcc config alyt aenv boundAcc)
-             (convertSharingAcc config alyt' (sa:aenv) bodyAcc)
+    AST.Alet (convertSharingAcc config alyt aenv' (ScopedAcc [] boundAcc))
+             (convertSharingAcc config alyt' (sa:aenv') bodyAcc)
 
-convertSharingAcc config alyt aenv (AccSharing _ preAcc)
+convertSharingAcc config alyt aenv (ScopedAcc lams (AccSharing _ preAcc))
   = AST.OpenAcc
-  $ let cvtA :: Arrays a => SharingAcc a -> AST.OpenAcc aenv a
-        cvtA = convertSharingAcc config alyt aenv
+  $ let aenv' = lams ++ aenv
 
-        cvtE :: Elt t => RootExp t -> AST.Exp aenv t
-        cvtE = convertRootExp config alyt aenv
+        cvtA :: Arrays a => ScopedAcc a -> AST.OpenAcc aenv a
+        cvtA = convertSharingAcc config alyt aenv'
 
-        cvtF1 :: (Elt a, Elt b) => (Exp a -> RootExp b) -> AST.Fun aenv (a -> b)
-        cvtF1 = convertSharingFun1 config alyt aenv
+        cvtE :: Elt t => ScopedExp t -> AST.Exp aenv t
+        cvtE = convertSharingExp config EmptyLayout alyt [] aenv'
 
-        cvtF2 :: (Elt a, Elt b, Elt c) => (Exp a -> Exp b -> RootExp c) -> AST.Fun aenv (a -> b -> c)
-        cvtF2 = convertSharingFun2 config alyt aenv
+        cvtF1 :: (Elt a, Elt b) => (Exp a -> ScopedExp b) -> AST.Fun aenv (a -> b)
+        cvtF1 = convertSharingFun1 config alyt aenv'
+
+        cvtF2 :: (Elt a, Elt b, Elt c) => (Exp a -> Exp b -> ScopedExp c) -> AST.Fun aenv (a -> b -> c)
+        cvtF2 = convertSharingFun2 config alyt aenv'
+
+        cvtAfun1 :: (Arrays a, Arrays b) => (Acc a -> ScopedAcc b) -> AST.OpenAfun aenv (a -> b)
+        cvtAfun1 f = Alam (Abody (convertSharingAcc config alyt' aenv' body))
+          where
+            alyt' = incLayout alyt `PushLayout` ZeroIdx
+            body  = f undefined
     in
     case preAcc of
 
@@ -244,7 +256,7 @@
 
       Pipe afun1 afun2 acc
         -> let alyt'    = incLayout alyt `PushLayout` ZeroIdx
-               boundAcc = aconvert config alyt  afun1 `AST.Apply` convertSharingAcc config alyt aenv acc
+               boundAcc = aconvert config alyt  afun1 `AST.Apply` convertSharingAcc config alyt aenv' acc
                bodyAcc  = aconvert config alyt' afun2 `AST.Apply` AST.OpenAcc (AST.Avar AST.ZeroIdx)
            in
            AST.Alet (AST.OpenAcc boundAcc) (AST.OpenAcc bodyAcc)
@@ -257,7 +269,8 @@
            AST.Aforeign ff (convertAfun a e f afun) (cvtA acc)
 
       Acond b acc1 acc2           -> AST.Acond (cvtE b) (cvtA acc1) (cvtA acc2)
-      Atuple arrs                 -> AST.Atuple (convertSharingAtuple config alyt aenv arrs)
+      Awhile pred iter init       -> AST.Awhile (cvtAfun1 pred) (cvtAfun1 iter) (cvtA init)
+      Atuple arrs                 -> AST.Atuple (convertSharingAtuple config alyt aenv' arrs)
       Aprj ix a                   -> AST.Aprj ix (cvtA a)
       Use array                   -> AST.Use (fromArr array)
       Unit e                      -> AST.Unit (cvtE e)
@@ -280,11 +293,11 @@
       Permute f dftAcc perm acc   -> AST.Permute (cvtF2 f) (cvtA dftAcc) (cvtF1 perm) (cvtA acc)
       Backpermute newDim perm acc -> AST.Backpermute (cvtE newDim) (cvtF1 perm) (cvtA acc)
       Stencil stencil boundary acc
-        -> AST.Stencil (convertSharingStencilFun1 config acc alyt aenv stencil)
+        -> AST.Stencil (convertSharingStencilFun1 config acc alyt aenv' stencil)
                        (convertBoundary boundary)
                        (cvtA acc)
       Stencil2 stencil bndy1 acc1 bndy2 acc2
-        -> AST.Stencil2 (convertSharingStencilFun2 config acc1 acc2 alyt aenv stencil)
+        -> AST.Stencil2 (convertSharingStencilFun2 config acc1 acc2 alyt aenv' stencil)
                         (convertBoundary bndy1)
                         (cvtA acc1)
                         (convertBoundary bndy2)
@@ -295,11 +308,11 @@
        Config
     -> Layout aenv aenv
     -> [StableSharingAcc]
-    -> Tuple.Atuple SharingAcc a
+    -> Tuple.Atuple ScopedAcc a
     -> Tuple.Atuple (AST.OpenAcc aenv) a
 convertSharingAtuple config alyt aenv = cvt
   where
-    cvt :: Tuple.Atuple SharingAcc a' -> Tuple.Atuple (AST.OpenAcc aenv) a'
+    cvt :: Tuple.Atuple ScopedAcc a' -> Tuple.Atuple (AST.OpenAcc aenv) a'
     cvt NilAtup         = NilAtup
     cvt (SnocAtup t a)  = cvt t `SnocAtup` convertSharingAcc config alyt aenv a
 
@@ -417,26 +430,29 @@
     -> Layout aenv aenv         -- array environment
     -> [StableSharingExp]       -- currently bound sharing variables of expressions
     -> [StableSharingAcc]       -- currently bound sharing variables of array computations
-    -> SharingExp t             -- expression to be converted
+    -> ScopedExp t              -- expression to be converted
     -> AST.OpenExp env aenv t
-convertSharingExp config lyt alyt env aenv = cvt
+convertSharingExp config lyt alyt env aenv exp@(ScopedExp lams _) = cvt exp
   where
-    cvt :: Elt t' => SharingExp t' -> AST.OpenExp env aenv t'
-    cvt (VarSharing se)
-      | Just i <- findIndex (matchStableExp se) env
+    -- scalar environment with any lambda bound variables this expression is rooted in
+    env' = lams ++ env
+
+    cvt :: Elt t' => ScopedExp t' -> AST.OpenExp env aenv t'
+    cvt (ScopedExp _ (VarSharing se))
+      | Just i <- findIndex (matchStableExp se) env'
       = AST.Var (prjIdx (ctxt ++ "; i = " ++ show i) i lyt)
-      | null env
+      | null env'
       = error $ "Cyclic definition of a value of type 'Exp' (sa = " ++ show (hashStableNameHeight se) ++ ")"
       | otherwise
       = INTERNAL_ERROR(error) "convertSharingExp" err
       where
         ctxt = "shared 'Exp' tree with stable name " ++ show (hashStableNameHeight se)
-        err  = "inconsistent valuation @ " ++ ctxt ++ ";\n  env = " ++ show env
-    cvt (LetSharing se@(StableSharingExp _ boundExp) bodyExp)
+        err  = "inconsistent valuation @ " ++ ctxt ++ ";\n  env' = " ++ show env'
+    cvt (ScopedExp _ (LetSharing se@(StableSharingExp _ boundExp) bodyExp))
       = let lyt' = incLayout lyt `PushLayout` ZeroIdx
         in
-        AST.Let (cvt boundExp) (convertSharingExp config lyt' alyt (se:env) aenv bodyExp)
-    cvt (ExpSharing _ pexp)
+        AST.Let (cvt (ScopedExp [] boundExp)) (convertSharingExp config lyt' alyt (se:env') aenv bodyExp)
+    cvt (ScopedExp _ (ExpSharing _ pexp))
       = case pexp of
           Tag i                 -> AST.Var (prjIdx ("de Bruijn conversion tag " ++ show i) i lyt)
           Const v               -> AST.Const (fromElt v)
@@ -450,20 +466,28 @@
           ToIndex sh ix         -> AST.ToIndex (cvt sh) (cvt ix)
           FromIndex sh e        -> AST.FromIndex (cvt sh) (cvt e)
           Cond e1 e2 e3         -> AST.Cond (cvt e1) (cvt e2) (cvt e3)
+          While p it i          -> AST.While (cvtFun1 p) (cvtFun1 it) (cvt i)
           PrimConst c           -> AST.PrimConst c
           PrimApp f e           -> cvtPrimFun f (cvt e)
           Index a e             -> AST.Index (cvtA a) (cvt e)
           LinearIndex a i       -> AST.LinearIndex (cvtA a) (cvt i)
           Shape a               -> AST.Shape (cvtA a)
           ShapeSize e           -> AST.ShapeSize (cvt e)
+          Intersect sh1 sh2     -> AST.Intersect (cvt sh1) (cvt sh2)
           Foreign ff f e        -> AST.Foreign ff (convertFun (recoverExpSharing config) f) (cvt e)
 
-    cvtA :: Arrays a => SharingAcc a -> AST.OpenAcc aenv a
+    cvtA :: Arrays a => ScopedAcc a -> AST.OpenAcc aenv a
     cvtA = convertSharingAcc config alyt aenv
 
-    cvtT :: Tuple.Tuple SharingExp tup -> Tuple.Tuple (AST.OpenExp env aenv) tup
-    cvtT = convertSharingTuple config lyt alyt env aenv
+    cvtT :: Tuple.Tuple ScopedExp tup -> Tuple.Tuple (AST.OpenExp env aenv) tup
+    cvtT = convertSharingTuple config lyt alyt env' aenv
 
+    cvtFun1 :: (Elt a, Elt b) => (Exp a -> ScopedExp b) -> AST.OpenFun env aenv (a -> b)
+    cvtFun1 f = Lam (Body (convertSharingExp config lyt' alyt env' aenv body))
+      where
+        lyt' = incLayout lyt `PushLayout` ZeroIdx
+        body = f undefined
+
     -- Push primitive function applications down through let bindings so that
     -- they are adjacent to their arguments. It looks a bit nicer this way.
     --
@@ -481,7 +505,7 @@
     -> Layout aenv aenv
     -> [StableSharingExp]                 -- currently bound scalar sharing-variables
     -> [StableSharingAcc]                 -- currently bound array sharing-variables
-    -> Tuple.Tuple SharingExp t
+    -> Tuple.Tuple ScopedExp t
     -> Tuple.Tuple (AST.OpenExp env aenv) t
 convertSharingTuple config lyt alyt env aenv tup =
   case tup of
@@ -489,20 +513,6 @@
     SnocTup t e -> convertSharingTuple config lyt alyt env aenv t
          `SnocTup` convertSharingExp   config lyt alyt env aenv e
 
--- | Convert a scalar expression, which is closed with respect to scalar variables
---
-convertRootExp
-    :: Elt t
-    => Config
-    -> Layout aenv aenv         -- array environment
-    -> [StableSharingAcc]       -- currently bound array sharing-variables
-    -> RootExp t                -- expression to be converted
-    -> AST.Exp aenv t
-convertRootExp config alyt aenv exp
-  = case exp of
-      EnvExp env exp    -> convertSharingExp config EmptyLayout alyt env aenv exp
-      _                 -> INTERNAL_ERROR(error) "convertRootExp" "not an 'EnvExp'"
-
 -- | Convert a unary functions
 --
 convertSharingFun1
@@ -510,7 +520,7 @@
     => Config
     -> Layout aenv aenv
     -> [StableSharingAcc]       -- currently bound array sharing-variables
-    -> (Exp a -> RootExp b)
+    -> (Exp a -> ScopedExp b)
     -> AST.Fun aenv (a -> b)
 convertSharingFun1 config alyt aenv f = Lam (Body openF)
   where
@@ -518,8 +528,7 @@
     lyt             = EmptyLayout
                       `PushLayout`
                       (ZeroIdx :: Idx ((), a) a)
-    EnvExp env body = f a
-    openF           = convertSharingExp config lyt alyt env aenv body
+    openF           = convertSharingExp config lyt alyt [] aenv (f a)
 
 -- | Convert a binary functions
 --
@@ -528,7 +537,7 @@
     => Config
     -> Layout aenv aenv
     -> [StableSharingAcc]       -- currently bound array sharing-variables
-    -> (Exp a -> Exp b -> RootExp c)
+    -> (Exp a -> Exp b -> ScopedExp c)
     -> AST.Fun aenv (a -> b -> c)
 convertSharingFun2 config alyt aenv f = Lam (Lam (Body openF))
   where
@@ -539,18 +548,17 @@
                       (SuccIdx ZeroIdx :: Idx (((), a), b) a)
                       `PushLayout`
                       (ZeroIdx         :: Idx (((), a), b) b)
-    EnvExp env body = f a b
-    openF           = convertSharingExp config lyt alyt env aenv body
+    openF           = convertSharingExp config lyt alyt [] aenv (f a b)
 
 -- | Convert a unary stencil function
 --
 convertSharingStencilFun1
     :: forall sh a stencil b aenv. (Elt a, Stencil sh a stencil, Elt b)
     => Config
-    -> SharingAcc (Array sh a)          -- just passed to fix the type variables
+    -> ScopedAcc (Array sh a)          -- just passed to fix the type variables
     -> Layout aenv aenv
     -> [StableSharingAcc]               -- currently bound array sharing-variables
-    -> (stencil -> RootExp b)
+    -> (stencil -> ScopedExp b)
     -> AST.Fun aenv (StencilRepr sh stencil -> b)
 convertSharingStencilFun1 config _ alyt aenv stencilFun = Lam (Body openStencilFun)
   where
@@ -560,8 +568,8 @@
               (ZeroIdx :: Idx ((), StencilRepr sh stencil)
                               (StencilRepr sh stencil))
 
-    EnvExp env body = stencilFun (stencilPrj (undefined::sh) (undefined::a) stencil)
-    openStencilFun  = convertSharingExp config lyt alyt env aenv body
+    body = stencilFun (stencilPrj (undefined::sh) (undefined::a) stencil)
+    openStencilFun  = convertSharingExp config lyt alyt [] aenv body
 
 -- | Convert a binary stencil function
 --
@@ -571,11 +579,11 @@
         Elt b, Stencil sh b stencil2,
         Elt c)
     => Config
-    -> SharingAcc (Array sh a)          -- just passed to fix the type variables
-    -> SharingAcc (Array sh b)          -- just passed to fix the type variables
+    -> ScopedAcc (Array sh a)          -- just passed to fix the type variables
+    -> ScopedAcc (Array sh b)          -- just passed to fix the type variables
     -> Layout aenv aenv
     -> [StableSharingAcc]               -- currently bound array sharing-variables
-    -> (stencil1 -> stencil2 -> RootExp c)
+    -> (stencil1 -> stencil2 -> ScopedExp c)
     -> AST.Fun aenv (StencilRepr sh stencil1 -> StencilRepr sh stencil2 -> c)
 convertSharingStencilFun2 config _ _ alyt aenv stencilFun = Lam (Lam (Body openStencilFun))
   where
@@ -591,9 +599,9 @@
                                             StencilRepr sh stencil2)
                                        (StencilRepr sh stencil2))
 
-    EnvExp env body = stencilFun (stencilPrj (undefined::sh) (undefined::a) stencil1)
-                                 (stencilPrj (undefined::sh) (undefined::b) stencil2)
-    openStencilFun  = convertSharingExp config lyt alyt env aenv body
+    body = stencilFun (stencilPrj (undefined::sh) (undefined::a) stencil1)
+                      (stencilPrj (undefined::sh) (undefined::b) stencil2)
+    openStencilFun  = convertSharingExp config lyt alyt [] aenv body
 
 
 -- Sharing recovery
@@ -781,19 +789,28 @@
 -- represented by variable (binding a shared subtree) using 'AvarSharing' and as being prefixed by
 -- a let binding (for a shared subtree) using 'AletSharing'.
 --
-data SharingAcc arrs where
+data SharingAcc acc exp arrs where
   AvarSharing :: Arrays arrs
-              => StableAccName arrs                                   -> SharingAcc arrs
-  AletSharing :: StableSharingAcc -> SharingAcc arrs                  -> SharingAcc arrs
+              => StableAccName arrs                        -> SharingAcc acc exp arrs
+  AletSharing :: StableSharingAcc -> acc arrs              -> SharingAcc acc exp arrs
   AccSharing  :: Arrays arrs
-              => StableAccName arrs -> PreAcc SharingAcc RootExp arrs -> SharingAcc arrs
+              => StableAccName arrs -> PreAcc acc exp arrs -> SharingAcc acc exp arrs
 
+-- Array expression with sharing but shared values have not been scoped; i.e. no let bindings. If
+-- the expression is rooted in a function, the list contains the tags of the variables bound by the
+-- immediate surrounding lambdas.
+data UnscopedAcc t = UnscopedAcc [Int] (SharingAcc UnscopedAcc RootExp t)
+
+-- Array expression with sharing. For expressions rooted in functions the list holds a sorted
+-- environment corresponding to the variables bound in the immediate surounding lambdas.
+data ScopedAcc t = ScopedAcc [StableSharingAcc] (SharingAcc ScopedAcc ScopedExp t)
+
 -- Stable name for an array computation associated with its sharing-annotated version.
 --
 data StableSharingAcc where
   StableSharingAcc :: Arrays arrs
                    => StableAccName arrs
-                   -> SharingAcc arrs
+                   -> SharingAcc ScopedAcc ScopedExp arrs
                    -> StableSharingAcc
 
 instance Show StableSharingAcc where
@@ -829,29 +846,35 @@
 -- Interleave sharing annotations into a scalar expressions AST in the same manner as 'SharingAcc'
 -- do for array computations.
 --
-data SharingExp t where
+data SharingExp (acc :: * -> *) exp t where
   VarSharing :: Elt t
-             => StableExpName t                                   -> SharingExp t
-  LetSharing :: StableSharingExp -> SharingExp t                  -> SharingExp t
+             => StableExpName t                            -> SharingExp acc exp t
+  LetSharing :: StableSharingExp -> exp t                  -> SharingExp acc exp t
   ExpSharing :: Elt t
-             => StableExpName t -> PreExp SharingAcc SharingExp t -> SharingExp t
+             => StableExpName t -> PreExp acc exp t -> SharingExp acc exp t
 
+-- Specifies a scalar expression AST with sharing annotations but no scoping; i.e. no LetSharing
+-- constructors. If the expression is rooted in a function, the list contains the tags of the
+-- variables bound by the immediate surrounding lambdas.
+data UnscopedExp t = UnscopedExp [Int] (SharingExp UnscopedAcc UnscopedExp t)
+
+-- Specifies a scalar expression AST with sharing. For expressions rooted in functions the list
+-- holds a sorted environment corresponding to the variables bound in the immediate surounding
+-- lambdas.
+data ScopedExp t = ScopedExp [StableSharingExp] (SharingExp ScopedAcc ScopedExp t)
+
 -- Expressions rooted in 'Acc' computations.
 --
--- * Between counting occurrences and determining scopes, the root of every expression embedded in an
---   'Acc' is annotated by (1) the tags of free scalar variables and (2) an occurrence map for that
---   one expression (excluding any subterms that are rooted in embedded 'Acc's.)
--- * After determining scopes, the root of every expression is annotated with a sorted environment of
---   the 'StableSharingExp's corresponding to its free expression-valued variables.
+-- * When counting occurrences, the root of every expression embedded in an 'Acc' is annotated by
+--   an occurrence map for that one expression (excluding any subterms that are rooted in embedded
+--   'Acc's.)
 --
-data RootExp t where
-  OccMapExp :: [Int] -> OccMap Exp -> SharingExp t -> RootExp t
-  EnvExp    :: [StableSharingExp]  -> SharingExp t -> RootExp t
+data RootExp t = RootExp (OccMap Exp) (UnscopedExp t)
 
 -- Stable name for an expression associated with its sharing-annotated version.
 --
 data StableSharingExp where
-  StableSharingExp :: Elt t => StableExpName t -> SharingExp t -> StableSharingExp
+  StableSharingExp :: Elt t => StableExpName t -> SharingExp ScopedAcc ScopedExp t -> StableSharingExp
 
 instance Show StableSharingExp where
   show (StableSharingExp sn _) = show $ hashStableNameHeight sn
@@ -910,7 +933,7 @@
     => Config
     -> Level
     -> Acc arrs
-    -> IO (SharingAcc arrs, OccMap Acc)
+    -> IO (UnscopedAcc arrs, OccMap Acc)
 makeOccMapAcc config lvl acc = do
   traceLine "makeOccMapAcc" "Enter"
   accOccMap             <- newASTHashTable
@@ -926,7 +949,7 @@
     -> OccMapHash Acc
     -> Level
     -> Acc arrs
-    -> IO (SharingAcc arrs, Int)
+    -> IO (UnscopedAcc arrs, Int)
 makeOccMapSharingAcc config accOccMap = traverseAcc
   where
     traverseFun1 :: (Elt a, Typeable b) => Level -> (Exp a -> Exp b) -> IO (Exp a -> RootExp b, Int)
@@ -938,10 +961,13 @@
                  -> IO (Exp a -> Exp b -> RootExp c, Int)
     traverseFun2 = makeOccMapFun2 config accOccMap
 
+    traverseAfun1 :: (Arrays a, Typeable b) => Level -> (Acc a -> Acc b) -> IO (Acc a -> UnscopedAcc b, Int)
+    traverseAfun1 = makeOccMapAfun1 config accOccMap
+
     traverseExp :: Typeable e => Level -> Exp e -> IO (RootExp e, Int)
     traverseExp = makeOccMapExp config accOccMap
 
-    traverseAcc :: forall arrs. Typeable arrs => Level -> Acc arrs -> IO (SharingAcc arrs, Int)
+    traverseAcc :: forall arrs. Typeable arrs => Level -> Acc arrs -> IO (UnscopedAcc arrs, Int)
     traverseAcc lvl acc@(Acc pacc)
       = mfix $ \ ~(_, height) -> do
           -- Compute stable name and enter it into the occurrence map
@@ -964,14 +990,14 @@
           --     case we cannot discharge the 'Arrays arrs' constraint.
           --
           let reconstruct :: Arrays arrs
-                          => IO (PreAcc SharingAcc RootExp arrs, Int)
-                          -> IO (SharingAcc arrs, Int)
+                          => IO (PreAcc UnscopedAcc RootExp arrs, Int)
+                          -> IO (UnscopedAcc arrs, Int)
               reconstruct newAcc
                 = case heightIfRepeatedOccurrence of
                     Just height | recoverAccSharing config
-                      -> return (AvarSharing (StableNameHeight sn height), height)
+                      -> return (UnscopedAcc [] (AvarSharing (StableNameHeight sn height)), height)
                     _ -> do (acc, height) <- newAcc
-                            return (AccSharing (StableNameHeight sn height) acc, height)
+                            return (UnscopedAcc [] (AccSharing (StableNameHeight sn height) acc), height)
 
           case pacc of
             Atag i                      -> reconstruct $ return (Atag i, 0)           -- height is 0!
@@ -982,6 +1008,12 @@
                                              (acc1', h2) <- traverseAcc lvl acc1
                                              (acc2', h3) <- traverseAcc lvl acc2
                                              return (Acond e' acc1' acc2', h1 `max` h2 `max` h3 + 1)
+            Awhile pred iter init       -> reconstruct $ do
+                                             (pred', h1) <- traverseAfun1 lvl pred
+                                             (iter', h2) <- traverseAfun1 lvl iter
+                                             (init', h3) <- traverseAcc lvl init
+                                             return (Awhile pred' iter' init'
+                                                    , h1 `max` h2 `max` h3 + 1)
 
             Atuple tup                  -> reconstruct $ do
                                              (tup', h) <- travAtup tup
@@ -1046,16 +1078,16 @@
 
       where
         travA :: Arrays arrs'
-              => (SharingAcc arrs' -> PreAcc SharingAcc RootExp arrs)
-              -> Acc arrs' -> IO (PreAcc SharingAcc RootExp arrs, Int)
+              => (UnscopedAcc arrs' -> PreAcc UnscopedAcc RootExp arrs)
+              -> Acc arrs' -> IO (PreAcc UnscopedAcc RootExp arrs, Int)
         travA c acc
           = do
               (acc', h) <- traverseAcc lvl acc
               return (c acc', h + 1)
 
         travEA :: (Typeable b, Arrays arrs')
-               => (RootExp b -> SharingAcc arrs' -> PreAcc SharingAcc RootExp arrs)
-               -> Exp b -> Acc arrs' -> IO (PreAcc SharingAcc RootExp arrs, Int)
+               => (RootExp b -> UnscopedAcc arrs' -> PreAcc UnscopedAcc RootExp arrs)
+               -> Exp b -> Acc arrs' -> IO (PreAcc UnscopedAcc RootExp arrs, Int)
         travEA c exp acc
           = do
               (exp', h1) <- traverseExp lvl exp
@@ -1063,10 +1095,10 @@
               return (c exp' acc', h1 `max` h2 + 1)
 
         travF2A :: (Elt b, Elt c, Typeable d, Arrays arrs')
-                => ((Exp b -> Exp c -> RootExp d) -> SharingAcc arrs'
-                    -> PreAcc SharingAcc RootExp arrs)
+                => ((Exp b -> Exp c -> RootExp d) -> UnscopedAcc arrs'
+                    -> PreAcc UnscopedAcc RootExp arrs)
                 -> (Exp b -> Exp c -> Exp d) -> Acc arrs'
-                -> IO (PreAcc SharingAcc RootExp arrs, Int)
+                -> IO (PreAcc UnscopedAcc RootExp arrs, Int)
         travF2A c fun acc
           = do
               (fun', h1) <- traverseFun2 lvl fun
@@ -1074,9 +1106,9 @@
               return (c fun' acc', h1 `max` h2 + 1)
 
         travF2EA :: (Elt b, Elt c, Typeable d, Typeable e, Arrays arrs')
-                 => ((Exp b -> Exp c -> RootExp d) -> RootExp e -> SharingAcc arrs' -> PreAcc SharingAcc RootExp arrs)
+                 => ((Exp b -> Exp c -> RootExp d) -> RootExp e -> UnscopedAcc arrs' -> PreAcc UnscopedAcc RootExp arrs)
                  -> (Exp b -> Exp c -> Exp d) -> Exp e -> Acc arrs'
-                 -> IO (PreAcc SharingAcc RootExp arrs, Int)
+                 -> IO (PreAcc UnscopedAcc RootExp arrs, Int)
         travF2EA c fun exp acc
           = do
               (fun', h1) <- traverseFun2 lvl fun
@@ -1085,9 +1117,9 @@
               return (c fun' exp' acc', h1 `max` h2 `max` h3 + 1)
 
         travF2A2 :: (Elt b, Elt c, Typeable d, Arrays arrs1, Arrays arrs2)
-                 => ((Exp b -> Exp c -> RootExp d) -> SharingAcc arrs1 -> SharingAcc arrs2 -> PreAcc SharingAcc RootExp arrs)
+                 => ((Exp b -> Exp c -> RootExp d) -> UnscopedAcc arrs1 -> UnscopedAcc arrs2 -> PreAcc UnscopedAcc RootExp arrs)
                  -> (Exp b -> Exp c -> Exp d) -> Acc arrs1 -> Acc arrs2
-                 -> IO (PreAcc SharingAcc RootExp arrs, Int)
+                 -> IO (PreAcc UnscopedAcc RootExp arrs, Int)
         travF2A2 c fun acc1 acc2
           = do
               (fun' , h1) <- traverseFun2 lvl fun
@@ -1096,14 +1128,26 @@
               return (c fun' acc1' acc2', h1 `max` h2 `max` h3 + 1)
 
         travAtup :: Tuple.Atuple Acc a
-                 -> IO (Tuple.Atuple SharingAcc a, Int)
+                 -> IO (Tuple.Atuple UnscopedAcc a, Int)
         travAtup NilAtup          = return (NilAtup, 1)
         travAtup (SnocAtup tup a) = do
           (tup', h1) <- travAtup tup
           (a',   h2) <- traverseAcc lvl a
           return (SnocAtup tup' a', h1 `max` h2 + 1)
 
+makeOccMapAfun1 :: (Arrays a, Typeable b)
+                => Config
+                -> OccMapHash Acc
+                -> Level
+                -> (Acc a -> Acc b)
+                -> IO (Acc a -> UnscopedAcc b, Int)
+makeOccMapAfun1 config accOccMap lvl f = do
+  let x = Acc (Atag lvl)
+  --
+  (UnscopedAcc [] body, height) <- makeOccMapSharingAcc config accOccMap (lvl+1) (f x)
+  return (const (UnscopedAcc [lvl] body), height)
 
+
 -- Generate occupancy information for scalar functions and expressions. Helper
 -- functions wrapping around 'makeOccMapRootExp' with more specific types.
 --
@@ -1195,11 +1239,11 @@
     -> IO (RootExp e, Int)
 makeOccMapRootExp config accOccMap lvl fvs exp = do
   traceLine "makeOccMapRootExp" "Enter"
-  expOccMap             <- newASTHashTable
-  (exp', height)        <- makeOccMapSharingExp config accOccMap expOccMap lvl exp
-  frozenExpOccMap       <- freezeOccMap expOccMap
+  expOccMap                     <- newASTHashTable
+  (UnscopedExp [] exp', height) <- makeOccMapSharingExp config accOccMap expOccMap lvl exp
+  frozenExpOccMap               <- freezeOccMap expOccMap
   traceLine "makeOccMapRootExp" "Exit"
-  return (OccMapExp fvs frozenExpOccMap exp', height)
+  return (RootExp frozenExpOccMap (UnscopedExp fvs exp'), height)
 
 
 -- Generate sharing information for an open scalar expression.
@@ -1211,10 +1255,10 @@
     -> OccMapHash Exp
     -> Level                            -- The level of currently bound variables
     -> Exp e
-    -> IO (SharingExp e, Int)
+    -> IO (UnscopedExp e, Int)
 makeOccMapSharingExp config accOccMap expOccMap = travE
   where
-    travE :: forall a. Typeable a => Level -> Exp a -> IO (SharingExp a, Int)
+    travE :: forall a. Typeable a => Level -> Exp a -> IO (UnscopedExp a, Int)
     travE lvl exp@(Exp pexp)
       = mfix $ \ ~(_, height) -> do
           -- Compute stable name and enter it into the occurrence map
@@ -1237,14 +1281,14 @@
           --     case we cannot discharge the 'Elt a' constraint.
           --
           let reconstruct :: Elt a
-                          => IO (PreExp SharingAcc SharingExp a, Int)
-                          -> IO (SharingExp a, Int)
+                          => IO (PreExp UnscopedAcc UnscopedExp a, Int)
+                          -> IO (UnscopedExp a, Int)
               reconstruct newExp
                 = case heightIfRepeatedOccurrence of
                     Just height | recoverExpSharing config
-                      -> return (VarSharing (StableNameHeight sn height), height)
+                      -> return (UnscopedExp [] (VarSharing (StableNameHeight sn height)), height)
                     _ -> do (exp, height) <- newExp
-                            return (ExpSharing (StableNameHeight sn height) exp, height)
+                            return (UnscopedExp [] (ExpSharing (StableNameHeight sn height) exp), height)
 
           case pexp of
             Tag i               -> reconstruct $ return (Tag i, 0)      -- height is 0!
@@ -1261,31 +1305,48 @@
             ToIndex sh ix       -> reconstruct $ travE2 ToIndex sh ix
             FromIndex sh e      -> reconstruct $ travE2 FromIndex sh e
             Cond e1 e2 e3       -> reconstruct $ travE3 Cond e1 e2 e3
+            While p iter init   -> reconstruct $ do
+                                     (p'   , h1) <- traverseFun1 lvl p
+                                     (iter', h2) <- traverseFun1 lvl iter
+                                     (init', h3) <- travE lvl init
+                                     return (While p' iter' init', h1 `max` h2 `max` h3 + 1)
             PrimConst c         -> reconstruct $ return (PrimConst c, 1)
             PrimApp p e         -> reconstruct $ travE1 (PrimApp p) e
             Index a e           -> reconstruct $ travAE Index a e
             LinearIndex a i     -> reconstruct $ travAE LinearIndex a i
             Shape a             -> reconstruct $ travA Shape a
             ShapeSize e         -> reconstruct $ travE1 ShapeSize e
+            Intersect sh1 sh2   -> reconstruct $ travE2 Intersect sh1 sh2
             Foreign ff f e      -> reconstruct $ do
                                       (e', h) <- travE lvl e
                                       return  (Foreign ff f e', h+1)
 
       where
-        traverseAcc :: Typeable arrs => Level -> Acc arrs -> IO (SharingAcc arrs, Int)
+        traverseAcc :: Typeable arrs => Level -> Acc arrs -> IO (UnscopedAcc arrs, Int)
         traverseAcc = makeOccMapSharingAcc config accOccMap
 
-        travE1 :: Typeable b => (SharingExp b -> PreExp SharingAcc SharingExp a) -> Exp b
-               -> IO (PreExp SharingAcc SharingExp a, Int)
+        traverseFun1 :: (Elt a, Typeable b)
+                     => Level
+                     -> (Exp a -> Exp b)
+                     -> IO (Exp a -> UnscopedExp b, Int)
+        traverseFun1 lvl f
+          = do
+              let x = Exp (Tag lvl)
+              (UnscopedExp [] body, height) <- travE (lvl+1) (f x)
+              return (const (UnscopedExp [lvl] body), height + 1)
+
+
+        travE1 :: Typeable b => (UnscopedExp b -> PreExp UnscopedAcc UnscopedExp a) -> Exp b
+               -> IO (PreExp UnscopedAcc UnscopedExp a, Int)
         travE1 c e
           = do
               (e', h) <- travE lvl e
               return (c e', h + 1)
 
         travE2 :: (Typeable b, Typeable c)
-               => (SharingExp b -> SharingExp c -> PreExp SharingAcc SharingExp a)
+               => (UnscopedExp b -> UnscopedExp c -> PreExp UnscopedAcc UnscopedExp a)
                -> Exp b -> Exp c
-               -> IO (PreExp SharingAcc SharingExp a, Int)
+               -> IO (PreExp UnscopedAcc UnscopedExp a, Int)
         travE2 c e1 e2
           = do
               (e1', h1) <- travE lvl e1
@@ -1293,9 +1354,9 @@
               return (c e1' e2', h1 `max` h2 + 1)
 
         travE3 :: (Typeable b, Typeable c, Typeable d)
-               => (SharingExp b -> SharingExp c -> SharingExp d -> PreExp SharingAcc SharingExp a)
+               => (UnscopedExp b -> UnscopedExp c -> UnscopedExp d -> PreExp UnscopedAcc UnscopedExp a)
                -> Exp b -> Exp c -> Exp d
-               -> IO (PreExp SharingAcc SharingExp a, Int)
+               -> IO (PreExp UnscopedAcc UnscopedExp a, Int)
         travE3 c e1 e2 e3
           = do
               (e1', h1) <- travE lvl e1
@@ -1303,24 +1364,24 @@
               (e3', h3) <- travE lvl e3
               return (c e1' e2' e3', h1 `max` h2 `max` h3 + 1)
 
-        travA :: Typeable b => (SharingAcc b -> PreExp SharingAcc SharingExp a) -> Acc b
-              -> IO (PreExp SharingAcc SharingExp a, Int)
+        travA :: Typeable b => (UnscopedAcc b -> PreExp UnscopedAcc UnscopedExp a) -> Acc b
+              -> IO (PreExp UnscopedAcc UnscopedExp a, Int)
         travA c acc
           = do
               (acc', h) <- traverseAcc lvl acc
               return (c acc', h + 1)
 
         travAE :: (Typeable b, Typeable c)
-               => (SharingAcc b -> SharingExp c -> PreExp SharingAcc SharingExp a)
+               => (UnscopedAcc b -> UnscopedExp c -> PreExp UnscopedAcc UnscopedExp a)
                -> Acc b -> Exp c
-               -> IO (PreExp SharingAcc SharingExp a, Int)
+               -> IO (PreExp UnscopedAcc UnscopedExp a, Int)
         travAE c acc e
           = do
               (acc', h1) <- traverseAcc lvl acc
               (e'  , h2) <- travE lvl e
               return (c acc' e', h1 `max` h2 + 1)
 
-        travTup :: Tuple.Tuple Exp tup -> IO (Tuple.Tuple SharingExp tup, Int)
+        travTup :: Tuple.Tuple Exp tup -> IO (Tuple.Tuple UnscopedExp tup, Int)
         travTup NilTup          = return (NilTup, 1)
         travTup (SnocTup tup e) = do
                                     (tup', h1) <- travTup tup
@@ -1328,11 +1389,13 @@
                                     return (SnocTup tup' e', h1 `max` h2 + 1)
 
 
--- Type used to maintain how often each shared subterm, so far, occurred during a bottom-up sweep.
+-- Type used to maintain how often each shared subterm, so far, occurred during a bottom-up sweep,
+-- as well as the relation between subterms. It is comprised of a list of terms and a graph giving
+-- their relation.
 --
---   Invariants:
+--   Invariants of the list:
 --   - If one shared term 's' is itself a subterm of another shared term 't', then 's' must occur
---     *after* 't' in the 'NodeCounts'.
+--     *after* 't' in the list.
 --   - No shared term occurs twice.
 --   - A term may have a final occurrence count of only 1 iff it is either a free variable ('Atag'
 --     or 'Tag') or an array computation lifted out of an expression.
@@ -1344,11 +1407,31 @@
 -- is 0, whereas other leaves have height 1.  This guarantees that all free variables are at the end
 -- of the 'NodeCounts' list.
 --
--- To ensure the invariant is preserved over merging node counts from sibling subterms, the
--- function '(+++)' must be used.
+-- The graph is represented as a map where a stable name 'a' is mapped to a set of stables names 'b'
+-- such that if there exists a edge from 'a' to 'c' that 'c' is contained within 'b'.
 --
-type NodeCounts = [NodeCount]
+--  Properties of the graph:
+--  - There exists an edge from 'a' to 'b' if the term 'a' names is a subterm of the term named by
+--    'b'.
+--
+-- To ensure the list invariant and the graph properties are preserved over merging node counts from
+-- sibling subterms, the function '(+++)' must be used.
+--
+type NodeCounts = ([NodeCount], Map.HashMap NodeName (Set.HashSet NodeName))
 
+data NodeName where
+  NodeName :: Typeable a => StableName a -> NodeName
+
+instance Eq NodeName where
+  (NodeName sn1) == (NodeName sn2) | Just sn2' <- gcast sn2 = sn1 == sn2'
+                                   | otherwise              = False
+
+instance Hashable NodeName where
+  hashWithSalt hash (NodeName sn1) = hash + hashStableName sn1
+
+instance Show NodeName where
+  show (NodeName sn) = show (hashStableName sn)
+
 data NodeCount = AccNodeCount StableSharingAcc Int
                | ExpNodeCount StableSharingExp Int
                deriving Show
@@ -1356,27 +1439,55 @@
 -- Empty node counts
 --
 noNodeCounts :: NodeCounts
-noNodeCounts = []
+noNodeCounts = ([], Map.empty)
 
--- Singleton node counts for 'Acc'
+-- Insert an Acc node into the node counts, assuming that it is a superterm of the all the existing
+-- nodes.
 --
-accNodeCount :: StableSharingAcc -> Int -> NodeCounts
-accNodeCount ssa n = [AccNodeCount ssa n]
+-- TODO: Perform cycle detection here.
+insertAccNode :: StableSharingAcc -> NodeCounts -> NodeCounts
+insertAccNode ssa@(StableSharingAcc (StableNameHeight sn _) _) (subterms,g)
+  = ([AccNodeCount ssa 1], g') +++ (subterms,g)
+  where
+    k  = NodeName sn
+    hs = map nodeName subterms
+    g' = Map.fromList $ (k, Set.empty) : [(h, Set.singleton k) | h <- hs]
 
--- Singleton node counts for 'Exp'
+-- Insert an Exp node into the node counts, assuming that it is a superterm of the all the existing
+-- nodes.
 --
-expNodeCount :: StableSharingExp -> Int -> NodeCounts
-expNodeCount sse n = [ExpNodeCount sse n]
+-- TODO: Perform cycle detection here.
+insertExpNode :: StableSharingExp -> NodeCounts -> NodeCounts
+insertExpNode ssa@(StableSharingExp (StableNameHeight sn _) _) (subterms,g)
+  = ([ExpNodeCount ssa 1], g') +++ (subterms,g)
+  where
+    k  = NodeName sn
+    hs = map nodeName subterms
+    g' = Map.fromList $ (k, Set.empty) : [(h, Set.singleton k) | h <- hs]
 
+-- Remove nodes that aren't in the list from the graph.
+--
+-- RCE: This is no longer necessary when NDP is supported.
+cleanCounts :: NodeCounts -> NodeCounts
+cleanCounts (ns, g) = (ns, Map.fromList $ [(h, Set.filter (flip elem hs) (g Map.! h)) | h <- hs ])
+  where
+    hs = (map nodeName ns)
+
+nodeName :: NodeCount -> NodeName
+nodeName (AccNodeCount (StableSharingAcc (StableNameHeight sn _) _) _) = NodeName sn
+nodeName (ExpNodeCount (StableSharingExp (StableNameHeight sn _) _) _) = NodeName sn
+
 -- Combine node counts that belong to the same node.
 --
--- * We assume that the node counts invariant —subterms follow their parents— holds for both
---   arguments and guarantee that it still holds for the result.
+-- * We assume that the list invariant —subterms follow their parents— holds for both arguments and
+--   guarantee that it still holds for the result.
 -- * In the same manner, we assume that all 'Exp' node counts precede 'Acc' node counts and
 --   guarantee that this also hold for the result.
 --
+-- RCE: The list combination should be able to be performed as a more efficient merge.
+--
 (+++) :: NodeCounts -> NodeCounts -> NodeCounts
-us +++ vs = foldr insert us vs
+(ns1,g1) +++ (ns2,g2) = (foldr insert ns1 ns2, Map.unionWith Set.union g1 g2)
   where
     insert x               []                         = [x]
     insert x@(AccNodeCount sa1 count1) ys@(y@(AccNodeCount sa2 count2) : ys')
@@ -1422,7 +1533,7 @@
           $ "Encountered a node that is not a plain 'Atag'\n  " ++ showSA sa
 
         noStableSharing :: StableSharingAcc
-        noStableSharing = StableSharingAcc noStableAccName (undefined :: SharingAcc ())
+        noStableSharing = StableSharingAcc noStableAccName (undefined :: SharingAcc acc exp ())
 
     showSA (StableSharingAcc _ (AccSharing  sn acc)) = show (hashStableNameHeight sn) ++ ": " ++
                                                        showPreAccOp acc
@@ -1453,7 +1564,7 @@
               ("Encountered a node that is not a plain 'Tag'\n  " ++ showSE se)
 
         noStableSharing :: StableSharingExp
-        noStableSharing = StableSharingExp noStableExpName (undefined :: SharingExp ())
+        noStableSharing = StableSharingExp noStableExpName (undefined :: SharingExp acc exp ())
 
     showSE (StableSharingExp _ (ExpSharing sn exp)) = show (hashStableNameHeight sn) ++ ": " ++
                                                       showPreExpOp exp
@@ -1487,10 +1598,10 @@
     => Config
     -> [Level]
     -> OccMap Acc
-    -> SharingAcc a
-    -> (SharingAcc a, [StableSharingAcc])
+    -> UnscopedAcc a
+    -> (ScopedAcc a, [StableSharingAcc])
 determineScopesAcc config fvs accOccMap rootAcc
-  = let (sharingAcc, counts) = determineScopesSharingAcc config accOccMap rootAcc
+  = let (sharingAcc, (counts, _)) = determineScopesSharingAcc config accOccMap rootAcc
         unboundTrees         = filter (not . isFreeVar) counts
     in
     if all isFreeVar counts
@@ -1501,18 +1612,18 @@
 determineScopesSharingAcc
     :: Config
     -> OccMap Acc
-    -> SharingAcc a
-    -> (SharingAcc a, NodeCounts)
+    -> UnscopedAcc a
+    -> (ScopedAcc a, NodeCounts)
 determineScopesSharingAcc config accOccMap = scopesAcc
   where
-    scopesAcc :: forall arrs. SharingAcc arrs -> (SharingAcc arrs, NodeCounts)
-    scopesAcc (AletSharing _ _)
+    scopesAcc :: forall arrs. UnscopedAcc arrs -> (ScopedAcc arrs, NodeCounts)
+    scopesAcc (UnscopedAcc _ (AletSharing _ _))
       = INTERNAL_ERROR(error) "determineScopesSharingAcc: scopesAcc" "unexpected 'AletSharing'"
 
-    scopesAcc sharingAcc@(AvarSharing sn)
-      = (sharingAcc, StableSharingAcc sn sharingAcc `accNodeCount` 1)
+    scopesAcc (UnscopedAcc _ (AvarSharing sn))
+      = (ScopedAcc [] (AvarSharing sn), StableSharingAcc sn (AvarSharing sn) `insertAccNode` noNodeCounts)
 
-    scopesAcc (AccSharing sn pacc)
+    scopesAcc (UnscopedAcc _ (AccSharing sn pacc))
       = case pacc of
           Atag i                  -> reconstruct (Atag i) noNodeCounts
           Pipe afun1 afun2 acc    -> travA (Pipe afun1 afun2) acc
@@ -1529,6 +1640,14 @@
                                      reconstruct (Acond e' acc1' acc2')
                                                  (accCount1 +++ accCount2 +++ accCount3)
 
+          Awhile pred iter init   -> let
+                                       (pred', accCount1) = scopesAfun1 pred
+                                       (iter', accCount2) = scopesAfun1 iter
+                                       (init', accCount3) = scopesAcc init
+                                     in
+                                     reconstruct (Awhile pred' iter' init')
+                                                 (accCount1 +++ accCount2 +++ accCount3)
+
           Atuple tup              -> let (tup', accCount) = travAtup tup
                                      in  reconstruct (Atuple tup') accCount
           Aprj ix a               -> travA (Aprj ix) a
@@ -1599,33 +1718,33 @@
                                        (accCount1 +++ accCount2 +++ accCount3)
       where
         travEA :: Arrays arrs
-               => (RootExp e -> SharingAcc arrs' -> PreAcc SharingAcc RootExp arrs)
+               => (ScopedExp e -> ScopedAcc arrs' -> PreAcc ScopedAcc ScopedExp arrs)
                -> RootExp e
-               -> SharingAcc arrs'
-               -> (SharingAcc arrs, NodeCounts)
+               -> UnscopedAcc arrs'
+               -> (ScopedAcc arrs, NodeCounts)
         travEA c e acc = reconstruct (c e' acc') (accCount1 +++ accCount2)
           where
             (e'  , accCount1) = scopesExp e
             (acc', accCount2) = scopesAcc acc
 
         travF2A :: (Elt a, Elt b, Arrays arrs)
-                => ((Exp a -> Exp b -> RootExp c) -> SharingAcc arrs'
-                    -> PreAcc SharingAcc RootExp arrs)
+                => ((Exp a -> Exp b -> ScopedExp c) -> ScopedAcc arrs'
+                    -> PreAcc ScopedAcc ScopedExp arrs)
                 -> (Exp a -> Exp b -> RootExp c)
-                -> SharingAcc arrs'
-                -> (SharingAcc arrs, NodeCounts)
+                -> UnscopedAcc arrs'
+                -> (ScopedAcc arrs, NodeCounts)
         travF2A c f acc = reconstruct (c f' acc') (accCount1 +++ accCount2)
           where
             (f'  , accCount1) = scopesFun2 f
             (acc', accCount2) = scopesAcc  acc
 
         travF2EA :: (Elt a, Elt b, Arrays arrs)
-                 => ((Exp a -> Exp b -> RootExp c) -> RootExp e
-                     -> SharingAcc arrs' -> PreAcc SharingAcc RootExp arrs)
+                 => ((Exp a -> Exp b -> ScopedExp c) -> ScopedExp e
+                     -> ScopedAcc arrs' -> PreAcc ScopedAcc ScopedExp arrs)
                  -> (Exp a -> Exp b -> RootExp c)
                  -> RootExp e
-                 -> SharingAcc arrs'
-                 -> (SharingAcc arrs, NodeCounts)
+                 -> UnscopedAcc arrs'
+                 -> (ScopedAcc arrs, NodeCounts)
         travF2EA c f e acc = reconstruct (c f' e' acc') (accCount1 +++ accCount2 +++ accCount3)
           where
             (f'  , accCount1) = scopesFun2 f
@@ -1633,12 +1752,12 @@
             (acc', accCount3) = scopesAcc  acc
 
         travF2A2 :: (Elt a, Elt b, Arrays arrs)
-                 => ((Exp a -> Exp b -> RootExp c) -> SharingAcc arrs1
-                     -> SharingAcc arrs2 -> PreAcc SharingAcc RootExp arrs)
+                 => ((Exp a -> Exp b -> ScopedExp c) -> ScopedAcc arrs1
+                     -> ScopedAcc arrs2 -> PreAcc ScopedAcc ScopedExp arrs)
                  -> (Exp a -> Exp b -> RootExp c)
-                 -> SharingAcc arrs1
-                 -> SharingAcc arrs2
-                 -> (SharingAcc arrs, NodeCounts)
+                 -> UnscopedAcc arrs1
+                 -> UnscopedAcc arrs2
+                 -> (ScopedAcc arrs, NodeCounts)
         travF2A2 c f acc1 acc2 = reconstruct (c f' acc1' acc2')
                                              (accCount1 +++ accCount2 +++ accCount3)
           where
@@ -1646,8 +1765,8 @@
             (acc1', accCount2) = scopesAcc  acc1
             (acc2', accCount3) = scopesAcc  acc2
 
-        travAtup ::  Tuple.Atuple SharingAcc a
-                 -> (Tuple.Atuple SharingAcc a, NodeCounts)
+        travAtup ::  Tuple.Atuple UnscopedAcc a
+                 -> (Tuple.Atuple ScopedAcc a, NodeCounts)
         travAtup NilAtup          = (NilAtup, noNodeCounts)
         travAtup (SnocAtup tup a) = let (tup', accCountT) = travAtup tup
                                         (a',   accCountA) = scopesAcc a
@@ -1655,9 +1774,9 @@
                                     (SnocAtup tup' a', accCountT +++ accCountA)
 
         travA :: Arrays arrs
-              => (SharingAcc arrs' -> PreAcc SharingAcc RootExp arrs)
-              -> SharingAcc arrs'
-              -> (SharingAcc arrs, NodeCounts)
+              => (ScopedAcc arrs' -> PreAcc ScopedAcc ScopedExp arrs)
+              -> UnscopedAcc arrs'
+              -> (ScopedAcc arrs, NodeCounts)
         travA c acc = reconstruct (c acc') accCount
           where
             (acc', accCount) = scopesAcc acc
@@ -1680,32 +1799,32 @@
         -- node.
         --
         reconstruct :: Arrays arrs
-                    => PreAcc SharingAcc RootExp arrs -> NodeCounts
-                    -> (SharingAcc arrs, NodeCounts)
+                    => PreAcc ScopedAcc ScopedExp arrs -> NodeCounts
+                    -> (ScopedAcc arrs, NodeCounts)
         reconstruct newAcc@(Atag _) _subCount
               -- free variable => replace by a sharing variable regardless of the number of
               -- occurrences
-          = let thisCount = StableSharingAcc sn (AccSharing sn newAcc) `accNodeCount` 1
+          = let thisCount = StableSharingAcc sn (AccSharing sn newAcc) `insertAccNode` noNodeCounts
             in
             tracePure "FREE" (show thisCount)
-            (AvarSharing sn, thisCount)
+            (ScopedAcc [] (AvarSharing sn), thisCount)
         reconstruct newAcc subCount
               -- shared subtree => replace by a sharing variable (if 'recoverAccSharing' enabled)
           | accOccCount > 1 && recoverAccSharing config
-          = let allCount = (StableSharingAcc sn sharingAcc `accNodeCount` 1) +++ newCount
+          = let allCount = (StableSharingAcc sn sharingAcc `insertAccNode` newCount)
             in
             tracePure ("SHARED" ++ completed) (show allCount)
-            (AvarSharing sn, allCount)
+            (ScopedAcc [] (AvarSharing sn), allCount)
               -- neither shared nor free variable => leave it as it is
           | otherwise
           = tracePure ("Normal" ++ completed) (show newCount)
-            (sharingAcc, newCount)
+            (ScopedAcc [] sharingAcc, newCount)
           where
               -- Determine the bindings that need to be attached to the current node...
             (newCount, bindHere) = filterCompleted subCount
 
               -- ...and wrap them in 'AletSharing' constructors
-            lets       = foldl (flip (.)) id . map AletSharing $ bindHere
+            lets       = foldl (flip (.)) id . map (\x y -> AletSharing x (ScopedAcc [] y)) $ bindHere
             sharingAcc = lets $ AccSharing sn newAcc
 
               -- trace support
@@ -1722,23 +1841,46 @@
         --     scope errors.
         --
         filterCompleted :: NodeCounts -> (NodeCounts, [StableSharingAcc])
-        filterCompleted counts
-          = let (completed, counts') = break notComplete counts
-            in (counts', [sa | AccNodeCount sa _ <- completed])
+        filterCompleted (ns, graph)
+          = let bindable     = map (isBindable bindable (map nodeName ns)) ns
+                (bind, rest) = partition fst $ zip bindable ns
+            in ((map snd rest, graph), [sa | AccNodeCount sa _ <- map snd bind])
           where
             -- a node is not yet complete while the node count 'n' is below the overall number
             -- of occurrences for that node in the whole program, with the exception that free
             -- variables are never complete
-            notComplete nc@(AccNodeCount sa n) | not . isFreeVar $ nc = lookupWithSharingAcc accOccMap sa > n
-            notComplete _                                             = True
+            isCompleted nc@(AccNodeCount sa n) | not . isFreeVar $ nc = lookupWithSharingAcc accOccMap sa == n
+            isCompleted _                                             = False
 
-    scopesExp :: RootExp t -> (RootExp t, NodeCounts)
+            isBindable :: [Bool] -> [NodeName] -> NodeCount -> Bool
+            isBindable bindable nodes nc@(AccNodeCount _ _) =
+              let superTerms = Set.toList $ graph Map.! nodeName nc
+                  unbound    = mapMaybe (`elemIndex` nodes) superTerms
+              in    isCompleted nc
+                 && all (bindable !!) unbound
+            isBindable _ _ (ExpNodeCount _ _) = False
+
+    scopesExp :: RootExp t -> (ScopedExp t, NodeCounts)
     scopesExp = determineScopesExp config accOccMap
 
     -- The lambda bound variable is at this point already irrelevant; for details, see
     -- Note [Traversing functions and side effects]
     --
-    scopesFun1 :: Elt e1 => (Exp e1 -> RootExp e2) -> (Exp e1 -> RootExp e2, NodeCounts)
+    scopesAfun1 :: Arrays a1 => (Acc a1 -> UnscopedAcc a2) -> (Acc a1 -> ScopedAcc a2, NodeCounts)
+    scopesAfun1 f = (const (ScopedAcc ssa body'), (counts',graph))
+      where
+        body@(UnscopedAcc fvs _) = f undefined
+        ((ScopedAcc [] body'), (counts,graph)) = scopesAcc body
+        ssa     = buildInitialEnvAcc fvs [sa | AccNodeCount sa _ <- freeCounts]
+        (freeCounts, counts') = partition isBoundHere counts
+
+        isBoundHere (AccNodeCount (StableSharingAcc _ (AccSharing _ (Atag i))) _) = i `elem` fvs
+        isBoundHere _                                                             = False
+
+    -- The lambda bound variable is at this point already irrelevant; for details, see
+    -- Note [Traversing functions and side effects]
+    --
+    scopesFun1 :: Elt e1 => (Exp e1 -> RootExp e2) -> (Exp e1 -> ScopedExp e2, NodeCounts)
     scopesFun1 f = (const body, counts)
       where
         (body, counts) = scopesExp (f undefined)
@@ -1748,7 +1890,7 @@
     --
     scopesFun2 :: (Elt e1, Elt e2)
                => (Exp e1 -> Exp e2 -> RootExp e3)
-               -> (Exp e1 -> Exp e2 -> RootExp e3, NodeCounts)
+               -> (Exp e1 -> Exp e2 -> ScopedExp e3, NodeCounts)
     scopesFun2 f = (\_ _ -> body, counts)
       where
         (body, counts) = scopesExp (f undefined undefined)
@@ -1757,9 +1899,9 @@
     -- Note [Traversing functions and side effects]
     --
     scopesStencil1 :: forall sh e1 e2 stencil. Stencil sh e1 stencil
-                   => SharingAcc (Array sh e1){-dummy-}
+                   => UnscopedAcc (Array sh e1){-dummy-}
                    -> (stencil -> RootExp e2)
-                   -> (stencil -> RootExp e2, NodeCounts)
+                   -> (stencil -> ScopedExp e2, NodeCounts)
     scopesStencil1 _ stencilFun = (const body, counts)
       where
         (body, counts) = scopesExp (stencilFun undefined)
@@ -1769,10 +1911,10 @@
     --
     scopesStencil2 :: forall sh e1 e2 e3 stencil1 stencil2.
                       (Stencil sh e1 stencil1, Stencil sh e2 stencil2)
-                   => SharingAcc (Array sh e1){-dummy-}
-                   -> SharingAcc (Array sh e2){-dummy-}
+                   => UnscopedAcc (Array sh e1){-dummy-}
+                   -> UnscopedAcc (Array sh e2){-dummy-}
                    -> (stencil1 -> stencil2 -> RootExp e3)
-                   -> (stencil1 -> stencil2 -> RootExp e3, NodeCounts)
+                   -> (stencil1 -> stencil2 -> ScopedExp e3, NodeCounts)
     scopesStencil2 _ _ stencilFun = (\_ _ -> body, counts)
       where
         (body, counts) = scopesExp (stencilFun undefined undefined)
@@ -1782,63 +1924,79 @@
     :: Config
     -> OccMap Acc
     -> RootExp t
-    -> (RootExp t, NodeCounts)          -- Root (closed) expression plus Acc node counts
-determineScopesExp config accOccMap (OccMapExp fvs expOccMap exp)
+    -> (ScopedExp t, NodeCounts)          -- Root (closed) expression plus Acc node counts
+determineScopesExp config accOccMap (RootExp expOccMap exp@(UnscopedExp fvs _))
   = let
-        (expWithScopes, nodeCounts)     = determineScopesSharingExp config accOccMap expOccMap exp
+        ((ScopedExp [] expWithScopes), (nodeCounts,graph)) = determineScopesSharingExp config accOccMap expOccMap exp
         (expCounts, accCounts)          = break isAccNodeCount nodeCounts
 
         isAccNodeCount AccNodeCount{}   = True
         isAccNodeCount _                = False
     in
-    (EnvExp (buildInitialEnvExp fvs [se | ExpNodeCount se _ <- expCounts]) expWithScopes, accCounts)
-
-determineScopesExp _ _ _ = INTERNAL_ERROR(error) "determineScopesExp" "not an 'OccMapExp'"
+    (ScopedExp (buildInitialEnvExp fvs [se | ExpNodeCount se _ <- expCounts]) expWithScopes, cleanCounts (accCounts,graph))
 
 
 determineScopesSharingExp
     :: Config
     -> OccMap Acc
     -> OccMap Exp
-    -> SharingExp t
-    -> (SharingExp t, NodeCounts)
+    -> UnscopedExp t
+    -> (ScopedExp t, NodeCounts)
 determineScopesSharingExp config accOccMap expOccMap = scopesExp
   where
-    scopesAcc :: SharingAcc a -> (SharingAcc a, NodeCounts)
+    scopesAcc :: UnscopedAcc a -> (ScopedAcc a, NodeCounts)
     scopesAcc = determineScopesSharingAcc config accOccMap
 
-    scopesExp :: forall t. SharingExp t -> (SharingExp t, NodeCounts)
-    scopesExp (LetSharing _ _)
+    scopesFun1 :: (Exp a -> UnscopedExp b) -> (Exp a -> ScopedExp b, NodeCounts)
+    scopesFun1 f = tracePure ("LAMBDA " ++ (show ssa)) (show counts) (const (ScopedExp ssa body'), (counts',graph))
+      where
+        body@(UnscopedExp fvs _) = f undefined
+        ((ScopedExp [] body'), (counts, graph)) = scopesExp body
+        ssa     = buildInitialEnvExp fvs [se | ExpNodeCount se _ <- freeCounts]
+        (freeCounts, counts') = partition isBoundHere counts
+
+        isBoundHere (ExpNodeCount (StableSharingExp _ (ExpSharing _ (Tag i))) _) = i `elem` fvs
+        isBoundHere _                                                            = False
+
+
+    scopesExp :: forall t. UnscopedExp t -> (ScopedExp t, NodeCounts)
+    scopesExp (UnscopedExp _ (LetSharing _ _))
       = INTERNAL_ERROR(error) "determineScopesSharingExp: scopesExp" "unexpected 'LetSharing'"
 
-    scopesExp sharingExp@(VarSharing sn)
-      = (sharingExp, StableSharingExp sn sharingExp `expNodeCount` 1)
+    scopesExp (UnscopedExp _ (VarSharing sn))
+      = (ScopedExp [] (VarSharing sn), StableSharingExp sn (VarSharing sn) `insertExpNode` noNodeCounts)
 
-    scopesExp (ExpSharing sn pexp)
+    scopesExp (UnscopedExp _ (ExpSharing sn pexp))
       = case pexp of
-          Tag i           -> reconstruct (Tag i) noNodeCounts
-          Const c         -> reconstruct (Const c) noNodeCounts
-          Tuple tup       -> let (tup', accCount) = travTup tup
-                             in
-                             reconstruct (Tuple tup') accCount
-          Prj i e         -> travE1 (Prj i) e
-          IndexNil        -> reconstruct IndexNil noNodeCounts
-          IndexCons ix i  -> travE2 IndexCons ix i
-          IndexHead i     -> travE1 IndexHead i
-          IndexTail ix    -> travE1 IndexTail ix
-          IndexAny        -> reconstruct IndexAny noNodeCounts
-          ToIndex sh ix   -> travE2 ToIndex sh ix
-          FromIndex sh e  -> travE2 FromIndex sh e
-          Cond e1 e2 e3   -> travE3 Cond e1 e2 e3
-          PrimConst c     -> reconstruct (PrimConst c) noNodeCounts
-          PrimApp p e     -> travE1 (PrimApp p) e
-          Index a e       -> travAE Index a e
-          LinearIndex a e -> travAE LinearIndex a e
-          Shape a         -> travA Shape a
-          ShapeSize e     -> travE1 ShapeSize e
-          Foreign ff f e  -> travE1 (Foreign ff f) e
+          Tag i                 -> reconstruct (Tag i) noNodeCounts
+          Const c               -> reconstruct (Const c) noNodeCounts
+          Tuple tup             -> let (tup', accCount) = travTup tup
+                                   in
+                                   reconstruct (Tuple tup') accCount
+          Prj i e               -> travE1 (Prj i) e
+          IndexNil              -> reconstruct IndexNil noNodeCounts
+          IndexCons ix i        -> travE2 IndexCons ix i
+          IndexHead i           -> travE1 IndexHead i
+          IndexTail ix          -> travE1 IndexTail ix
+          IndexAny              -> reconstruct IndexAny noNodeCounts
+          ToIndex sh ix         -> travE2 ToIndex sh ix
+          FromIndex sh e        -> travE2 FromIndex sh e
+          Cond e1 e2 e3         -> travE3 Cond e1 e2 e3
+          While p it i          -> let
+                                     (p' , accCount1) = scopesFun1 p
+                                     (it', accCount2) = scopesFun1 it
+                                     (i' , accCount3) = scopesExp i
+                                   in reconstruct (While p' it' i') (accCount1 +++ accCount2 +++ accCount3)
+          PrimConst c           -> reconstruct (PrimConst c) noNodeCounts
+          PrimApp p e           -> travE1 (PrimApp p) e
+          Index a e             -> travAE Index a e
+          LinearIndex a e       -> travAE LinearIndex a e
+          Shape a               -> travA Shape a
+          ShapeSize e           -> travE1 ShapeSize e
+          Intersect sh1 sh2     -> travE2 Intersect sh1 sh2
+          Foreign ff f e        -> travE1 (Foreign ff f) e
       where
-        travTup :: Tuple.Tuple SharingExp tup -> (Tuple.Tuple SharingExp tup, NodeCounts)
+        travTup :: Tuple.Tuple UnscopedExp tup -> (Tuple.Tuple ScopedExp tup, NodeCounts)
         travTup NilTup          = (NilTup, noNodeCounts)
         travTup (SnocTup tup e) = let
                                     (tup', accCountT) = travTup tup
@@ -1846,64 +2004,64 @@
                                   in
                                   (SnocTup tup' e', accCountT +++ accCountE)
 
-        travE1 :: (SharingExp a -> PreExp SharingAcc SharingExp t) -> SharingExp a
-               -> (SharingExp t, NodeCounts)
+        travE1 :: (ScopedExp a -> PreExp ScopedAcc ScopedExp t) -> UnscopedExp a
+               -> (ScopedExp t, NodeCounts)
         travE1 c e = reconstruct (c e') accCount
           where
             (e', accCount) = scopesExp e
 
-        travE2 :: (SharingExp a -> SharingExp b -> PreExp SharingAcc SharingExp t)
-               -> SharingExp a
-               -> SharingExp b
-               -> (SharingExp t, NodeCounts)
+        travE2 :: (ScopedExp a -> ScopedExp b -> PreExp ScopedAcc ScopedExp t)
+               -> UnscopedExp a
+               -> UnscopedExp b
+               -> (ScopedExp t, NodeCounts)
         travE2 c e1 e2 = reconstruct (c e1' e2') (accCount1 +++ accCount2)
           where
             (e1', accCount1) = scopesExp e1
             (e2', accCount2) = scopesExp e2
 
-        travE3 :: (SharingExp a -> SharingExp b -> SharingExp c -> PreExp SharingAcc SharingExp t)
-               -> SharingExp a
-               -> SharingExp b
-               -> SharingExp c
-               -> (SharingExp t, NodeCounts)
+        travE3 :: (ScopedExp a -> ScopedExp b -> ScopedExp c -> PreExp ScopedAcc ScopedExp t)
+               -> UnscopedExp a
+               -> UnscopedExp b
+               -> UnscopedExp c
+               -> (ScopedExp t, NodeCounts)
         travE3 c e1 e2 e3 = reconstruct (c e1' e2' e3') (accCount1 +++ accCount2 +++ accCount3)
           where
             (e1', accCount1) = scopesExp e1
             (e2', accCount2) = scopesExp e2
             (e3', accCount3) = scopesExp e3
 
-        travA :: (SharingAcc a -> PreExp SharingAcc SharingExp t) -> SharingAcc a
-              -> (SharingExp t, NodeCounts)
+        travA :: (ScopedAcc a -> PreExp ScopedAcc ScopedExp t) -> UnscopedAcc a
+              -> (ScopedExp t, NodeCounts)
         travA c acc = maybeFloatOutAcc c acc' accCount
           where
             (acc', accCount)  = scopesAcc acc
 
-        travAE :: (SharingAcc a -> SharingExp b -> PreExp SharingAcc SharingExp t)
-               -> SharingAcc a
-               -> SharingExp b
-               -> (SharingExp t, NodeCounts)
+        travAE :: (ScopedAcc a -> ScopedExp b -> PreExp ScopedAcc ScopedExp t)
+               -> UnscopedAcc a
+               -> UnscopedExp b
+               -> (ScopedExp t, NodeCounts)
         travAE c acc e = maybeFloatOutAcc (`c` e') acc' (accCountA +++ accCountE)
           where
             (acc', accCountA) = scopesAcc acc
             (e'  , accCountE) = scopesExp e
 
-        maybeFloatOutAcc :: (SharingAcc a -> PreExp SharingAcc SharingExp t)
-                         -> SharingAcc a
+        maybeFloatOutAcc :: (ScopedAcc a -> PreExp ScopedAcc ScopedExp t)
+                         -> ScopedAcc a
                          -> NodeCounts
-                         -> (SharingExp t, NodeCounts)
-        maybeFloatOutAcc c acc@(AvarSharing _) accCount        -- nothing to float out
+                         -> (ScopedExp t, NodeCounts)
+        maybeFloatOutAcc c acc@(ScopedAcc _ (AvarSharing _)) accCount        -- nothing to float out
           = reconstruct (c acc) accCount
         maybeFloatOutAcc c acc                 accCount
-          | floatOutAcc config = reconstruct (c var) ((stableAcc `accNodeCount` 1) +++ accCount)
+          | floatOutAcc config = reconstruct (c var) ((stableAcc `insertAccNode` noNodeCounts) +++ accCount)
           | otherwise          = reconstruct (c acc) accCount
           where
-             (var, stableAcc) = abstract acc id
+             (var, stableAcc) = abstract acc (\(ScopedAcc _ s) -> s)
 
-        abstract :: SharingAcc a -> (SharingAcc a -> SharingAcc a)
-                 -> (SharingAcc a, StableSharingAcc)
-        abstract (AvarSharing _)       _    = INTERNAL_ERROR(error) "sharingAccToVar" "AvarSharing"
-        abstract (AletSharing sa acc)  lets = abstract acc (lets . AletSharing sa)
-        abstract acc@(AccSharing sn _) lets = (AvarSharing sn, StableSharingAcc sn (lets acc))
+        abstract :: ScopedAcc a -> (ScopedAcc a -> SharingAcc ScopedAcc ScopedExp a)
+                 -> (ScopedAcc a, StableSharingAcc)
+        abstract (ScopedAcc _ (AvarSharing _))       _      = INTERNAL_ERROR(error) "sharingAccToVar" "AvarSharing"
+        abstract (ScopedAcc ssa (AletSharing sa acc))  lets = abstract acc (lets . (\x -> ScopedAcc ssa (AletSharing sa x)))
+        abstract acc@(ScopedAcc ssa (AccSharing sn _)) lets = (ScopedAcc ssa (AvarSharing sn), StableSharingAcc sn (lets acc))
 
         -- Occurrence count of the currently processed node
         expOccCount = let StableNameHeight sn' _ = sn
@@ -1922,32 +2080,32 @@
         -- In either case, any completed 'NodeCounts' are injected as bindings using 'LetSharing'
         -- node.
         --
-        reconstruct :: PreExp SharingAcc SharingExp t -> NodeCounts
-                    -> (SharingExp t, NodeCounts)
+        reconstruct :: PreExp ScopedAcc ScopedExp t -> NodeCounts
+                    -> (ScopedExp t, NodeCounts)
         reconstruct newExp@(Tag _) _subCount
               -- free variable => replace by a sharing variable regardless of the number of
               -- occurrences
-          = let thisCount = StableSharingExp sn (ExpSharing sn newExp) `expNodeCount` 1
+          = let thisCount = StableSharingExp sn (ExpSharing sn newExp) `insertExpNode` noNodeCounts
             in
             tracePure "FREE" (show thisCount)
-            (VarSharing sn, thisCount)
+            (ScopedExp [] (VarSharing sn), thisCount)
         reconstruct newExp subCount
               -- shared subtree => replace by a sharing variable (if 'recoverExpSharing' enabled)
           | expOccCount > 1 && recoverExpSharing config
-          = let allCount = (StableSharingExp sn sharingExp `expNodeCount` 1) +++ newCount
+          = let allCount = StableSharingExp sn sharingExp `insertExpNode` newCount
             in
             tracePure ("SHARED" ++ completed) (show allCount)
-            (VarSharing sn, allCount)
+            (ScopedExp [] (VarSharing sn), allCount)
               -- neither shared nor free variable => leave it as it is
           | otherwise
           = tracePure ("Normal" ++ completed) (show newCount)
-            (sharingExp, newCount)
+            (ScopedExp [] sharingExp, newCount)
           where
               -- Determine the bindings that need to be attached to the current node...
             (newCount, bindHere) = filterCompleted subCount
 
               -- ...and wrap them in 'LetSharing' constructors
-            lets       = foldl (flip (.)) id . map LetSharing $ bindHere
+            lets       = foldl (flip (.)) id . map (\x y -> LetSharing x (ScopedExp [] y)) $ bindHere
             sharingExp = lets $ ExpSharing sn newExp
 
               -- trace support
@@ -1964,17 +2122,26 @@
         --     scope errors.
         --
         filterCompleted :: NodeCounts -> (NodeCounts, [StableSharingExp])
-        filterCompleted counts
-          = let (completed, counts') = break notComplete counts
-            in (counts', [sa | ExpNodeCount sa _ <- completed])
+        filterCompleted (ns,graph)
+          = let bindable       = map (isBindable bindable (map nodeName ns)) ns
+                (bind, unbind) = partition fst $ zip bindable ns
+            in ((map snd unbind, graph), [se | ExpNodeCount se _ <- map snd bind])
           where
             -- a node is not yet complete while the node count 'n' is below the overall number
             -- of occurrences for that node in the whole program, with the exception that free
             -- variables are never complete
-            notComplete nc@(ExpNodeCount sa n) | not . isFreeVar $ nc = lookupWithSharingExp expOccMap sa > n
-            notComplete _                                             = True
+            isCompleted nc@(ExpNodeCount sa n) | not . isFreeVar $ nc = lookupWithSharingExp expOccMap sa == n
+            isCompleted _                                             = False
 
+            isBindable :: [Bool] -> [NodeName] -> NodeCount -> Bool
+            isBindable bindable nodes nc@(ExpNodeCount _ _) =
+              let superTerms = Set.toList $ graph Map.! nodeName nc
+                  unbound    = mapMaybe (`elemIndex` nodes) superTerms
+              in    isCompleted nc
+                 && all (bindable !!) unbound
+            isBindable _ _ (AccNodeCount _ _) = False
 
+
 -- |Recover sharing information and annotate the HOAS AST with variable and let binding
 -- annotations.  The first argument determines whether array computations are floated out of
 -- expressions irrespective of whether they are shared or not — 'True' implies floating them out.
@@ -1999,7 +2166,7 @@
     -> Level            -- The level of currently bound array variables
     -> [Level]          -- The tags of newly introduced free array variables
     -> Acc a
-    -> (SharingAcc a, [StableSharingAcc])
+    -> (ScopedAcc a, [StableSharingAcc])
 {-# NOINLINE recoverSharingAcc #-}
 recoverSharingAcc config alvl avars acc
   = let (acc', occMap)
@@ -2015,7 +2182,7 @@
     -> Level            -- The level of currently bound scalar variables
     -> [Level]          -- The tags of newly introduced free scalar variables
     -> Exp e
-    -> (SharingExp e, [StableSharingExp])
+    -> (ScopedExp e, [StableSharingExp])
 {-# NOINLINE recoverSharingExp #-}
 recoverSharingExp config lvl fvar exp
   = let
@@ -2026,10 +2193,10 @@
 
           return (exp', frozenAccOccMap)
 
-        (EnvExp sse sharingExp, _) =
+        (ScopedExp sse sharingExp, _) =
           determineScopesExp config accOccMap rootExp
     in
-    (sharingExp, sse)
+    (ScopedExp [] sharingExp, sse)
 
 
 -- Debugging
@@ -2049,10 +2216,4 @@
 tracePure header msg
   = Debug.tracePure Debug.dump_sharing
   $ header ++ ": " ++ msg
-
-
-_showSharingAccOp :: SharingAcc arrs -> String
-_showSharingAccOp (AvarSharing sn)    = "AVAR " ++ show (hashStableNameHeight sn)
-_showSharingAccOp (AletSharing _ acc) = "ALET " ++ _showSharingAccOp acc
-_showSharingAccOp (AccSharing _ acc)  = showPreAccOp acc
 
diff --git a/Data/Array/Accelerate/Trafo/Shrink.hs b/Data/Array/Accelerate/Trafo/Shrink.hs
--- a/Data/Array/Accelerate/Trafo/Shrink.hs
+++ b/Data/Array/Accelerate/Trafo/Shrink.hs
@@ -40,7 +40,6 @@
 import Data.Array.Accelerate.AST
 import Data.Array.Accelerate.Tuple
 import Data.Array.Accelerate.Trafo.Base
-import Data.Array.Accelerate.Array.Sugar                ( Arrays )
 import Data.Array.Accelerate.Trafo.Substitution
 
 import qualified Data.Array.Accelerate.Debug            as Stats
@@ -109,7 +108,7 @@
       ToIndex sh ix             -> ToIndex <$> shrinkE sh <*> shrinkE ix
       FromIndex sh i            -> FromIndex <$> shrinkE sh <*> shrinkE i
       Cond p t e                -> Cond <$> shrinkE p <*> shrinkE t <*> shrinkE e
-      Iterate n f x             -> Iterate <$> shrinkE n <*> shrinkE f <*> shrinkE x
+      While p f x               -> While <$> shrinkF p <*> shrinkF f <*> shrinkE x
       PrimConst c               -> pure (PrimConst c)
       PrimApp f x               -> PrimApp f <$> shrinkE x
       Index a sh                -> Index a <$> shrinkE sh
@@ -165,6 +164,7 @@
       Apply f a                 -> Apply (shrinkAF f) (shrinkAcc a)
       Aforeign ff af a          -> Aforeign ff af (shrinkAcc a)
       Acond p t e               -> Acond (shrinkE p) (shrinkAcc t) (shrinkAcc e)
+      Awhile p f a              -> Awhile (shrinkAF p) (shrinkAF f) (shrinkAcc a)
       Use a                     -> Use a
       Unit e                    -> Unit (shrinkE e)
       Reshape e a               -> Reshape (shrinkE e) (shrinkAcc a)
@@ -206,7 +206,7 @@
       ToIndex sh ix             -> ToIndex (shrinkE sh) (shrinkE ix)
       FromIndex sh i            -> FromIndex (shrinkE sh) (shrinkE i)
       Cond p t e                -> Cond (shrinkE p) (shrinkE t) (shrinkE e)
-      Iterate n f x             -> Iterate (shrinkE n) (shrinkE f) (shrinkE x)
+      While p f x               -> While (shrinkF p) (shrinkF f) (shrinkE x)
       PrimConst c               -> PrimConst c
       PrimApp f x               -> PrimApp f (shrinkE x)
       Index a sh                -> Index (shrinkAcc a) (shrinkE sh)
@@ -242,8 +242,8 @@
     -> UsesOfAcc acc
     -> ReduceAcc acc
 basicReduceAcc unwrapAcc countAcc (unwrapAcc -> bnd) body@(unwrapAcc -> pbody)
-  | Avar _ <- bnd       = Stats.inline "Avar"  . Just $ rebuildA rebuildAcc (subTop bnd) pbody
-  | uses <= lIMIT       = Stats.betaReduce msg . Just $ rebuildA rebuildAcc (subTop bnd) pbody
+  | Avar _ <- bnd       = Stats.inline "Avar"  . Just $ rebuildA rebuildAcc (subAtop bnd) pbody
+  | uses <= lIMIT       = Stats.betaReduce msg . Just $ rebuildA rebuildAcc (subAtop bnd) pbody
   | otherwise           = Nothing
   where
     -- If the bound variable is used at most this many times, it will be inlined
@@ -258,11 +258,7 @@
       0 -> "dead acc"
       _ -> "inline acc"         -- forced inlining when lIMIT > 1
 
-    subTop :: Arrays t => PreOpenAcc acc aenv s -> Idx (aenv,s) t -> PreOpenAcc acc aenv t
-    subTop t ZeroIdx       = t
-    subTop _ (SuccIdx idx) = Avar idx
 
-
 -- Occurrence Counting
 -- ===================
 
@@ -292,7 +288,7 @@
       ToIndex sh ix             -> countE sh + countE ix
       FromIndex sh i            -> countE sh + countE i
       Cond p t e                -> countE p  + countE t `max` countE e
-      Iterate n f x             -> countE n  + countE x + usesOfExp (SuccIdx idx) f
+      While p f x               -> countE x  + countF idx p + countF idx f
       PrimConst _               -> 0
       PrimApp _ x               -> countE x
       Index _ sh                -> countE sh
@@ -302,6 +298,10 @@
       Intersect sh sz           -> countE sh + countE sz
       Foreign _ _ e             -> countE e
 
+    countF :: Idx env' s -> PreOpenFun acc env' aenv f -> Int
+    countF idx' (Lam  f) = countF (SuccIdx idx') f
+    countF idx' (Body b) = usesOfExp idx' b
+
     countT :: Tuple (PreOpenExp acc env aenv) e -> Int
     countT NilTup        = 0
     countT (SnocTup t e) = countT t + countE e
@@ -334,6 +334,7 @@
       Apply _ a                 -> countA a
       Aforeign _ _ a            -> countA a
       Acond p t e               -> countE p  + countA t `max` countA e
+      Awhile _ _ a              -> countA a
       Use _                     -> 0
       Unit e                    -> countE e
       Reshape e a               -> countE e  + countA a
@@ -378,7 +379,7 @@
       ToIndex sh ix             -> countE sh + countE ix
       FromIndex sh i            -> countE sh + countE i
       Cond p t e                -> countE p  + countE t + countE e
-      Iterate n f x             -> countE n  + countE x + countE f
+      While p f x               -> countF p  + countF f + countE x
       PrimConst _               -> 0
       PrimApp _ x               -> countE x
       Index a sh                -> countA a + countE sh
diff --git a/Data/Array/Accelerate/Trafo/Simplify.hs b/Data/Array/Accelerate/Trafo/Simplify.hs
--- a/Data/Array/Accelerate/Trafo/Simplify.hs
+++ b/Data/Array/Accelerate/Trafo/Simplify.hs
@@ -24,6 +24,7 @@
 
 -- standard library
 import Prelude                                          hiding ( exp, iterate )
+import Data.List                                        ( nubBy )
 import Data.Maybe
 import Data.Monoid
 import Data.Typeable
@@ -31,7 +32,7 @@
 
 -- friends
 import Data.Array.Accelerate.AST                        hiding ( prj )
-import Data.Array.Accelerate.Type
+-- import Data.Array.Accelerate.Type
 import Data.Array.Accelerate.Tuple
 import Data.Array.Accelerate.Analysis.Match
 import Data.Array.Accelerate.Trafo.Base
@@ -124,6 +125,9 @@
     -> PreOpenExp acc env     aenv a
     -> PreOpenExp acc (env,a) aenv b
     -> Maybe (PreOpenExp acc env aenv b)
+recoverLoops _ _ _
+  = Nothing
+{--
 recoverLoops _ bnd e3
   -- To introduce scaler loops, we look for expressions of the form:
   --
@@ -169,6 +173,7 @@
                 -> PreOpenExp acc (env,t) aenv g
                 -> Maybe (s :=: t)
     matchEnvTop _ _ = gcast REFL
+--}
 
 
 -- Walk a scalar expression applying simplifications to terms bottom-up.
@@ -210,7 +215,6 @@
       ToIndex sh ix             -> ToIndex <$> cvtE sh <*> cvtE ix
       FromIndex sh ix           -> FromIndex <$> cvtE sh <*> cvtE ix
       Cond p t e                -> cond (cvtE p) (cvtE t) (cvtE e)
-      Iterate n f x             -> Iterate <$> cvtE n <*> cvtE' (incExp env `PushExp` Var ZeroIdx) f <*> cvtE x
       PrimConst c               -> pure $ PrimConst c
       PrimApp f x               -> evalPrimApp env f <$> cvtE x
       Index a sh                -> Index a <$> cvtE sh
@@ -219,6 +223,7 @@
       ShapeSize sh              -> ShapeSize <$> cvtE sh
       Intersect s t             -> cvtE s `intersect` cvtE t
       Foreign ff f e            -> Foreign ff <$> first Any (simplifyOpenFun EmptyExp f) <*> cvtE e
+      While p f x               -> While <$> cvtF env p <*> cvtF env f <*> cvtE x
 
     cvtT :: Tuple (PreOpenExp acc env aenv) t -> (Any, Tuple (PreOpenExp acc env aenv) t)
     cvtT NilTup        = pure NilTup
@@ -227,16 +232,30 @@
     cvtE' :: Gamma acc env' env' aenv -> PreOpenExp acc env' aenv e' -> (Any, PreOpenExp acc env' aenv e')
     cvtE' env' = first Any . simplifyOpenExp env'
 
-    -- If the head terms of a shape intersection match, avoid the intersection
-    -- test and return the shape.
+    cvtF :: Gamma acc env' env' aenv -> PreOpenFun acc env' aenv f -> (Any, PreOpenFun acc env' aenv f)
+    cvtF env' = first Any . simplifyOpenFun env'
+
+    -- Return the minimal set of unique shapes to intersect. This is a bit
+    -- inefficient, but the number of shapes is expected to be small so should
+    -- be fine in practice.
     --
     intersect :: Shape t
               => (Any, PreOpenExp acc env aenv t)
               -> (Any, PreOpenExp acc env aenv t)
               -> (Any, PreOpenExp acc env aenv t)
-    intersect sh1@(_,sh1') sh2@(_,sh2')
-      | Just REFL <- match sh1' sh2' = Stats.ruleFired "intersect" (yes sh1')
-      | otherwise                    = Intersect <$> sh1 <*> sh2
+    intersect (c1, sh1) (c2, sh2)
+      | Nothing <- match sh sh' = Stats.ruleFired "intersect" (yes sh')
+      | otherwise               = (c1 <> c2, sh')
+      where
+        sh      = Intersect sh1 sh2
+        sh'     = foldl1 Intersect
+                $ nubBy (\x y -> isJust (match x y))
+                $ leaves sh1 ++ leaves sh2
+
+        leaves :: Shape t => PreOpenExp acc env aenv t -> [PreOpenExp acc env aenv t]
+        leaves (Intersect x y)  = leaves x ++ leaves y
+        leaves rest             = [rest]
+
 
     -- Simplify conditional expressions, in particular by eliminating branches
     -- when the predicate is a known constant.
diff --git a/Data/Array/Accelerate/Trafo/Substitution.hs b/Data/Array/Accelerate/Trafo/Substitution.hs
--- a/Data/Array/Accelerate/Trafo/Substitution.hs
+++ b/Data/Array/Accelerate/Trafo/Substitution.hs
@@ -18,6 +18,7 @@
 
   -- ** Renaming & Substitution
   inline, substitute, compose,
+  subTop, subAtop,
 
   -- ** Weakening
   (:>),
@@ -76,10 +77,6 @@
        -> PreOpenExp acc env      aenv s
        -> PreOpenExp acc env      aenv t
 inline f g = Stats.substitution "inline" $ rebuildE (subTop g) f
-  where
-    subTop :: Elt t => PreOpenExp acc env aenv s -> Idx (env, s) t -> PreOpenExp acc env aenv t
-    subTop s ZeroIdx      = s
-    subTop _ (SuccIdx ix) = Var ix
 
 -- | Replace an expression that uses the top environment variable with another.
 -- The result of the first is let bound into the second.
@@ -109,6 +106,15 @@
 compose _              _              = error "compose: impossible evaluation"
 
 
+subTop :: Elt t => PreOpenExp acc env aenv s -> Idx (env, s) t -> PreOpenExp acc env aenv t
+subTop s ZeroIdx      = s
+subTop _ (SuccIdx ix) = Var ix
+
+subAtop :: Arrays t => PreOpenAcc acc aenv s -> Idx (aenv, s) t -> PreOpenAcc acc aenv t
+subAtop t ZeroIdx       = t
+subAtop _ (SuccIdx idx) = Avar idx
+
+
 -- NOTE: [Weakening]
 --
 -- Weakening is something we usually take for granted: every time you learn a
@@ -218,7 +224,7 @@
     ToIndex sh ix       -> ToIndex (rebuildE v sh) (rebuildE v ix)
     FromIndex sh ix     -> FromIndex (rebuildE v sh) (rebuildE v ix)
     Cond p t e          -> Cond (rebuildE v p) (rebuildE v t) (rebuildE v e)
-    Iterate n f x       -> Iterate (rebuildE v n) (rebuildE (shiftE v) f) (rebuildE v x)
+    While p f x         -> While (rebuildFE v p) (rebuildFE v f) (rebuildE v x)
     PrimConst c         -> PrimConst c
     PrimApp f x         -> PrimApp f (rebuildE v x)
     Index a sh          -> Index a (rebuildE v sh)
@@ -308,6 +314,7 @@
     Apply f a           -> Apply (rebuildAfun rebuild v f) (rebuild v a)
     Aforeign ff afun as -> Aforeign ff afun (rebuild v as)
     Acond p t e         -> Acond (rebuildEA rebuild v p) (rebuild v t) (rebuild v e)
+    Awhile p f a        -> Awhile (rebuildAfun rebuild v p) (rebuildAfun rebuild v f) (rebuild v a)
     Use a               -> Use a
     Unit e              -> Unit (rebuildEA rebuild v e)
     Reshape e a         -> Reshape (rebuildEA rebuild v e) (rebuild v a)
@@ -386,7 +393,7 @@
     ToIndex sh ix       -> ToIndex (rebuildEA k v sh) (rebuildEA k v ix)
     FromIndex sh ix     -> FromIndex (rebuildEA k v sh) (rebuildEA k v ix)
     Cond p t e          -> Cond (rebuildEA k v p) (rebuildEA k v t) (rebuildEA k v e)
-    Iterate n f x       -> Iterate (rebuildEA k v n) (rebuildEA k v f) (rebuildEA k v x)
+    While p f x         -> While (rebuildFA k v p) (rebuildFA k v f) (rebuildEA k v x)
     PrimConst c         -> PrimConst c
     PrimApp f x         -> PrimApp f (rebuildEA k v x)
     Index a sh          -> Index (k v a) (rebuildEA k v sh)
diff --git a/Data/Array/Accelerate/Tuple.hs b/Data/Array/Accelerate/Tuple.hs
--- a/Data/Array/Accelerate/Tuple.hs
+++ b/Data/Array/Accelerate/Tuple.hs
@@ -1,4 +1,6 @@
-{-# LANGUAGE GADTs, TypeFamilies, FlexibleInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs             #-}
+{-# LANGUAGE TypeFamilies      #-}
 {-# OPTIONS_HADDOCK hide #-}
 -- |
 -- Module      : Data.Array.Accelerate.Tuple
diff --git a/Data/Array/Accelerate/Type.hs b/Data/Array/Accelerate/Type.hs
--- a/Data/Array/Accelerate/Type.hs
+++ b/Data/Array/Accelerate/Type.hs
@@ -1,4 +1,7 @@
-{-# LANGUAGE CPP, TypeOperators, GADTs, TypeFamilies, FlexibleInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs             #-}
+{-# LANGUAGE TypeFamilies      #-}
+{-# LANGUAGE TypeOperators     #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# OPTIONS_HADDOCK hide #-}
 -- |
@@ -48,11 +51,7 @@
 -- ------------------------------------------
 
 myMkTyCon :: String -> TyCon
-#if __GLASGOW_HASKELL__ == 700
-myMkTyCon = mkTyCon
-#else
 myMkTyCon = mkTyCon3 "accelerate" "Data.Array.Accelerate.Type"
-#endif
 
 class Typeable8 t where
   typeOf8 :: t a b c d e f g h -> TypeRep
@@ -61,7 +60,7 @@
   typeOf8 _ = myMkTyCon "(,,,,,,,)" `mkTyConApp` []
 
 typeOf7Default :: (Typeable8 t, Typeable a) => t a b c d e f g h -> TypeRep
-typeOf7Default x = typeOf7 x `mkAppTy` typeOf (argType x)
+typeOf7Default x = typeOf8 x `mkAppTy` typeOf (argType x)
  where
    argType :: t a b c d e f g h -> a
    argType =  undefined
@@ -77,7 +76,7 @@
   typeOf9 _ = myMkTyCon "(,,,,,,,,)" `mkTyConApp` []
 
 typeOf8Default :: (Typeable9 t, Typeable a) => t a b c d e f g h i -> TypeRep
-typeOf8Default x = typeOf8 x `mkAppTy` typeOf (argType x)
+typeOf8Default x = typeOf9 x `mkAppTy` typeOf (argType x)
  where
    argType :: t a b c d e f g h i -> a
    argType =  undefined
diff --git a/accelerate.cabal b/accelerate.cabal
--- a/accelerate.cabal
+++ b/accelerate.cabal
@@ -1,7 +1,7 @@
 Name:                   accelerate
-Version:                0.13.0.5
+Version:                0.14.0.0
 Cabal-version:          >= 1.6
-Tested-with:            GHC >= 7.4.2
+Tested-with:            GHC == 7.6.*
 Build-type:             Custom
 
 Synopsis:               An embedded language for accelerated array processing
@@ -98,6 +98,9 @@
   .
   [/Release notes/]
   .
+    * /0.14.0.0:/ New iteration constructs. Additional Prelude-like functions.
+      Improved code generation and fusion optimisation. Bug fixes.
+  .
     * /0.13.0.0:/ New array fusion optimisation. New foreign function
       interface for array and scalar expressions. Additional Prelude-like
       functions. New example programs. Bug fixes and performance improvements.
@@ -128,6 +131,15 @@
   .
     * /0.7.1.0:/ The CUDA backend and a number of scalar functions.
   .
+  [/Hackage note/]
+  .
+  The module documentation list generated by Hackage is incorrect. The only
+  exposed modules should be:
+  .
+    * "Data.Array.Accelerate"
+  .
+    * "Data.Array.Accelerate.Interpreter"
+  .
 
 License:                BSD3
 License-file:           LICENSE
@@ -189,24 +201,25 @@
 
 Library
   Include-Dirs:         include
-  Build-depends:        base            == 4.*,
-                        ghc-prim,
-                        array           >= 0.3  && < 0.5,
-                        containers      >= 0.3  && < 0.6,
-                        fclabels        >= 1.0  && < 1.2,
-                        hashable        >= 1.1  && < 1.3,
-                        hashtables      >= 1.0  && < 1.2,
-                        pretty          >= 1.0  && < 1.2
+  Build-depends:        array                >= 0.3,
+                        base                 == 4.6.*,
+                        containers           >= 0.3,
+                        unordered-containers >= 0.2     && < 0.3,
+                        fclabels             >= 2.0     && < 2.1,
+                        ghc-prim             >= 0.2,
+                        hashable             >= 1.1     && < 1.3,
+                        hashtables           >= 1.0     && < 1.2,
+                        pretty               >= 1.0
 
   if flag(more-pp)
-    Build-depends:      bytestring      >= 0.9  && < 0.11,
-                        blaze-html      >= 0.5  && < 0.7,
-                        blaze-markup    >= 0.5  && < 0.6,
-                        directory       >= 1.0  && < 1.3,
-                        filepath        >= 1.0  && < 1.4,
-                        mtl             >= 2.0  && < 2.2,
-                        text            >= 0.10 && < 0.12,
-                        unix            >= 2.4  && < 2.7
+    Build-depends:      bytestring           >= 0.9,
+                        blaze-html           >= 0.5,
+                        blaze-markup         >= 0.5,
+                        directory            >= 1.0,
+                        filepath             >= 1.0,
+                        mtl                  >= 2.0,
+                        text                 >= 0.10,
+                        unix                 >= 2.4
 
   Exposed-modules:      Data.Array.Accelerate
                         Data.Array.Accelerate.AST