From de6c394e89bb6cb7e628eb43bf155f3e205561bf Mon Sep 17 00:00:00 2001
From: Roman Leshchinskiy <rl@cse.unsw.edu.au>
Date: Thu, 30 Aug 2007 02:52:24 +0000
Subject: [PATCH] Find the correct array type for primitive tycons

---
 compiler/vectorise/VectBuiltIn.hs |   11 ++++++++++-
 compiler/vectorise/VectMonad.hs   |    7 +++++--
 compiler/vectorise/VectUtils.hs   |   17 +++++++++++++++--
 3 files changed, 30 insertions(+), 5 deletions(-)

diff --git a/compiler/vectorise/VectBuiltIn.hs b/compiler/vectorise/VectBuiltIn.hs
index 36159cf..39d4a03 100644
--- a/compiler/vectorise/VectBuiltIn.hs
+++ b/compiler/vectorise/VectBuiltIn.hs
@@ -2,7 +2,7 @@ module VectBuiltIn (
   Builtins(..), sumTyCon, prodTyCon,
   initBuiltins, initBuiltinTyCons, initBuiltinPAs, initBuiltinPRs,
 
-  primMethod
+  primMethod, primPArray
 ) where
 
 #include "HsVersions.h"
@@ -20,6 +20,7 @@ import NameEnv
 import OccName
 
 import TypeRep         ( funTyCon )
+import Type            ( Type )
 import TysPrim
 import TysWiredIn      ( unitTyCon, tupleTyCon, intTyConName )
 import PrelNames
@@ -203,6 +204,14 @@ primMethod tycon method
 
   | otherwise = return Nothing
 
+primPArray :: TyCon -> DsM (Maybe TyCon)
+primPArray tycon
+  | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
+  = liftM Just
+  $ dsLookupTyCon =<< lookupOrig nDP_PRIM (mkOccName tcName $ "PArray" ++ suffix)
+
+  | otherwise = return Nothing
+
 prim_ty_cons = mkNameEnv [mk_prim intPrimTyCon]
   where
     mk_prim tycon = (tyConName tycon, '_' : getOccString tycon)
diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs
index 07638ac..b60a67c 100644
--- a/compiler/vectorise/VectMonad.hs
+++ b/compiler/vectorise/VectMonad.hs
@@ -24,7 +24,7 @@ module VectMonad (
   lookupDataCon, defDataCon,
   lookupTyConPA, defTyConPA, defTyConPAs,
   lookupTyConPR,
-  lookupPrimMethod,
+  lookupPrimMethod, lookupPrimPArray,
   lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
 
   {-lookupInst,-} lookupFamInst
@@ -355,8 +355,11 @@ defDataCon :: DataCon -> DataCon -> VM ()
 defDataCon dc dc' = updGEnv $ \env ->
   env { global_datacons = extendNameEnv (global_datacons env) (dataConName dc) dc' }
 
+lookupPrimPArray :: TyCon -> VM (Maybe TyCon)
+lookupPrimPArray = liftDs . primPArray
+
 lookupPrimMethod :: TyCon -> String -> VM (Maybe Var)
-lookupPrimMethod tycon method = liftDs $ primMethod tycon method
+lookupPrimMethod tycon = liftDs . primMethod tycon
 
 lookupTyConPA :: TyCon -> VM (Maybe Var)
 lookupTyConPA tc = readGEnv $ \env -> lookupNameEnv (global_pa_funs env) (tyConName tc)
diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs
index 3c9d921..b9c4597 100644
--- a/compiler/vectorise/VectUtils.hs
+++ b/compiler/vectorise/VectUtils.hs
@@ -100,6 +100,14 @@ splitClosureTy = splitBinTy "splitClosureTy" closureTyConName
 splitPArrayTy :: Type -> Type
 splitPArrayTy = splitUnTy "splitPArrayTy" parrayTyConName
 
+splitPrimTyCon :: Type -> Maybe TyCon
+splitPrimTyCon ty
+  | Just (tycon, []) <- splitTyConApp_maybe ty
+  , isPrimTyCon tycon
+  = Just tycon
+
+  | otherwise = Nothing
+
 mkBuiltinTyConApp :: (Builtins -> TyCon) -> [Type] -> VM Type
 mkBuiltinTyConApp get_tc tys
   = do
@@ -138,6 +146,12 @@ mkPADictType :: Type -> VM Type
 mkPADictType ty = mkBuiltinTyConApp paTyCon [ty]
 
 mkPArrayType :: Type -> VM Type
+mkPArrayType ty
+  | Just tycon <- splitPrimTyCon ty
+  = do
+      arr <- traceMaybeV "mkPArrayType" (ppr tycon)
+           $ lookupPrimPArray tycon
+      return $ mkTyConApp arr []
 mkPArrayType ty = mkBuiltinTyConApp parrayTyCon [ty]
 
 mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion
@@ -229,8 +243,7 @@ pa_empty     = (emptyPAVar,     "emptyPA")
 
 paMethod :: PAMethod -> Type -> VM CoreExpr
 paMethod (method, name) ty
-  | Just (tycon, []) <- splitTyConApp_maybe ty
-  , isPrimTyCon tycon
+  | Just tycon <- splitPrimTyCon ty
   = do
       fn <- traceMaybeV "paMethod" (ppr tycon <+> text name)
           $ lookupPrimMethod tycon name
-- 
1.7.10.4