From d46b38d86430c0c34250de8eb51e33f24c5eb71d Mon Sep 17 00:00:00 2001
From: Roman Leshchinskiy <rl@cse.unsw.edu.au>
Date: Wed, 5 Dec 2007 22:12:13 +0000
Subject: [PATCH] Optimise desugaring of parallel array comprehensions

---
 compiler/deSugar/DsListComp.lhs |   16 ++++++++++++----
 compiler/prelude/PrelNames.lhs  |    4 +++-
 2 files changed, 15 insertions(+), 5 deletions(-)

diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs
index 7fc4fb9..68c5249 100644
--- a/compiler/deSugar/DsListComp.lhs
+++ b/compiler/deSugar/DsListComp.lhs
@@ -361,9 +361,8 @@ dsPArrComp      :: [Stmt Id]
 dsPArrComp [ParStmt qss] body _  =  -- parallel comprehension
   dePArrParComp qss body
 dsPArrComp qs            body _  =  -- no ParStmt in `qs'
-  dsLookupGlobalId replicatePName			  `thenDs` \repP ->
-  let unitArray = mkApps (Var repP) [Type unitTy, 
-				     mkIntExpr 1, 
+  dsLookupGlobalId singletonPName			  `thenDs` \sglP ->
+  let unitArray = mkApps (Var sglP) [Type unitTy, 
 				     mkCoreTup []]
   in
   dePArrComp qs body (mkTuplePat []) unitArray
@@ -396,6 +395,14 @@ dePArrComp (ExprStmt b _ _ : qs) body pa cea =
   in
   deLambda ty pa b				  `thenDs` \(clam,_) ->
   dePArrComp qs body pa (mkApps (Var filterP) [Type ty, clam, cea])
+
+--
+--  <<[:e' | p <- e, qs:]>> pa ea =
+--    let ef = \pa -> e
+--    in
+--    <<[:e' | qs:]>> (pa, p) (crossMap ea ef)
+--
+-- if matching again p cannot fail, or else
 --
 --  <<[:e' | p <- e, qs:]>> pa ea = 
 --    let ef = \pa -> filterP (\x -> case x of {p -> True; _ -> False}) e
@@ -413,7 +420,8 @@ dePArrComp (BindStmt p e _ _ : qs) body pa cea =
   in
   newSysLocalDs ety'ce					  `thenDs` \v       ->
   matchSimply (Var v) (StmtCtxt PArrComp) p true false    `thenDs` \pred    ->
-  let cef = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]
+  let cef | isIrrefutableHsPat p = ce
+          | otherwise            = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]
   in
   mkLambda ety'cea pa cef				  `thenDs` \(clam, 
 								     _    ) ->
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 86267fb..baf3b50 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -184,7 +184,7 @@ basicKnownKeyNames
 	zipName, foldrName, buildName, augmentName, appendName,
 
         -- Parallel array operations
-	nullPName, lengthPName, replicatePName,	mapPName,
+	nullPName, lengthPName, replicatePName,	singletonPName, mapPName,
 	filterPName, zipPName, crossMapPName, indexPName,
 	toPName, bpermutePName, bpermuteDftPName, indexOfPName,
 
@@ -603,6 +603,7 @@ enumFromToPName	   = varQual gHC_PARR FSLIT("enumFromToP") enumFromToPIdKey
 enumFromThenToPName= varQual gHC_PARR FSLIT("enumFromThenToP") enumFromThenToPIdKey
 nullPName	  = varQual gHC_PARR FSLIT("nullP")      	 nullPIdKey
 lengthPName	  = varQual gHC_PARR FSLIT("lengthP")    	 lengthPIdKey
+singletonPName    = varQual gHC_PARR FSLIT("singletonP")         singletonPIdKey
 replicatePName	  = varQual gHC_PARR FSLIT("replicateP") 	 replicatePIdKey
 mapPName	  = varQual gHC_PARR FSLIT("mapP")       	 mapPIdKey
 filterPName	  = varQual gHC_PARR FSLIT("filterP")    	 filterPIdKey
@@ -975,6 +976,7 @@ breakpointAutoJumpIdKey       = mkPreludeMiscIdUnique 67
 inlineIdKey		      = mkPreludeMiscIdUnique 68
 
 -- Parallel array functions
+singletonPIdKey               = mkPreludeMiscIdUnique 79
 nullPIdKey	              = mkPreludeMiscIdUnique 80
 lengthPIdKey		      = mkPreludeMiscIdUnique 81
 replicatePIdKey		      = mkPreludeMiscIdUnique 82
-- 
1.7.10.4