[project @ 2002-02-11 08:20:38 by chak]

*******************************
		       * Merging from ghc-ndp-branch *
		       *******************************

This commit merges the current state of the "parallel array extension" and
includes the following:

* (Almost) completed Milestone 1:
  - The option `-fparr' activates the H98 extension for parallel arrays.
  - These changes have a high likelihood of conflicting (in the CVS sense)
    with other changes to GHC and are the reason for merging now.
  - ToDo: There are still some (less often used) functions not implemented in
	  `PrelPArr' and a mechanism is needed to automatically import
	  `PrelPArr' iff `-fparr' is given.  Documentation that should go into
	  the Commentary is currently in `ghc/compiler/ndpFlatten/TODO'.

* Partial Milestone 2:
  - The option `-fflatten' activates the flattening transformation and `-ndp'
    selects the "ndp" way (where all libraries have to be compiled with
    flattening).  The way option `-ndp' automagically turns on `-fparr' and
    `-fflatten'.
  - Almost all changes are in the new directory `ndpFlatten' and shouldn't
    affect the rest of the compiler.  The only exception are the options and
    the points in `HscMain' where the flattening phase is called when
    `-fflatten' is given.
  - This isn't usable yet, but already implements function lifting,
    vectorisation, and a new analysis that determines which parts of a module
    have to undergo the flattening transformation.  Missing are data structure
    and function specialisation, the unboxed array library (including fusion
    rules), and lots of testing.

I have just run the regression tests on the thing without any problems.  So,
it seems, as if we haven't broken anything crucial.

5 files changed, 324 insertions, 34 deletions

diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs
index 17e0e52dff..d445834451 100644
--- a/ghc/compiler/deSugar/Check.lhs
+++ b/ghc/compiler/deSugar/Check.lhs
@@ -142,6 +142,8 @@ untidy b (ConPatIn name pats)  =
 untidy b (ConOpPatIn pat1 name fixity pat2) = 
        pars b (ConOpPatIn (untidy_pars pat1) name fixity (untidy_pars pat2)) 
 untidy _ (ListPatIn pats)  = ListPatIn (map untidy_no_pars pats) 
+untidy _ (PArrPatIn pats)  = 
+       panic "Check.untidy: Shouldn't get a parallel array here!"
 untidy _ (TuplePatIn pats boxed) = TuplePatIn (map untidy_no_pars pats) boxed
 
 untidy _ pat = pprPanic "Check.untidy: SigPatIn" (ppr pat)
@@ -523,12 +525,26 @@ make_con (ConPat id _ _ _ _) (p:q:ps, constraints)
     where name   = getName id
           fixity = panic "Check.make_con: Guessing fixity"
 
-make_con (ConPat id _ _ _ pats) (ps,constraints) 
+make_con (ConPat id _ _ _ pats) (ps, constraints) 
       | isTupleTyCon tc = (TuplePatIn pats_con (tupleTyConBoxity tc) : rest_pats, constraints) 
       | otherwise       = (ConPatIn name pats_con		     : rest_pats, constraints)
     where name      = getName id
 	  (pats_con, rest_pats) = splitAtList pats ps
 	  tc	    = dataConTyCon id
+
+-- reconstruct parallel array pattern
+--
+-- * don't check for the type only; we need to make sure that we are really
+--   dealing with one of the fake constructors and not with the real
+--   representation 
+--
+make_con (ConPat id _ _ _ pats) (ps, constraints) 
+  | isPArrFakeCon id = (PArrPatIn patsCon     : restPats, constraints) 
+  | otherwise        = (ConPatIn name patsCon : restPats, constraints)
+  where 
+    name                = getName id
+    (patsCon, restPats) = splitAtList pats ps
+    tc	                = dataConTyCon id
 	  
 
 make_whole_con :: DataCon -> WarningPat
@@ -575,6 +591,13 @@ simplify_pat (ListPat ty ps) = foldr (\ x -> \y -> ConPat consDataCon list_ty []
 	                             (map simplify_pat ps)
                              where list_ty = mkListTy ty
 
+-- introduce fake parallel array constructors to be able to handle parallel
+-- arrays with the existing machinery for constructor pattern
+--
+simplify_pat (PArrPat ty ps)
+  = ConPat (parrFakeCon arity) (mkPArrTy ty) [] [] (map simplify_pat ps)
+  where
+    arity = length ps
 
 simplify_pat (TuplePat ps boxity)
   = ConPat (tupleCon boxity arity)
diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index 162ae247c7..5d7ff191df 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -32,7 +32,7 @@ import DsMonad
 import DsBinds		( dsMonoBinds, AutoScc(..) )
 import DsGRHSs		( dsGuarded )
 import DsCCall		( dsCCall, resultWrapper )
-import DsListComp	( dsListComp )
+import DsListComp	( dsListComp, dsPArrComp )
 import DsUtils		( mkErrorAppDs, mkStringLit, mkStringLitFS, 
 			  mkConsExpr, mkNilExpr, mkIntegerLit
 			)
@@ -49,7 +49,7 @@ import TyCon		( tyConDataCons )
 import TysWiredIn	( tupleCon, listTyCon, charDataCon, intDataCon )
 import BasicTypes	( RecFlag(..), Boxity(..), ipNameName )
 import Maybes		( maybeToBool )
-import PrelNames	( hasKey, ratioTyConKey )
+import PrelNames	( hasKey, ratioTyConKey, toPName )
 import Util		( zipEqual, zipWithEqual )
 import Outputable
 
@@ -262,27 +262,26 @@ dsExpr (HsWith expr binds)
         = dsExpr e	`thenDs` \ e' ->
 	  returnDs (Let (NonRec (ipNameName n) e') body)
 
-dsExpr (HsDoOut do_or_lc stmts return_id then_id fail_id result_ty src_loc)
-  | maybeToBool maybe_list_comp
+-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
+-- because the interpretation of `stmts' depends on what sort of thing it is.
+--
+dsExpr (HsDoOut ListComp stmts return_id then_id fail_id result_ty src_loc)
   =	-- Special case for list comprehensions
     putSrcLocDs src_loc $
     dsListComp stmts elt_ty
+  where
+    (_, [elt_ty]) = tcSplitTyConApp result_ty
 
-  | otherwise
+dsExpr (HsDoOut DoExpr   stmts return_id then_id fail_id result_ty src_loc)
   = putSrcLocDs src_loc $
-    dsDo do_or_lc stmts return_id then_id fail_id result_ty
+    dsDo DoExpr stmts return_id then_id fail_id result_ty
+
+dsExpr (HsDoOut PArrComp stmts return_id then_id fail_id result_ty src_loc)
+  =	-- Special case for array comprehensions
+    putSrcLocDs src_loc $
+    dsPArrComp stmts elt_ty
   where
-    maybe_list_comp 
-	= case (do_or_lc, tcSplitTyConApp_maybe result_ty) of
-	    (ListComp, Just (tycon, [elt_ty]))
-		  | tycon == listTyCon
-		 -> Just elt_ty
-	    other -> Nothing
-	-- We need the ListComp form to use deListComp (rather than the "do" form)
-	-- because the interpretation of ExprStmt depends on what sort of thing
-	-- it is.
-
-    Just elt_ty = maybe_list_comp
+    (_, [elt_ty]) = tcSplitTyConApp result_ty
 
 dsExpr (HsIf guard_expr then_expr else_expr src_loc)
   = putSrcLocDs src_loc $
@@ -319,6 +318,21 @@ dsExpr (ExplicitList ty xs)
 		go xs					`thenDs` \ core_xs ->
 		returnDs (mkConsExpr ty core_x core_xs)
 
+-- we create a list from the array elements and convert them into a list using
+-- `PrelPArr.toP'
+--
+-- * the main disadvantage to this scheme is that `toP' traverses the list
+--   twice: once to determine the length and a second time to put to elements
+--   into the array; this inefficiency could be avoided by exposing some of
+--   the innards of `PrelPArr' to the compiler (ie, have a `PrelPArrBase') so
+--   that we can exploit the fact that we already know the length of the array
+--   here at compile time
+--
+dsExpr (ExplicitPArr ty xs)
+  = dsLookupGlobalValue toPName				`thenDs` \toP      ->
+    dsExpr (ExplicitList ty xs)				`thenDs` \coreList ->
+    returnDs (mkApps (Var toP) [Type ty, coreList])
+
 dsExpr (ExplicitTuple expr_list boxity)
   = mapDs dsExpr expr_list	  `thenDs` \ core_exprs  ->
     returnDs (mkConApp (tupleCon boxity (length expr_list))
@@ -347,6 +361,24 @@ dsExpr (ArithSeqOut expr (FromThenTo from thn two))
     dsExpr thn		  `thenDs` \ thn2 ->
     dsExpr two		  `thenDs` \ two2 ->
     returnDs (mkApps expr2 [from2, thn2, two2])
+
+dsExpr (PArrSeqOut expr (FromTo from two))
+  = dsExpr expr		  `thenDs` \ expr2 ->
+    dsExpr from		  `thenDs` \ from2 ->
+    dsExpr two		  `thenDs` \ two2 ->
+    returnDs (mkApps expr2 [from2, two2])
+
+dsExpr (PArrSeqOut expr (FromThenTo from thn two))
+  = dsExpr expr		  `thenDs` \ expr2 ->
+    dsExpr from		  `thenDs` \ from2 ->
+    dsExpr thn		  `thenDs` \ thn2 ->
+    dsExpr two		  `thenDs` \ two2 ->
+    returnDs (mkApps expr2 [from2, thn2, two2])
+
+dsExpr (PArrSeqOut expr _)
+  = panic "DsExpr.dsExpr: Infinite parallel array!"
+    -- the parser shouldn't have generated it and the renamer and typechecker
+    -- shouldn't have let it through
 \end{code}
 
 \noindent
@@ -512,6 +544,7 @@ dsExpr (DictApp expr dicts)	-- becomes a curried application
 dsExpr (HsDo _ _ _)	    = panic "dsExpr:HsDo"
 dsExpr (ExprWithTySig _ _)  = panic "dsExpr:ExprWithTySig"
 dsExpr (ArithSeqIn _)	    = panic "dsExpr:ArithSeqIn"
+dsExpr (PArrSeqIn _)	    = panic "dsExpr:PArrSeqIn"
 #endif
 
 \end{code}
@@ -534,7 +567,7 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty
 	(_, b_ty) = tcSplitAppTy result_ty	-- result_ty must be of the form (m b)
 	is_do	  = case do_or_lc of
 			DoExpr   -> True
-			ListComp -> False
+			_	 -> False
 	
 	-- For ExprStmt, see the comments near HsExpr.Stmt about 
 	-- exactly what ExprStmts mean!
diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs
index ebe08c6189..99b8980f26 100644
--- a/ghc/compiler/deSugar/DsListComp.lhs
+++ b/ghc/compiler/deSugar/DsListComp.lhs
@@ -1,18 +1,23 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-\section[DsListComp]{Desugaring list comprehensions}
+\section[DsListComp]{Desugaring list comprehensions and array comprehensions}
 
 \begin{code}
-module DsListComp ( dsListComp ) where
+module DsListComp ( dsListComp, dsPArrComp ) where
 
 #include "HsVersions.h"
 
 import {-# SOURCE #-} DsExpr ( dsExpr, dsLet )
 
 import BasicTypes	( Boxity(..) )
-import HsSyn		( OutPat(..), HsExpr(..), Stmt(..), HsMatchContext(..), HsDoContext(..) )
-import TcHsSyn		( TypecheckedStmt, TypecheckedPat, TypecheckedHsExpr, outPatType )
+import DataCon		( dataConId )
+import TyCon		( tyConName )
+import HsSyn		( OutPat(..), HsExpr(..), Stmt(..),
+			  HsMatchContext(..), HsDoContext(..),
+			  collectHsOutBinders )
+import TcHsSyn		( TypecheckedStmt, TypecheckedPat, TypecheckedHsExpr,
+			  outPatType )
 import CoreSyn
 
 import DsMonad		-- the monadery used in the desugarer
@@ -22,12 +27,18 @@ import CmdLineOpts	( opt_FoldrBuildOn )
 import CoreUtils	( exprType, mkIfThenElse )
 import Id		( idType )
 import Var              ( Id )
-import Type		( mkTyVarTy, mkFunTys, mkFunTy, Type )
+import Type		( mkTyVarTy, mkFunTys, mkFunTy, Type,
+			  splitTyConApp_maybe )
 import TysPrim		( alphaTyVar )
-import TysWiredIn	( nilDataCon, consDataCon, unitDataConId, mkListTy, mkTupleTy )
+import TysWiredIn	( nilDataCon, consDataCon, unitDataConId, unitTy,
+			  mkListTy, mkTupleTy, intDataCon )
 import Match		( matchSimply )
-import PrelNames	( foldrName, buildName )
+import PrelNames	( trueDataConName, falseDataConName, foldrName,
+			  buildName, replicatePName, mapPName, filterPName,
+			  zipPName, crossPName, parrTyConName ) 
+import PrelInfo		( pAT_ERROR_ID )
 import SrcLoc		( noSrcLoc )
+import Panic		( panic )
 \end{code}
 
 List comprehensions may be desugared in one of two ways: ``ordinary''
@@ -319,4 +330,146 @@ dfListComp c_id n_id (BindStmt pat list1 locn : quals)
     )
 \end{code}
 
+%************************************************************************
+%*									*
+\subsection[DsPArrComp]{Desugaring of array comprehensions}
+%*									*
+%************************************************************************
+
+\begin{code}
+
+-- entry point for desugaring a parallel array comprehension
+--
+--   [:e | qss:] = <<[:e | qss:]>> () [:():]
+--
+dsPArrComp      :: [TypecheckedStmt] 
+	        -> Type		    -- Don't use; called with `undefined' below
+	        -> DsM CoreExpr
+dsPArrComp qs _  =
+  dsLookupGlobalValue replicatePName			  `thenDs` \repP ->
+  let unitArray = mkApps (Var repP) [Type unitTy, 
+				     mkConApp intDataCon [mkIntLit 1], 
+				     mkTupleExpr []]
+  in
+  dePArrComp qs (TuplePat [] Boxed) unitArray
 
+-- the work horse
+--
+dePArrComp :: [TypecheckedStmt] 
+	   -> TypecheckedPat		-- the current generator pattern
+	   -> CoreExpr			-- the current generator expression
+	   -> DsM CoreExpr
+--
+--  <<[:e' | :]>> pa ea = mapP (\pa -> e') ea
+--
+dePArrComp [ResultStmt e' _] pa cea =
+  dsLookupGlobalValue mapPName				  `thenDs` \mapP    ->
+  let ty = parrElemType cea
+  in
+  deLambda ty pa e'					  `thenDs` \(clam, 
+								     ty'e') ->
+  returnDs $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea]
+--
+--  <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
+--
+dePArrComp (ExprStmt b _ _ : qs) pa cea =
+  dsLookupGlobalValue filterPName			  `thenDs` \filterP  ->
+  let ty = parrElemType cea
+  in
+  deLambda ty pa b					  `thenDs` \(clam,_) ->
+  dePArrComp qs pa (mkApps (Var filterP) [Type ty, clam, cea])
+--
+--  <<[:e' | p <- e, qs:]>> pa ea = 
+--    let ef = filterP (\x -> case x of {p -> True; _ -> False}) e
+--    in
+--    <<[:e' | qs:]>> (pa, p) (crossP ea ef)
+--
+dePArrComp (BindStmt p e _ : qs) pa cea =
+  dsLookupGlobalValue falseDataConName			  `thenDs` \falseId ->
+  dsLookupGlobalValue trueDataConName			  `thenDs` \trueId ->
+  dsLookupGlobalValue filterPName			  `thenDs` \filterP ->
+  dsLookupGlobalValue crossPName			  `thenDs` \crossP  ->
+  dsExpr e						  `thenDs` \ce      ->
+  let ty'cea = parrElemType cea
+      ty'ce  = parrElemType ce
+      false  = Var falseId
+      true   = Var trueId
+  in
+  newSysLocalDs ty'ce					  `thenDs` \v       ->
+  matchSimply (Var v) (DoCtxt PArrComp) p true false      `thenDs` \pred    ->
+  let cef    = mkApps (Var filterP) [Type ty'ce, mkLams [v] pred, ce]
+      ty'cef = ty'ce				-- filterP preserves the type
+      pa'    = TuplePat [pa, p] Boxed
+  in
+  dePArrComp qs pa' (mkApps (Var crossP) [Type ty'cea, Type ty'cef, cea, cef])
+--
+--  <<[:e' | let ds, qs:]>> pa ea = 
+--    <<[:e' | qs:]>> (pa, (x_1, ..., x_n)) 
+--		      (mapP (\v@pa -> (v, let ds in (x_1, ..., x_n))) ea)
+--  where
+--    {x_1, ..., x_n} = DV (ds)		-- Defined Variables
+--
+dePArrComp (LetStmt ds : qs) pa cea =
+  dsLookupGlobalValue mapPName				  `thenDs` \mapP    ->
+  let xs     = collectHsOutBinders ds
+      ty'cea = parrElemType cea
+  in
+  newSysLocalDs ty'cea					  `thenDs` \v       ->
+  dsLet ds (mkTupleExpr xs)				  `thenDs` \clet    ->
+  newSysLocalDs (exprType clet)				  `thenDs` \let'v   ->
+  let projBody = mkDsLet (NonRec let'v clet) $ mkTupleExpr [v, let'v]
+      errTy    = exprType projBody
+      errMsg   = "DsListComp.dePArrComp: internal error!"
+  in
+  mkErrorAppDs pAT_ERROR_ID errTy errMsg                  `thenDs` \cerr    ->
+  matchSimply (Var v) (DoCtxt PArrComp) pa projBody cerr  `thenDs` \ccase   ->
+  let pa'    = TuplePat [pa, TuplePat (map VarPat xs) Boxed] Boxed
+      proj   = mkLams [v] ccase
+  in
+  dePArrComp qs pa' (mkApps (Var mapP) [Type ty'cea, proj, cea])
+--
+--  <<[:e' | qs | qss:]>> pa ea = 
+--    <<[:e' | qss:]>> (pa, (x_1, ..., x_n)) 
+--		       (zipP ea <<[:(x_1, ..., x_n) | qs:]>>)
+--    where
+--      {x_1, ..., x_n} = DV (qs)
+--
+dePArrComp (ParStmtOut []             : qss2) pa cea = dePArrComp qss2 pa cea
+dePArrComp (ParStmtOut ((xs, qs):qss) : qss2) pa cea =
+  dsLookupGlobalValue zipPName				  `thenDs` \zipP    ->
+  let pa'     = TuplePat [pa, TuplePat (map VarPat xs) Boxed] Boxed
+      ty'cea  = parrElemType cea
+      resStmt = ResultStmt (ExplicitTuple (map HsVar xs) Boxed) noSrcLoc
+  in
+  dsPArrComp (qs ++ [resStmt]) undefined		  `thenDs` \cqs     ->
+  let ty'cqs = parrElemType cqs
+      cea'   = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
+  in
+  dePArrComp (ParStmtOut qss : qss2) pa' cea'
+
+-- generate Core corresponding to `\p -> e'
+--
+deLambda        :: Type			-- type of the argument
+		-> TypecheckedPat	-- argument pattern
+		-> TypecheckedHsExpr	-- body
+		-> DsM (CoreExpr, Type)
+deLambda ty p e  =
+  newSysLocalDs ty					  `thenDs` \v       ->
+  dsExpr e						  `thenDs` \ce      ->
+  let errTy    = exprType ce
+      errMsg   = "DsListComp.deLambda: internal error!"
+  in
+  mkErrorAppDs pAT_ERROR_ID errTy errMsg                  `thenDs` \cerr    ->
+  matchSimply (Var v) (DoCtxt PArrComp) p ce cerr	  `thenDs` \res	    ->
+  returnDs (mkLams [v] res, errTy)
+
+-- obtain the element type of the parallel array produced by the given Core
+-- expression
+--
+parrElemType   :: CoreExpr -> Type
+parrElemType e  = 
+  case splitTyConApp_maybe (exprType e) of
+    Just (tycon, [ty]) | tyConName tycon == parrTyConName -> ty
+    _							  -> panic
+      "DsListComp.parrElemType: not a parallel array type"
+\end{code}
diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 6b45c58108..9bb99a65c5 100644
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -44,23 +44,24 @@ import MkId		( rebuildConArgs )
 import Id		( idType, Id, mkWildId )
 import Literal		( Literal(..), inIntRange, tARGET_MAX_INT )
 import TyCon		( isNewTyCon, tyConDataCons, isRecursiveTyCon )
-import DataCon		( DataCon, dataConStrictMarks, dataConId )
-import Type		( mkFunTy, isUnLiftedType, Type )
+import DataCon		( DataCon, dataConStrictMarks, dataConId,
+			  dataConSourceArity )
+import Type		( mkFunTy, isUnLiftedType, Type, splitTyConApp )
 import TcType		( tcTyConAppTyCon, isIntTy, isFloatTy, isDoubleTy )
 import TysPrim		( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy )
 import TysWiredIn	( nilDataCon, consDataCon, 
                           tupleCon,
 			  unitDataConId, unitTy,
                           charTy, charDataCon, 
-                          intDataCon, smallIntegerDataCon, 
+                          intTy, intDataCon, smallIntegerDataCon, 
 			  floatDataCon, 
                           doubleDataCon,
-			  stringTy
-			)
+			  stringTy, isPArrFakeCon )
 import BasicTypes	( Boxity(..) )
 import UniqSet		( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet )
 import PrelNames	( unpackCStringName, unpackCStringUtf8Name, 
-			  plusIntegerName, timesIntegerName )
+			  plusIntegerName, timesIntegerName, 
+			  lengthPName, indexPName )
 import Outputable
 import UnicodeUtil      ( stringToUtf8 )
 import Util             ( isSingleton )
@@ -265,6 +266,9 @@ mkCoAlgCaseMatchResult var match_alts
   = ASSERT( null (tail match_alts) && null (tail arg_ids) )
     mkCoLetsMatchResult [NonRec arg_id newtype_rhs] match_result
 
+  | isPArrFakeAlts match_alts	-- Sugared parallel array; use a literal case 
+  = MatchResult CanFail mk_parrCase
+
   | otherwise			-- Datatype case; use a case
   = MatchResult fail_flag mk_case
   where
@@ -309,6 +313,72 @@ mkCoAlgCaseMatchResult var match_alts
     un_mentioned_constructors
         = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts]
     exhaustive_case = isEmptyUniqSet un_mentioned_constructors
+
+	-- Stuff for parallel arrays
+	-- 
+	-- * the following is to desugar cases over fake constructors for
+	--   parallel arrays, which are introduced by `tidy1' in the `PArrPat'
+	--   case
+	--
+	-- Concerning `isPArrFakeAlts':
+	--
+	-- * it is *not* sufficient to just check the type of the type
+	--   constructor, as we have to be careful not to confuse the real
+	--   representation of parallel arrays with the fake constructors;
+	--   moreover, a list of alternatives must not mix fake and real
+	--   constructors (this is checked earlier on)
+	--
+	-- FIXME: We actually go through the whole list and make sure that
+	--	  either all or none of the constructors are fake parallel
+	--	  array constructors.  This is to spot equations that mix fake
+	--	  constructors with the real representation defined in
+	--	  `PrelPArr'.  It would be nicer to spot this situation
+	--	  earlier and raise a proper error message, but it can really
+	--	  only happen in `PrelPArr' anyway.
+	--
+    isPArrFakeAlts [(dcon, _, _)]      = isPArrFakeCon dcon
+    isPArrFakeAlts ((dcon, _, _):alts) = 
+      case (isPArrFakeCon dcon, isPArrFakeAlts alts) of
+        (True , True ) -> True
+        (False, False) -> False
+	_	       -> 
+	  panic "DsUtils: You may not mix `[:...:]' with `PArr' patterns"
+    --
+    mk_parrCase fail = 		   
+      dsLookupGlobalValue lengthPName			`thenDs` \lengthP  ->
+      unboxAlt						`thenDs` \alt      ->
+      returnDs (Case (len lengthP) (mkWildId intTy) [alt])
+      where
+	elemTy      = case splitTyConApp (idType var) of
+		        (_, [elemTy]) -> elemTy
+		        _	        -> panic panicMsg
+        panicMsg    = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"
+	len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]
+	--
+	unboxAlt = 
+	  newSysLocalDs intPrimTy			`thenDs` \l	   ->
+	  dsLookupGlobalValue indexPName		`thenDs` \indexP   ->
+	  mapDs (mkAlt indexP) match_alts               `thenDs` \alts     ->
+	  returnDs (DataAlt intDataCon, [l], (Case (Var l) wild (dft : alts)))
+          where
+	    wild = mkWildId intPrimTy
+	    dft  = (DEFAULT, [], fail)
+	--
+	-- each alternative matches one array length (corresponding to one
+	-- fake array constructor), so the match is on a literal; each
+	-- alternative's body is extended by a local binding for each
+	-- constructor argument, which are bound to array elements starting
+	-- with the first
+	--
+	mkAlt indexP (con, args, MatchResult _ bodyFun) = 
+	  bodyFun fail					`thenDs` \body     ->
+	  returnDs (LitAlt lit, [], mkDsLets binds body)
+	  where
+	    lit   = MachInt $ toInteger (dataConSourceArity con)
+	    binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args]
+	    --
+	    indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, toInt i]
+	    toInt     i = mkConApp intDataCon [Lit $ MachInt i]
 \end{code}
 
 
diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index 74be345ca1..1f9fcdadf2 100644
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -24,7 +24,8 @@ import MatchCon		( matchConFamily )
 import MatchLit		( matchLiterals )
 import PrelInfo		( pAT_ERROR_ID )
 import TcType		( mkTyVarTys, Type, tcTyConAppArgs, tcEqType )
-import TysWiredIn	( nilDataCon, consDataCon, mkTupleTy, mkListTy, tupleCon )
+import TysWiredIn	( nilDataCon, consDataCon, mkTupleTy, mkListTy,
+			  tupleCon, parrFakeCon, mkPArrTy )
 import BasicTypes	( Boxity(..) )
 import UniqSet
 import ErrUtils		( addWarnLocHdrLine, dontAddErrLoc )
@@ -314,7 +315,8 @@ Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@.
 \item
 Removing lazy (irrefutable) patterns (you don't want to know...).
 \item
-Converting explicit tuple- and list-pats into ordinary @ConPats@.
+Converting explicit tuple-, list-, and parallel-array-pats into ordinary
+@ConPats@. 
 \item
 Convert the literal pat "" to [].
 \end{itemize}
@@ -441,6 +443,15 @@ tidy1 v (ListPat ty pats) match_result
 	      (ConPat nilDataCon  list_ty [] [] [])
 	      pats
 
+-- introduce fake parallel array constructors to be able to handle parallel
+-- arrays with the existing machinery for constructor pattern
+--
+tidy1 v (PArrPat ty pats) match_result
+  = returnDs (parrConPat, match_result)
+  where
+    arity      = length pats
+    parrConPat = ConPat (parrFakeCon arity) (mkPArrTy ty) [] [] pats
+
 tidy1 v (TuplePat pats boxity) match_result
   = returnDs (tuple_ConPat, match_result)
   where