Vectoriser gets all DPH library identifiers from Data.Array.Parallel.Prim
authorManuel M T Chakravarty <chak@cse.unsw.edu.au>
Mon, 24 Oct 2011 03:48:34 +0000 (14:48 +1100)
committerManuel M T Chakravarty <chak@cse.unsw.edu.au>
Tue, 25 Oct 2011 03:50:01 +0000 (14:50 +1100)
* No more use of hardcoded original names
* Initialisation of the desugarer monad loads 'Data.Array.Parallel.Prim' if -fdph-* given
* Initialisation of the vectoriser gets all built-in names from there

16 files changed:
compiler/deSugar/DsMonad.lhs
compiler/ghc.cabal.in
compiler/iface/TcIface.lhs
compiler/main/HscTypes.lhs
compiler/main/TidyPgm.lhs
compiler/prelude/PrelNames.lhs
compiler/vectorise/Vectorise/Builtins.hs
compiler/vectorise/Vectorise/Builtins/Base.hs
compiler/vectorise/Vectorise/Builtins/Initialise.hs
compiler/vectorise/Vectorise/Builtins/Modules.hs [deleted file]
compiler/vectorise/Vectorise/Env.hs
compiler/vectorise/Vectorise/Monad.hs
compiler/vectorise/Vectorise/Utils.hs
compiler/vectorise/Vectorise/Utils/Base.hs
compiler/vectorise/Vectorise/Utils/Closure.hs
compiler/vectorise/Vectorise/Utils/PADict.hs

index b04d3b6..87f3343 100644 (file)
@@ -22,11 +22,11 @@ module DsMonad (
         UniqSupply, newUniqueSupply,
         getDOptsDs, getGhcModeDs, doptDs, woptDs,
         dsLookupGlobal, dsLookupGlobalId, dsLookupDPHId, dsLookupTyCon, dsLookupDataCon,
+        
+        assertDAPPLoaded, lookupDAPPRdrEnv, dsImportDecl, dsImportId, dsImportTyCon,
 
         DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
 
-        dsLoadModule,
-
         -- Warnings
         DsWarning, warnDs, failWithDs,
 
@@ -41,6 +41,8 @@ import CoreSyn
 import HsSyn
 import TcIface
 import LoadIface
+import PrelNames
+import Avail
 import RdrName
 import HscTypes
 import Bag
@@ -57,6 +59,8 @@ import NameEnv
 import DynFlags
 import ErrUtils
 import FastString
+import Maybes
+import Control.Monad
 
 import Data.IORef
 \end{code}
@@ -114,6 +118,7 @@ orFail _        _        = CanFail
 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
 a @UniqueSupply@ and some annotations, which
 presumably include source-file location information:
+
 \begin{code}
 type DsM result = TcRnIf DsGblEnv DsLclEnv result
 
@@ -130,8 +135,11 @@ data DsGblEnv = DsGblEnv {
         ds_mod     :: Module,                   -- For SCC profiling
         ds_unqual  :: PrintUnqualified,
         ds_msgs    :: IORef Messages,           -- Warning messages
-        ds_if_env  :: (IfGblEnv, IfLclEnv)      -- Used for looking up global, 
+        ds_if_env  :: (IfGblEnv, IfLclEnv),     -- Used for looking up global, 
                                                 -- possibly-imported things
+        ds_dph_env :: GlobalRdrEnv              -- exported entities of 'Data.Array.Parallel.Prim' iff
+                                                -- '-fdph-*' flag was given (i.e., 'DynFlags.DPHBackend /=
+                                                -- DPHNone'); otherwise, empty
     }
 
 data DsLclEnv = DsLclEnv {
@@ -152,18 +160,19 @@ data DsMetaVal
                         -- the PendingSplices on a HsBracketOut
 
 initDs :: HscEnv
-        -> Module -> GlobalRdrEnv -> TypeEnv
-        -> DsM a
-        -> IO (Messages, Maybe a)
+       -> Module -> GlobalRdrEnv -> TypeEnv
+       -> DsM a
+       -> IO (Messages, Maybe a)
 -- Print errors and warnings, if any arise
 
 initDs hsc_env mod rdr_env type_env thing_inside
   = do  { msg_var <- newIORef (emptyBag, emptyBag)
-        ; let dflags = hsc_dflags hsc_env
-        ; (ds_gbl_env, ds_lcl_env) <- mkDsEnvs dflags mod rdr_env type_env msg_var
+        ; let dflags                   = hsc_dflags hsc_env
+              (ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env msg_var
 
         ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
-                        tryM thing_inside       -- Catch exceptions (= errors during desugaring)
+                          loadDAPP dflags $
+                            tryM thing_inside       -- Catch exceptions (= errors during desugaring)
 
         -- Display any errors and warnings 
         -- Note: if -Werror is used, we don't signal an error here.
@@ -172,12 +181,31 @@ initDs hsc_env mod rdr_env type_env thing_inside
         ; let final_res | errorsFound dflags msgs = Nothing
                         | otherwise = case either_res of
                                         Right res -> Just res
-                                        Left exn -> pprPanic "initDs" (text (show exn))
+                                        Left exn  -> pprPanic "initDs" (text (show exn))
                 -- The (Left exn) case happens when the thing_inside throws
                 -- a UserError exception.  Then it should have put an error
                 -- message in msg_var, so we just discard the exception
 
-        ; return (msgs, final_res) }
+        ; return (msgs, final_res) 
+        }
+  where
+    -- Extend the global environment with a 'GlobalRdrEnv' containing the exported entities of
+    -- 'Data.Array.Parallel.Prim' if '-fdph-*' specified.
+    loadDAPP dflags thing_inside
+      | Just pkg <- dphPackageMaybe dflags
+      = do { rdr_env <- loadModule sdoc (dATA_ARRAY_PARALLEL_PRIM pkg)
+           ; updGblEnv (\env -> env {ds_dph_env = rdr_env}) thing_inside
+           }
+      | otherwise
+      = do { ifXOptM Opt_ParallelArrays (liftIO $ fatalErrorMsg dflags $ ptext selectBackendErrPA)
+           ; ifDOptM Opt_Vectorise      (liftIO $ fatalErrorMsg dflags $ ptext selectBackendErrVect)
+           ; thing_inside
+           }
+
+    sdoc = ptext (sLit "Internal Data Parallel Haskell interface 'Data.Array.Parallel.Prim'")
+
+    selectBackendErrVect = sLit "To use -fvectorise select a DPH backend with -fdph-par or -fdph-seq"
+    selectBackendErrPA   = sLit "To use -XParallelArrays select a DPH backend with -fdph-par or -fdph-seq"
 
 initDsTc :: DsM a -> TcM a
 initDsTc thing_inside
@@ -187,24 +215,54 @@ initDsTc thing_inside
         ; dflags   <- getDOpts
         ; let type_env = tcg_type_env tcg_env
               rdr_env  = tcg_rdr_env tcg_env
-        ; ds_envs <- liftIO $ mkDsEnvs dflags this_mod rdr_env type_env msg_var
-        ; setEnvs ds_envs thing_inside }
+              ds_envs  = mkDsEnvs dflags this_mod rdr_env type_env msg_var
+        ; setEnvs ds_envs thing_inside
+        }
 
-mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv)
+mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> (DsGblEnv, DsLclEnv)
 mkDsEnvs dflags mod rdr_env type_env msg_var
-  = do -- TODO: unnecessarily monadic
-       let     if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
-               if_lenv = mkIfLclEnv mod (ptext (sLit "GHC error in desugarer lookup in") <+> ppr mod)
-               gbl_env = DsGblEnv { ds_mod = mod, 
-                                    ds_if_env = (if_genv, if_lenv),
-                                    ds_unqual = mkPrintUnqualified dflags rdr_env,
-                                    ds_msgs = msg_var}
-               lcl_env = DsLclEnv { ds_meta = emptyNameEnv, 
-                                    ds_loc = noSrcSpan }
-
-       return (gbl_env, lcl_env)
+  = let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
+        if_lenv = mkIfLclEnv mod (ptext (sLit "GHC error in desugarer lookup in") <+> ppr mod)
+        gbl_env = DsGblEnv { ds_mod     = mod
+                           , ds_if_env  = (if_genv, if_lenv)
+                           , ds_unqual  = mkPrintUnqualified dflags rdr_env
+                           , ds_msgs    = msg_var
+                           , ds_dph_env = emptyGlobalRdrEnv
+                           }
+        lcl_env = DsLclEnv { ds_meta = emptyNameEnv
+                           , ds_loc  = noSrcSpan
+                           }
+    in (gbl_env, lcl_env)
+
+-- Attempt to load the given module and return its exported entities if successful; otherwise, return an
+-- empty environment.  See "Note [Loading Data.Array.Parallel.Prim]".
+--
+loadModule :: SDoc -> Module -> DsM GlobalRdrEnv
+loadModule doc mod
+  = do { env <- getGblEnv
+       ; setEnvs (ds_if_env env) $ do
+       { iface <- loadInterface doc mod ImportBySystem
+       ;   case iface of
+             Failed _err     -> return $ mkGlobalRdrEnv []
+             Succeeded iface -> return $ mkGlobalRdrEnv . gresFromAvails prov . mi_exports $ iface
+       } }
+  where
+    prov     = Imported [ImpSpec { is_decl = imp_spec, is_item = ImpAll }]
+    imp_spec = ImpDeclSpec { is_mod = name, is_qual = True,
+                             is_dloc = wiredInSrcSpan, is_as = name }
+    name = moduleName mod
 \end{code}
 
+Note [Loading Data.Array.Parallel.Prim]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We generally attempt to load the interface of 'Data.Array.Parallel.Prim' when a DPH backend is selected.
+However, while compiling packages containing a DPH backend, we will start out compiling the modules
+'Data.Array.Parallel.Prim' depends on — i.e., when compiling these modules, the interface won't exist yet.
+This is fine, as these modules do not use the vectoriser, but we need to ensure that GHC doesn't barf when
+the interface is missing.  Instead of an error message, we just put an empty 'GlobalRdrEnv' into the
+'DsM' state.
+
+
 %************************************************************************
 %*                                                                      *
                 Operations in the monad
@@ -320,6 +378,51 @@ dsLookupDataCon name
 \end{code}
 
 \begin{code}
+-- Complain if 'Data.Array.Parallel.Prim' wasn't loaded (and we are about to use it).
+--
+-- See "Note [Loading Data.Array.Parallel.Prim]".
+--
+assertDAPPLoaded :: DsM ()
+assertDAPPLoaded 
+  = do { env <- ds_dph_env <$> getGblEnv
+       ; when (null $ occEnvElts env) $
+           panic "'Data.Array.Parallel.Prim' not available; probably missing dependencies in DPH package"
+       }
+
+-- Look up a name exported by 'Data.Array.Parallel.Prim'.
+--
+lookupDAPPRdrEnv :: OccName -> DsM Name
+lookupDAPPRdrEnv occ
+  = do { env <- ds_dph_env <$> getGblEnv
+       ; let gres = lookupGlobalRdrEnv env occ
+       ; case gres of
+           []    -> pprPanic "Name not found in 'Data.Array.Parallel.Prim':" (ppr occ)
+           [gre] -> return $ gre_name gre
+           _     -> pprPanic "Multiple definitions in 'Data.Array.Parallel.Prim':" (ppr occ)
+       }
+
+-- Find the thing repferred to by an imported name.
+--
+dsImportDecl :: Name -> DsM TyThing
+dsImportDecl name
+  = do { env <- getGblEnv
+       ; setEnvs (ds_if_env env) $ do
+       { mb_thing <- importDecl name
+       ; case mb_thing of
+           Failed err      -> failIfM err
+           Succeeded thing -> return thing
+       } }
+
+dsImportId :: Name -> DsM Id
+dsImportId name
+  = tyThingId <$> dsImportDecl name
+
+dsImportTyCon :: Name -> DsM TyCon
+dsImportTyCon name
+  = tyThingTyCon <$> dsImportDecl name
+\end{code}
+
+\begin{code}
 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
 
@@ -327,13 +430,3 @@ dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
 dsExtendMetaEnv menv thing_inside
   = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
 \end{code}
-
-\begin{code}
-dsLoadModule :: SDoc -> Module -> DsM ()
-dsLoadModule doc mod
-  = do { env <- getGblEnv
-       ; setEnvs (ds_if_env env)
-                 (loadSysInterface doc mod >> return ())
-       }
-\end{code}
-
index 56d9538..f84da15 100755 (executable)
@@ -459,7 +459,6 @@ Library
         Util
         Vectorise.Builtins.Base
         Vectorise.Builtins.Initialise
-        Vectorise.Builtins.Modules
         Vectorise.Builtins
         Vectorise.Monad.Base
         Vectorise.Monad.Naming
index c44bc55..dff668f 100644 (file)
@@ -64,7 +64,6 @@ import Util
 import FastString
 
 import Control.Monad
-import Data.List
 \end{code}
 
 This module takes
@@ -724,13 +723,11 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
        ; vVars     <- mapM vectVarMapping                          vars
        ; tyConRes1 <- mapM vectTyConMapping                        tycons
        ; tyConRes2 <- mapM (vectTyConReuseMapping scalarTyConsSet) tyconsReuse
-       ; let (vTyCons, vDataCons, vPAs, vIsos) = unzip4 (tyConRes1 ++ tyConRes2)
+       ; let (vTyCons, vDataCons) = unzip (tyConRes1 ++ tyConRes2)
        ; return $ VectInfo 
                   { vectInfoVar          = mkVarEnv  vVars
                   , vectInfoTyCon        = mkNameEnv vTyCons
                   , vectInfoDataCon      = mkNameEnv (concat vDataCons)
-                  , vectInfoPADFun       = mkNameEnv (catMaybes vPAs)
-                  , vectInfoIso          = mkNameEnv (catMaybes vIsos)
                   , vectInfoScalarVars   = mkVarSet  (map lookupVar scalarVars)
                   , vectInfoScalarTyCons = scalarTyConsSet
                   }
@@ -748,44 +745,31 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
            }
     vectTyConMapping name 
       = do { vName   <- lookupOrig mod (mkLocalisedOccName mod mkVectTyConOcc name)
-           ; paName  <- lookupOrig mod (mkLocalisedOccName mod mkPADFunOcc    name)
-           ; isoName <- lookupOrig mod (mkLocalisedOccName mod mkVectIsoOcc   name)
            -- FIXME: we will need to use tcIfaceTyCon/tcIfaceExtId on some of these (but depends
            --   on how we exactly define the 'VECTORISE type' pragma to work)
            ; let { tycon    = lookupTyCon name
                  ; vTycon   = lookupTyCon vName
-                 ; paTycon  = lookupVar paName
-                 ; isoTycon = lookupVar isoName
                  }
            ; vDataCons <- mapM vectDataConMapping (tyConDataCons tycon)
            ; return ( (name, (tycon, vTycon))          -- (T, T_v)
                     , vDataCons                        -- list of (Ci, Ci_v)
-                    , Just (vName, (vTycon, paTycon))  -- (T_v, paT)
-                    , Just (name, (tycon, isoTycon))   -- (T, isoT)
                     )
            }
     vectTyConReuseMapping scalarNames name 
-      = do { paName  <- lookupOrig mod (mkLocalisedOccName mod mkPADFunOcc  name)
-           ; isoName <- lookupOrig mod (mkLocalisedOccName mod mkVectIsoOcc name)
-           ; tycon <- forkM (text ("vect reuse tycon") <+> ppr name) $
+      = do { tycon <- forkM (text ("vect reuse tycon") <+> ppr name) $
                       tcIfaceTyCon (IfaceTc name) -- somewhat naughty for wired in tycons, but ok
            ; if name `elemNameSet` scalarNames
              then do
-           { return ( (name, (tycon, tycon))      -- scalar type constructors expose no data...
-                    , []                          -- ...constructors and have no PA and ISO vars...
-                    , Nothing                     -- ...see "Note [Pragmas to vectorise tycons]" in..
-                    , Nothing                     -- ...'Vectorise.Type.Env'
-                    )
+           { return ( (name, (tycon, tycon))      -- scalar type constructors expose no data..
+                    , []                          -- ..constructors see..
+                    )                             -- .."Note [Pragmas to vectorise tycons]"..
+                                                  -- ..in 'Vectorise.Type.Env'
            } else do 
-           { let { paTycon    = lookupVar paName
-                 ; isoTycon   = lookupVar isoName
-                 ; vDataCons  = [ (dataConName dc, (dc, dc)) 
+           { let { vDataCons  = [ (dataConName dc, (dc, dc)) 
                                 | dc <- tyConDataCons tycon]
                  }
            ; return ( (name, (tycon, tycon))          -- (T, T)
                     , vDataCons                       -- list of (Ci, Ci)
-                    , Just (name, (tycon, paTycon))   -- (T, paT)
-                    , Just (name, (tycon, isoTycon))  -- (T, isoT)
                     )
            }}
     vectDataConMapping datacon
index 5dc92be..3e2551e 100644 (file)
@@ -1910,8 +1910,6 @@ data VectInfo
     { vectInfoVar          :: VarEnv  (Var    , Var  )    -- ^ @(f, f_v)@ keyed on @f@
     , vectInfoTyCon        :: NameEnv (TyCon  , TyCon)    -- ^ @(T, T_v)@ keyed on @T@
     , vectInfoDataCon      :: NameEnv (DataCon, DataCon)  -- ^ @(C, C_v)@ keyed on @C@
-    , vectInfoPADFun       :: NameEnv (TyCon  , Var)      -- ^ @(T_v, paT)@ keyed on @T_v@
-    , vectInfoIso          :: NameEnv (TyCon  , Var)      -- ^ @(T, isoT)@ keyed on @T@
     , vectInfoScalarVars   :: VarSet                      -- ^ set of purely scalar variables
     , vectInfoScalarTyCons :: NameSet                     -- ^ set of scalar type constructors
     }
@@ -1937,16 +1935,13 @@ data IfaceVectInfo
 
 noVectInfo :: VectInfo
 noVectInfo 
-  = VectInfo emptyVarEnv emptyNameEnv emptyNameEnv emptyNameEnv emptyNameEnv emptyVarSet
-             emptyNameSet
+  = VectInfo emptyVarEnv emptyNameEnv emptyNameEnv emptyVarSet emptyNameSet
 
 plusVectInfo :: VectInfo -> VectInfo -> VectInfo
 plusVectInfo vi1 vi2 = 
   VectInfo (vectInfoVar          vi1 `plusVarEnv`    vectInfoVar          vi2)
            (vectInfoTyCon        vi1 `plusNameEnv`   vectInfoTyCon        vi2)
            (vectInfoDataCon      vi1 `plusNameEnv`   vectInfoDataCon      vi2)
-           (vectInfoPADFun       vi1 `plusNameEnv`   vectInfoPADFun       vi2)
-           (vectInfoIso          vi1 `plusNameEnv`   vectInfoIso          vi2)
            (vectInfoScalarVars   vi1 `unionVarSet`   vectInfoScalarVars   vi2)
            (vectInfoScalarTyCons vi1 `unionNameSets` vectInfoScalarTyCons vi2)
 
@@ -1961,8 +1956,6 @@ instance Outputable VectInfo where
              [ ptext (sLit "variables     :") <+> ppr (vectInfoVar          info)
              , ptext (sLit "tycons        :") <+> ppr (vectInfoTyCon        info)
              , ptext (sLit "datacons      :") <+> ppr (vectInfoDataCon      info)
-             , ptext (sLit "PA dfuns      :") <+> ppr (vectInfoPADFun       info)
-             , ptext (sLit "iso           :") <+> ppr (vectInfoIso          info)
              , ptext (sLit "scalar vars   :") <+> ppr (vectInfoScalarVars   info)
              , ptext (sLit "scalar tycons :") <+> ppr (vectInfoScalarTyCons info)
              ]
index 980b46c..d800bc6 100644 (file)
@@ -494,13 +494,9 @@ tidyInstances tidy_dfun ispecs
 \begin{code}
 tidyVectInfo :: TidyEnv -> VectInfo -> VectInfo
 tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar          = vars
-                                         , vectInfoPADFun       = pas
-                                         , vectInfoIso          = isos
                                          , vectInfoScalarVars   = scalarVars
                                          })
   = info { vectInfoVar          = tidy_vars
-         , vectInfoPADFun       = tidy_pas
-         , vectInfoIso          = tidy_isos 
          , vectInfoScalarVars   = tidy_scalarVars
          }
   where
@@ -512,11 +508,6 @@ tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar          = vars
                          , isExportedId tidy_var_v
                          ]
 
-    tidy_pas  = mapNameEnv tidy_snd_var pas
-    tidy_isos = mapNameEnv tidy_snd_var isos
-
-    tidy_snd_var (x, var) = (x, lookup_var var)
-
     tidy_scalarVars = mkVarSet [ lookup_var var 
                                | var <- varSetElems scalarVars
                                , isGlobalId var || isExportedId var]
index b48df7f..7eacbd5 100644 (file)
@@ -399,6 +399,9 @@ rANDOM          = mkBaseModule (fsLit "System.Random")
 gHC_EXTS        = mkBaseModule (fsLit "GHC.Exts")
 cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base")
 
+dATA_ARRAY_PARALLEL_PRIM :: PackageId -> Module
+dATA_ARRAY_PARALLEL_PRIM pkg = mkModule pkg (mkModuleNameFS (fsLit "Data.Array.Parallel.Prim"))
+
 gHC_PARR :: PackageId -> Module
 gHC_PARR pkg = mkModule pkg (mkModuleNameFS (fsLit "Data.Array.Parallel"))
 
index 5545df8..bf0fae1 100644 (file)
@@ -1,74 +1,32 @@
--- Types and functions declared in the DPH packages and used by the vectoriser.
+-- Types and functions declared in 'Data.Array.Parallel.Prim' and used by the vectoriser.
 --
--- The @Builtins@ structure holds the name of all the things in the DPH packages that appear in
--- code generated by the vectoriser. We can get specific things using the selectors, which print a
--- civilized panic message if the specified thing cannot be found.
+-- The @Builtins@ structure holds the name of all the things in 'Data.Array.Parallel.Prim' that appear in
+-- code generated by the vectoriser.
 
 module Vectorise.Builtins (
   -- * Builtins
   Builtins(..),
-  indexBuiltin,
   
   -- * Wrapped selectors
+  parray_PrimTyCon,
   selTy,
   selReplicate,
-  selPick,
   selTags,
   selElements,
   sumTyCon,
   prodTyCon,
   prodDataCon,
+  replicatePD_PrimVar,
+  emptyPD_PrimVar,
+  packByTagPD_PrimVar,
   combinePDVar,
+  combinePD_PrimVar,
   scalarZip,
   closureCtrFun,
 
   -- * Initialisation
-  initBuiltins, initBuiltinVars, initBuiltinTyCons, 
-  initBuiltinPAs, initBuiltinPRs,
-  
-  -- * Lookup
-  primMethod,
-  primPArray
+  initBuiltins, initBuiltinVars, initBuiltinTyCons
 ) where
-  
+
 import Vectorise.Builtins.Base
-import Vectorise.Builtins.Modules
 import Vectorise.Builtins.Initialise
-
-import TysPrim
-import IfaceEnv
-import TyCon
-import DsMonad
-import NameEnv
-import Name
-import Var
-import Control.Monad
-
-
--- |Lookup a method function given its name and instance type.
---
-primMethod :: TyCon -> String -> Builtins -> DsM (Maybe Var)
-primMethod  tycon method (Builtins { dphModules = mods })
-  | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
-  = liftM Just
-  $ dsLookupGlobalId =<< lookupOrig (dph_Unboxed mods)
-                                    (mkVarOcc $ method ++ suffix)
-
-  | otherwise = return Nothing
-
--- |Lookup the representation type we use for PArrays that contain a given element type.
---
-primPArray :: TyCon -> Builtins -> DsM (Maybe TyCon)
-primPArray tycon (Builtins { dphModules = mods })
-  | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon)
-  = liftM Just
-  $ dsLookupTyCon =<< lookupOrig (dph_Unboxed mods)
-                                 (mkTcOcc $ "PArray" ++ suffix)
-
-  | otherwise = return Nothing
-
-prim_ty_cons :: NameEnv String
-prim_ty_cons = mkNameEnv [mk_prim intPrimTyCon]
-  where
-    mk_prim tycon = (tyConName tycon, '_' : getOccString tycon)
-
index 52eb887..13ab890 100644 (file)
@@ -1,4 +1,5 @@
--- | Builtin types and functions used by the vectoriser. These are all defined in the DPH package.
+-- |Builtin types and functions used by the vectoriser. These are all defined in
+-- 'Data.Array.Parallel.Prim'.
 
 module Vectorise.Builtins.Base (
   -- * Hard config
@@ -6,26 +7,30 @@ module Vectorise.Builtins.Base (
   mAX_DPH_SUM,
   mAX_DPH_COMBINE,
   mAX_DPH_SCALAR_ARGS,
+  aLL_DPH_PRIM_TYCONS,
   
   -- * Builtins
   Builtins(..),
-  indexBuiltin,
   
   -- * Projections
-        selTy,
+  parray_PrimTyCon,
+  selTy,
   selReplicate,
-  selPick,
   selTags,
   selElements,
   sumTyCon,
   prodTyCon,
   prodDataCon,
+  replicatePD_PrimVar,
+  emptyPD_PrimVar,
+  packByTagPD_PrimVar,
   combinePDVar,
+  combinePD_PrimVar,
   scalarZip,
   closureCtrFun
 ) where
 
-import Vectorise.Builtins.Modules
+import TysPrim
 import BasicTypes
 import Class
 import CoreSyn
@@ -33,11 +38,15 @@ import TysWiredIn
 import Type
 import TyCon
 import DataCon
+import NameEnv
+import Name
 import Outputable
+
 import Data.Array
 
 
--- Numbers of things exported by the DPH library.
+-- Cardinality of the various families of types and functions exported by the DPH library.
+
 mAX_DPH_PROD :: Int
 mAX_DPH_PROD = 5
 
@@ -50,114 +59,83 @@ mAX_DPH_COMBINE = 2
 mAX_DPH_SCALAR_ARGS :: Int
 mAX_DPH_SCALAR_ARGS = 3
 
+-- Types from 'GHC.Prim' supported by DPH
+--
+aLL_DPH_PRIM_TYCONS :: [Name]
+aLL_DPH_PRIM_TYCONS = map tyConName [intPrimTyCon, {- floatPrimTyCon, -} doublePrimTyCon]
+
 
--- | Holds the names of the builtin types and functions used by the vectoriser.
+-- |Holds the names of the types and functions from 'Data.Array.Parallel.Prim' that are used by the
+-- vectoriser.
+--
 data Builtins 
         = Builtins 
-        { dphModules       :: Modules
-
-  -- From dph-common:Data.Array.Parallel.Lifted.PArray
-        , parrayTyCon      :: TyCon                     -- ^ PArray
-        , parrayDataCon    :: DataCon                   -- ^ PArray
-        , pdataTyCon       :: TyCon                     -- ^ PData
-        , paClass          :: Class                     -- ^ PA
-        , paTyCon          :: TyCon                     -- ^ PA
-        , paDataCon        :: DataCon                   -- ^ PA
-        , paPRSel          :: Var                       -- ^ PA
-        , preprTyCon       :: TyCon                     -- ^ PRepr
-        , prClass          :: Class                     -- ^ PR
-        , prTyCon          :: TyCon                     -- ^ PR
-        , prDataCon        :: DataCon                   -- ^ PR
-        , replicatePDVar   :: Var                       -- ^ replicatePD
-        , emptyPDVar       :: Var                       -- ^ emptyPD
-        , packByTagPDVar   :: Var                       -- ^ packByTagPD
-        , combinePDVars    :: Array Int Var             -- ^ combinePD
-        , scalarClass      :: Class                     -- ^ Scalar
-
-        -- From dph-common:Data.Array.Parallel.Lifted.Closure
-        , closureTyCon     :: TyCon                     -- ^ :->
-        , closureVar       :: Var                       -- ^ closure
-        , applyVar         :: Var                       -- ^ $: 
-        , liftedClosureVar :: Var                       -- ^ liftedClosure
-        , liftedApplyVar   :: Var                       -- ^ liftedApply
-        , closureCtrFuns   :: Array Int Var             -- ^ closure1 .. closure2
-
-  -- From dph-common:Data.Array.Parallel.Lifted.Repr
-        , voidTyCon        :: TyCon                     -- ^ Void
-        , wrapTyCon        :: TyCon                     -- ^ Wrap
-        , sumTyCons        :: Array Int TyCon           -- ^ Sum2 .. Sum3
-        , voidVar          :: Var                       -- ^ void
-        , pvoidVar         :: Var                       -- ^ pvoid
-        , fromVoidVar      :: Var                       -- ^ fromVoid
-        , punitVar         :: Var                       -- ^ punit
-
-  -- From dph-common:Data.Array.Parallel.Lifted.Selector
-        , selTys           :: Array Int Type            -- ^ Sel2
-        , selReplicates    :: Array Int CoreExpr        -- ^ replicate2
-        , selPicks         :: Array Int CoreExpr        -- ^ pick2
-        , selTagss         :: Array Int CoreExpr        -- ^ tagsSel2
-        , selEls           :: Array (Int, Int) CoreExpr -- ^ elementsSel2_0 .. elementsSel_2_1
-
-  -- From dph-common:Data.Array.Parallel.Lifted.Scalar
-  -- NOTE: map is counted as a zipWith fn with one argument array.
-        , scalarZips       :: Array Int Var             -- ^ map, zipWith, zipWith3
-
-  -- A Fresh variable
-        , liftingContext   :: Var                       -- ^ lc
+        { parrayTyCon          :: TyCon                     -- ^ PArray
+        , parray_PrimTyCons    :: NameEnv TyCon             -- ^ PArray_Int# etc.
+        , pdataTyCon           :: TyCon                     -- ^ PData
+        , prClass              :: Class                     -- ^ PR
+        , prTyCon              :: TyCon                     -- ^ PR
+        , preprTyCon           :: TyCon                     -- ^ PRepr
+        , paClass              :: Class                     -- ^ PA
+        , paTyCon              :: TyCon                     -- ^ PA
+        , paDataCon            :: DataCon                   -- ^ PA
+        , paPRSel              :: Var                       -- ^ PA
+        , replicatePDVar       :: Var                       -- ^ replicatePD
+        , replicatePD_PrimVars :: NameEnv Var               -- ^ replicatePD_Int# etc.
+        , emptyPDVar           :: Var                       -- ^ emptyPD
+        , emptyPD_PrimVars     :: NameEnv Var               -- ^ emptyPD_Int# etc.
+        , packByTagPDVar       :: Var                       -- ^ packByTagPD
+        , packByTagPD_PrimVars :: NameEnv Var               -- ^ packByTagPD_Int# etc.
+        , combinePDVars        :: Array Int Var             -- ^ combinePD
+        , combinePD_PrimVarss  :: Array Int (NameEnv Var)   -- ^ combine2PD_Int# etc.
+        , scalarClass          :: Class                     -- ^ Scalar
+        , scalarZips           :: Array Int Var             -- ^ map, zipWith, zipWith3
+        , voidTyCon            :: TyCon                     -- ^ Void
+        , voidVar              :: Var                       -- ^ void
+        , fromVoidVar          :: Var                       -- ^ fromVoid
+        , sumTyCons            :: Array Int TyCon           -- ^ Sum2 .. Sum3
+        , wrapTyCon            :: TyCon                     -- ^ Wrap
+        , pvoidVar             :: Var                       -- ^ pvoid
+        , closureTyCon         :: TyCon                     -- ^ :->
+        , closureVar           :: Var                       -- ^ closure
+        , liftedClosureVar     :: Var                       -- ^ liftedClosure
+        , applyVar             :: Var                       -- ^ $: 
+        , liftedApplyVar       :: Var                       -- ^ liftedApply
+        , closureCtrFuns       :: Array Int Var             -- ^ closure1 .. closure3
+        , selTys               :: Array Int Type            -- ^ Sel2
+        , selReplicates        :: Array Int CoreExpr        -- ^ replicate2
+        , selTagss             :: Array Int CoreExpr        -- ^ tagsSel2
+        , selElementss         :: Array (Int, Int) CoreExpr -- ^ elementsSel2_0 .. elementsSel_2_1
+        , liftingContext       :: Var                       -- ^ lc
         }
 
 
--- | Get an element from one of the arrays of contained by a `Builtins`.
---   If the indexed thing is not in the array then panic.
-indexBuiltin 
-  :: (Ix i, Outputable i) 
-  => String       -- ^ Name of the selector we've used, for panic messages.
-  -> (Builtins -> Array i a)  -- ^ Field selector for the `Builtins`.
-  -> i        -- ^ Index into the array.
-  -> Builtins 
-  -> a
-
-indexBuiltin fn f i bi
-  | inRange (bounds xs) i = xs ! i
-  | otherwise       
-  = pprSorry "Vectorise.Builtins.indexBuiltin" 
-    (vcat [ text ""
-    , text "DPH builtin function '" <> text fn <> text "' of size '" <> ppr i <> text "' is not yet implemented."
-    , text "This function does not appear in your source program, but it is needed"
-    , text "to compile your code in the backend. This is a known, current limitation"
-    , text "of DPH. If you want it to to work you should send mail to cvs-ghc@haskell.org"
-    , text "and ask what you can do to help (it might involve some GHC hacking)."])
-
-  where xs = f bi
-
-
 -- Projections ----------------------------------------------------------------
 -- We use these wrappers instead of indexing the `Builtin` structure directly
 -- because they give nicer panic messages if the indexed thing cannot be found.
 
+parray_PrimTyCon :: TyCon -> Builtins -> TyCon
+parray_PrimTyCon tc bi = lookupEnvBuiltin "parray_PrimTyCon" (parray_PrimTyCons bi) (tyConName tc)
+
 selTy :: Int -> Builtins -> Type
-selTy     = indexBuiltin "selTy" selTys
+selTy = indexBuiltin "selTy" selTys
 
 selReplicate :: Int -> Builtins -> CoreExpr
-selReplicate  = indexBuiltin "selReplicate" selReplicates 
-
-selPick :: Int -> Builtins -> CoreExpr
-selPick   = indexBuiltin "selPick" selPicks
+selReplicate = indexBuiltin "selReplicate" selReplicates 
 
 selTags :: Int -> Builtins -> CoreExpr
 selTags   = indexBuiltin "selTags" selTagss
 
 selElements :: Int -> Int -> Builtins -> CoreExpr
-selElements i j = indexBuiltin "selElements" selEls (i,j)
+selElements i j = indexBuiltin "selElements" selElementss (i, j)
 
 sumTyCon :: Int -> Builtins -> TyCon
-sumTyCon  = indexBuiltin "sumTyCon" sumTyCons
+sumTyCon = indexBuiltin "sumTyCon" sumTyCons
 
 prodTyCon :: Int -> Builtins -> TyCon
 prodTyCon n _
   | n >= 2 && n <= mAX_DPH_PROD 
   = tupleTyCon BoxedTuple n
-
   | otherwise
   = pprPanic "prodTyCon" (ppr n)
 
@@ -167,13 +145,67 @@ prodDataCon n bi
     [con] -> con
     _ -> pprPanic "prodDataCon" (ppr n)
 
+replicatePD_PrimVar :: TyCon -> Builtins -> Var
+replicatePD_PrimVar tc bi
+  = lookupEnvBuiltin "replicatePD_PrimVar" (replicatePD_PrimVars bi) (tyConName tc)
+
+emptyPD_PrimVar :: TyCon -> Builtins -> Var
+emptyPD_PrimVar tc bi
+  = lookupEnvBuiltin "emptyPD_PrimVar" (emptyPD_PrimVars bi) (tyConName tc)
+
+packByTagPD_PrimVar :: TyCon -> Builtins -> Var
+packByTagPD_PrimVar tc bi
+  = lookupEnvBuiltin "packByTagPD_PrimVar" (packByTagPD_PrimVars bi) (tyConName tc)
+
 combinePDVar :: Int -> Builtins -> Var
-combinePDVar  = indexBuiltin "combinePDVar" combinePDVars
+combinePDVar = indexBuiltin "combinePDVar" combinePDVars
+
+combinePD_PrimVar :: Int -> TyCon -> Builtins -> Var
+combinePD_PrimVar i tc bi
+  = lookupEnvBuiltin "combinePD_PrimVar" 
+      (indexBuiltin "combinePD_PrimVar" combinePD_PrimVarss i bi) (tyConName tc)
 
 scalarZip :: Int -> Builtins -> Var
-scalarZip   = indexBuiltin "scalarZip" scalarZips
+scalarZip = indexBuiltin "scalarZip" scalarZips
 
 closureCtrFun :: Int -> Builtins -> Var
-closureCtrFun   = indexBuiltin "closureCtrFun" closureCtrFuns
-
+closureCtrFun = indexBuiltin "closureCtrFun" closureCtrFuns
+
+-- Get an element from one of the arrays of `Builtins`. Panic if the indexed thing is not in the array.
+--
+indexBuiltin :: (Ix i, Outputable i) 
+             => String                   -- ^ Name of the selector we've used, for panic messages.
+             -> (Builtins -> Array i a)  -- ^ Field selector for the `Builtins`.
+             -> i                        -- ^ Index into the array.
+             -> Builtins 
+             -> a
+indexBuiltin fn f i bi
+  | inRange (bounds xs) i = xs ! i
+  | otherwise       
+  = pprSorry "Vectorise.Builtins.indexBuiltin" 
+    (vcat [ text ""
+    , text "DPH builtin function '" <> text fn <> text "' of size '" <> ppr i <> 
+      text "' is not yet implemented."
+    , text "This function does not appear in your source program, but it is needed"
+    , text "to compile your code in the backend. This is a known, current limitation"
+    , text "of DPH. If you want it to to work you should send mail to cvs-ghc@haskell.org"
+    , text "and ask what you can do to help (it might involve some GHC hacking)."])
+  where xs = f bi
 
+-- Get an entry from one of a 'NameEnv' of `Builtins`. Panic if the named item is not in the array.
+--
+lookupEnvBuiltin :: String                    -- Function name for error messages
+                 -> NameEnv a                 -- Name environment
+                 -> Name                      -- Index into the name environment
+                 -> a
+lookupEnvBuiltin fn env n
+  | Just r <- lookupNameEnv env n = r
+  | otherwise 
+  = pprSorry "Vectorise.Builtins.lookupEnvBuiltin" 
+    (vcat [ text ""
+    , text "DPH builtin function '" <> text fn <> text "_" <> ppr n <> 
+      text "' is not yet implemented."
+    , text "This function does not appear in your source program, but it is needed"
+    , text "to compile your code in the backend. This is a known, current limitation"
+    , text "of DPH. If you want it to to work you should send mail to cvs-ghc@haskell.org"
+    , text "and ask what you can do to help (it might involve some GHC hacking)."])
index ac7b580..4f8361b 100644 (file)
@@ -2,26 +2,22 @@
 
 module Vectorise.Builtins.Initialise (
   -- * Initialisation
-  initBuiltins, initBuiltinVars, initBuiltinTyCons,
-  initBuiltinPAs, initBuiltinPRs
+  initBuiltins, initBuiltinVars, initBuiltinTyCons
 ) where
 
 import Vectorise.Builtins.Base
-import Vectorise.Builtins.Modules
 
 import BasicTypes
 import TysPrim
 import DsMonad
-import IfaceEnv
-import InstEnv
 import TysWiredIn
 import DataCon
 import TyCon
 import Class
 import CoreSyn
 import Type
+import NameEnv
 import Name
-import Module
 import Id
 import FastString
 import Outputable
@@ -29,177 +25,137 @@ import Outputable
 import Control.Monad
 import Data.Array
 
+
 -- |Create the initial map of builtin types and functions.
 --
-initBuiltins :: PackageId  -- ^ package id the builtins are in, eg dph-common
-             -> DsM Builtins
-initBuiltins pkg
- = do mapM_ load dph_Orphans
-
-      -- From dph-common:Data.Array.Parallel.PArray.PData
-      --     PData is a type family that maps an element type onto the type
-      --     we use to hold an array of those elements.
-      pdataTyCon  <- externalTyCon  dph_PArray_PData  (fsLit "PData")
-
-      --     PR is a type class that holds the primitive operators we can 
-      --     apply to array data. Its functions take arrays in terms of PData types.
-      prClass           <- externalClass        dph_PArray_PData  (fsLit "PR")
-      let prTyCon     = classTyCon prClass
-          [prDataCon] = tyConDataCons prTyCon
-
-
-      -- From dph-common:Data.Array.Parallel.PArray.PRepr
-      preprTyCon  <- externalTyCon  dph_PArray_PRepr  (fsLit "PRepr")
-      paClass           <- externalClass        dph_PArray_PRepr  (fsLit "PA")
-      let paTyCon     = classTyCon paClass
-          [paDataCon] = tyConDataCons paTyCon
-          paPRSel     = classSCSelId paClass 0
-
-      replicatePDVar    <- externalVar          dph_PArray_PRepr  (fsLit "replicatePD")
-      emptyPDVar        <- externalVar          dph_PArray_PRepr  (fsLit "emptyPD")
-      packByTagPDVar    <- externalVar          dph_PArray_PRepr  (fsLit "packByTagPD")
-      combines    <- mapM (externalVar dph_PArray_PRepr)
-                          [mkFastString ("combine" ++ show i ++ "PD")
-                              | i <- [2..mAX_DPH_COMBINE]]
-
-      let combinePDVars = listArray (2, mAX_DPH_COMBINE) combines
-
-
-      -- From dph-common:Data.Array.Parallel.PArray.Scalar
-      --     Scalar is the class of scalar values. 
-      --     The dictionary contains functions to coerce U.Arrays of scalars
-      --     to and from the PData representation.
-      scalarClass   <- externalClass        dph_PArray_Scalar (fsLit "Scalar")
-
-
-      -- From dph-common:Data.Array.Parallel.Lifted.PArray
-      --   A PArray (Parallel Array) holds the array length and some array elements
-      --   represented by the PData type family.
-      parrayTyCon <- externalTyCon  dph_PArray_Base   (fsLit "PArray")
-      let [parrayDataCon] = tyConDataCons parrayTyCon
-
-      -- From dph-common:Data.Array.Parallel.PArray.Types
-      voidTyCon   <- externalTyCon        dph_PArray_Types  (fsLit "Void")
-      voidVar     <- externalVar          dph_PArray_Types  (fsLit "void")
-      fromVoidVar <- externalVar          dph_PArray_Types  (fsLit "fromVoid")
-      wrapTyCon   <- externalTyCon        dph_PArray_Types  (fsLit "Wrap")
-      sum_tcs     <- mapM (externalTyCon  dph_PArray_Types) (numbered "Sum" 2 mAX_DPH_SUM)
-
-      -- from dph-common:Data.Array.Parallel.PArray.PDataInstances
-      pvoidVar          <- externalVar dph_PArray_PDataInstances  (fsLit "pvoid")
-      punitVar          <- externalVar dph_PArray_PDataInstances  (fsLit "punit")
-
-
-      closureTyCon  <- externalTyCon dph_Closure     (fsLit ":->")
-
-
-      -- From dph-common:Data.Array.Parallel.Lifted.Unboxed
-      sel_tys   <- mapM (externalType dph_Unboxed)
-                            (numbered "Sel" 2 mAX_DPH_SUM)
-
-      sel_replicates  <- mapM (externalFun dph_Unboxed)
-        (numbered_hash "replicateSel" 2 mAX_DPH_SUM)
-
-      sel_picks   <- mapM (externalFun dph_Unboxed)
-        (numbered_hash "pickSel" 2 mAX_DPH_SUM)
-
-      sel_tags    <- mapM (externalFun dph_Unboxed)
-        (numbered "tagsSel" 2 mAX_DPH_SUM)
-
-      sel_els   <- mapM mk_elements
-        [(i,j) | i <- [2..mAX_DPH_SUM], j <- [0..i-1]]
-
-
-      let selTys        = listArray (2, mAX_DPH_SUM) sel_tys
-          selReplicates = listArray (2, mAX_DPH_SUM) sel_replicates
-          selPicks      = listArray (2, mAX_DPH_SUM) sel_picks
-          selTagss      = listArray (2, mAX_DPH_SUM) sel_tags
-          selEls        = array     ((2,0), (mAX_DPH_SUM, mAX_DPH_SUM)) sel_els
-          sumTyCons     = listArray (2, mAX_DPH_SUM) sum_tcs
-
-
-
-      closureVar       <- externalVar dph_Closure (fsLit "closure")
-      applyVar         <- externalVar dph_Closure (fsLit "$:")
-      liftedClosureVar <- externalVar dph_Closure (fsLit "liftedClosure")
-      liftedApplyVar   <- externalVar dph_Closure (fsLit "liftedApply")
-
-      scalar_map  <- externalVar  dph_Scalar  (fsLit "scalar_map")
-      scalar_zip2   <- externalVar  dph_Scalar  (fsLit "scalar_zipWith")
-      scalar_zips <- mapM (externalVar dph_Scalar)
-                            (numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS)
-
-      let scalarZips  = listArray (1, mAX_DPH_SCALAR_ARGS)
-                                 (scalar_map : scalar_zip2 : scalar_zips)
-
-      closures    <- mapM (externalVar dph_Closure)
-                          (numbered "closure" 1 mAX_DPH_SCALAR_ARGS)
-
-      let closureCtrFuns = listArray (1, mAX_DPH_COMBINE) closures
-
-      liftingContext  <- liftM (\u -> mkSysLocal (fsLit "lc") u intPrimTy)
-        newUnique
-
-      return   $ Builtins 
-               { dphModules       = mods
-               , parrayTyCon      = parrayTyCon
-               , parrayDataCon    = parrayDataCon
-               , pdataTyCon       = pdataTyCon
-               , paClass          = paClass
-               , paTyCon          = paTyCon
-               , paDataCon        = paDataCon
-               , paPRSel          = paPRSel
-               , preprTyCon       = preprTyCon
-               , prClass          = prClass
-               , prTyCon          = prTyCon
-               , prDataCon        = prDataCon
-               , voidTyCon        = voidTyCon
-               , wrapTyCon        = wrapTyCon
-               , selTys           = selTys
-               , selReplicates    = selReplicates
-               , selPicks         = selPicks
-               , selTagss         = selTagss
-               , selEls           = selEls
-               , sumTyCons        = sumTyCons
-               , closureTyCon     = closureTyCon
-               , voidVar          = voidVar
-               , pvoidVar         = pvoidVar
-               , fromVoidVar      = fromVoidVar
-               , punitVar         = punitVar
-               , closureVar       = closureVar
-               , applyVar         = applyVar
-               , liftedClosureVar = liftedClosureVar
-               , liftedApplyVar   = liftedApplyVar
-               , replicatePDVar   = replicatePDVar
-               , emptyPDVar       = emptyPDVar
-               , packByTagPDVar   = packByTagPDVar
-               , combinePDVars    = combinePDVars
-               , scalarClass      = scalarClass
-               , scalarZips       = scalarZips
-               , closureCtrFuns   = closureCtrFuns
-               , liftingContext   = liftingContext
+initBuiltins :: DsM Builtins
+initBuiltins
+ = do { assertDAPPLoaded      -- complain if 'Data.Array.Parallel.Prim' is not available
+
+          -- 'PArray': desugared array type
+      ; parrayTyCon <- externalTyCon (fsLit "PArray")
+      ; parray_tcs  <- mapM externalTyCon (suffixed "PArray" aLL_DPH_PRIM_TYCONS)
+      ; let parray_PrimTyCons = mkNameEnv (zip aLL_DPH_PRIM_TYCONS parray_tcs)
+
+          -- 'PData': type family mapping array element types to array representation types
+      ; pdataTyCon <- externalTyCon (fsLit "PData")
+
+          -- 'PR': class of basic array operators operating on 'PData' types
+      ; prClass <- externalClass (fsLit "PR")
+      ; let prTyCon     = classTyCon prClass
+
+          -- 'PRepr': type family mapping element types to representation types
+      ; preprTyCon  <- externalTyCon (fsLit "PRepr")
+
+          -- 'PA': class of basic operations on arrays (parametrised by the element type)
+      ; paClass <- externalClass (fsLit "PA")
+      ; let paTyCon     = classTyCon paClass
+            [paDataCon] = tyConDataCons paTyCon
+            paPRSel     = classSCSelId paClass 0
+
+          -- Functions on array representations
+      ; replicatePDVar <- externalVar (fsLit "replicatePD")
+      ; replicate_vars <- mapM externalVar (suffixed "replicatePA" aLL_DPH_PRIM_TYCONS)
+      ; emptyPDVar     <- externalVar (fsLit "emptyPD")
+      ; empty_vars     <- mapM externalVar (suffixed "emptyPA" aLL_DPH_PRIM_TYCONS)
+      ; packByTagPDVar <- externalVar (fsLit "packByTagPD")
+      ; packByTag_vars <- mapM externalVar (suffixed "packByTagPA" aLL_DPH_PRIM_TYCONS)
+      ; let combineNamesD = [("combine" ++ show i ++ "PD") | i <- [2..mAX_DPH_COMBINE]]
+      ; let combineNamesA = [("combine" ++ show i ++ "PA") | i <- [2..mAX_DPH_COMBINE]]
+      ; combines       <- mapM externalVar (map mkFastString combineNamesD)
+      ; combines_vars  <- mapM (mapM externalVar) $
+                            map (\name -> suffixed name aLL_DPH_PRIM_TYCONS) combineNamesA
+      ; let replicatePD_PrimVars = mkNameEnv (zip aLL_DPH_PRIM_TYCONS replicate_vars)
+            emptyPD_PrimVars     = mkNameEnv (zip aLL_DPH_PRIM_TYCONS empty_vars)
+            packByTagPD_PrimVars = mkNameEnv (zip aLL_DPH_PRIM_TYCONS packByTag_vars)
+            combinePDVars        = listArray (2, mAX_DPH_COMBINE) combines
+            combinePD_PrimVarss  = listArray (2, mAX_DPH_COMBINE)
+                                     [ mkNameEnv (zip aLL_DPH_PRIM_TYCONS vars)
+                                     | vars <- combines_vars]
+
+          -- 'Scalar': class moving between plain unboxed arrays and 'PData' representations
+      ; scalarClass <- externalClass (fsLit "Scalar")
+
+          -- N-ary maps ('zipWith' family)
+      ; scalar_map  <- externalVar (fsLit "scalar_map")
+      ; scalar_zip2 <- externalVar (fsLit "scalar_zipWith")
+      ; scalar_zips <- mapM externalVar (numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS)
+      ; let scalarZips = listArray (1, mAX_DPH_SCALAR_ARGS) (scalar_map : scalar_zip2 : scalar_zips)
+
+          -- Types and functions for generic type representations
+      ; voidTyCon   <- externalTyCon (fsLit "Void")
+      ; voidVar     <- externalVar (fsLit "void")
+      ; fromVoidVar <- externalVar (fsLit "fromVoid")
+      ; sum_tcs     <- mapM externalTyCon (numbered "Sum" 2 mAX_DPH_SUM)
+      ; let sumTyCons = listArray (2, mAX_DPH_SUM) sum_tcs
+      ; wrapTyCon   <- externalTyCon (fsLit "Wrap")
+      ; pvoidVar    <- externalVar (fsLit "pvoid")
+
+          -- Types and functions for closure conversion
+      ; closureTyCon     <- externalTyCon (fsLit ":->")
+      ; closureVar       <- externalVar (fsLit "closure")
+      ; liftedClosureVar <- externalVar (fsLit "liftedClosure")
+      ; applyVar         <- externalVar (fsLit "$:")
+      ; liftedApplyVar   <- externalVar (fsLit "liftedApply")
+      ; closures         <- mapM externalVar (numbered "closure" 1 mAX_DPH_SCALAR_ARGS)
+      ; let closureCtrFuns = listArray (1, mAX_DPH_COMBINE) closures
+
+          -- Types and functions for selectors
+      ; sel_tys        <- mapM externalType (numbered "Sel" 2 mAX_DPH_SUM)
+      ; sel_replicates <- mapM externalFun (numbered_hash "replicateSel" 2 mAX_DPH_SUM)
+      ; sel_tags       <- mapM externalFun (numbered "tagsSel" 2 mAX_DPH_SUM)
+      ; sel_elements   <- mapM mk_elements [(i,j) | i <- [2..mAX_DPH_SUM], j <- [0..i-1]]
+      ; let selTys        = listArray (2, mAX_DPH_SUM) sel_tys
+            selReplicates = listArray (2, mAX_DPH_SUM) sel_replicates
+            selTagss      = listArray (2, mAX_DPH_SUM) sel_tags
+            selElementss  = array     ((2, 0), (mAX_DPH_SUM, mAX_DPH_SUM)) sel_elements
+
+          -- Distinct local variable
+      ; liftingContext  <- liftM (\u -> mkSysLocal (fsLit "lc") u intPrimTy) newUnique
+
+      ; return $ Builtins 
+               { parrayTyCon          = parrayTyCon
+               , parray_PrimTyCons    = parray_PrimTyCons
+               , pdataTyCon           = pdataTyCon
+               , preprTyCon           = preprTyCon
+               , prClass              = prClass
+               , prTyCon              = prTyCon
+               , paClass              = paClass
+               , paTyCon              = paTyCon
+               , paDataCon            = paDataCon
+               , paPRSel              = paPRSel
+               , replicatePDVar       = replicatePDVar
+               , replicatePD_PrimVars = replicatePD_PrimVars
+               , emptyPDVar           = emptyPDVar
+               , emptyPD_PrimVars     = emptyPD_PrimVars
+               , packByTagPDVar       = packByTagPDVar
+               , packByTagPD_PrimVars = packByTagPD_PrimVars
+               , combinePDVars        = combinePDVars
+               , combinePD_PrimVarss  = combinePD_PrimVarss
+               , scalarClass          = scalarClass
+               , scalarZips           = scalarZips
+               , voidTyCon            = voidTyCon
+               , voidVar              = voidVar
+               , fromVoidVar          = fromVoidVar
+               , sumTyCons            = sumTyCons
+               , wrapTyCon            = wrapTyCon
+               , pvoidVar             = pvoidVar
+               , closureTyCon         = closureTyCon
+               , closureVar           = closureVar
+               , liftedClosureVar     = liftedClosureVar
+               , applyVar             = applyVar
+               , liftedApplyVar       = liftedApplyVar
+               , closureCtrFuns       = closureCtrFuns
+               , selTys               = selTys
+               , selReplicates        = selReplicates
+               , selTagss             = selTagss
+               , selElementss         = selElementss
+               , liftingContext       = liftingContext
                }
+      }
   where
-    -- Extract out all the modules we'll use.
-    -- These are the modules from the DPH base library that contain
-    --  the primitive array types and functions that vectorised code uses.
-    mods@(Modules 
-                { dph_PArray_Base               = dph_PArray_Base
-                , dph_PArray_Scalar             = dph_PArray_Scalar
-                , dph_PArray_PRepr              = dph_PArray_PRepr
-                , dph_PArray_PData              = dph_PArray_PData
-                , dph_PArray_PDataInstances     = dph_PArray_PDataInstances
-                , dph_PArray_Types              = dph_PArray_Types
-                , dph_Closure                   = dph_Closure
-                , dph_Scalar                    = dph_Scalar
-                , dph_Unboxed                   = dph_Unboxed
-                })
-      = dph_Modules pkg
-
-    load get_mod = dsLoadModule doc mod
-      where
-        mod = get_mod mods 
-        doc = ppr mod <+> ptext (sLit "is a DPH module")
+    suffixed :: String -> [Name] -> [FastString]
+    suffixed pfx ns = [mkFastString (pfx ++ "_" ++ (occNameString . nameOccName) n) | n <- ns]
 
     -- Make a list of numbered strings in some range, eg foo3, foo4, foo5
     numbered :: String -> Int -> Int -> [FastString]
@@ -210,33 +166,33 @@ initBuiltins pkg
 
     mk_elements :: (Int, Int) -> DsM ((Int, Int), CoreExpr)
     mk_elements (i,j)
-      = do
-          v <- externalVar dph_Unboxed
-             $ mkFastString ("elementsSel" ++ show i ++ "_" ++ show j ++ "#")
-          return ((i,j), Var v)
+      = do { v <- externalVar $ mkFastString ("elementsSel" ++ show i ++ "_" ++ show j ++ "#")
+           ; return ((i, j), Var v)
+           }
 
--- | Get the mapping of names in the Prelude to names in the DPH library.
+-- |Get the mapping of names in the Prelude to names in the DPH library.
 --
 initBuiltinVars :: Builtins -> DsM [(Var, Var)]
-initBuiltinVars (Builtins { dphModules = mods })
+-- FIXME: must be replaced by VECTORISE pragmas!!!
+initBuiltinVars (Builtins { })
   = do
-      cvars <- zipWithM externalVar cmods cfs
+      cvars <- mapM externalVar cfs
       return $ zip (map dataConWorkId cons) cvars
   where
-    (cons, cmods, cfs) = unzip3 (preludeDataCons mods)
+    (cons, cfs) = unzip preludeDataCons
 
-    preludeDataCons :: Modules -> [(DataCon, Module, FastString)]
-    preludeDataCons (Modules { dph_Prelude_Tuple = dph_Prelude_Tuple })
-      = [mk_tup n dph_Prelude_Tuple (mkFastString $ "tup" ++ show n) | n <- [2..3]]
+    preludeDataCons :: [(DataCon, FastString)]
+    preludeDataCons
+      = [mk_tup n (mkFastString $ "tup" ++ show n) | n <- [2..3]]
       where
-        mk_tup n mod name = (tupleCon BoxedTuple n, mod, name)
+        mk_tup n name = (tupleCon BoxedTuple n, name)
 
 -- |Get a list of names to `TyCon`s in the mock prelude.
 --
 initBuiltinTyCons :: Builtins -> DsM [(Name, TyCon)]
+-- FIXME: must be replaced by VECTORISE pragmas!!!
 initBuiltinTyCons bi
   = do
-      -- parr <- externalTyCon dph_Prelude_PArr (fsLit "PArr")
       return $ (tyConName funTyCon, closureTyCon bi)
              : (parrTyConName,      parrayTyCon bi)
 
@@ -244,57 +200,39 @@ initBuiltinTyCons bi
              : (tyConName $ parrayTyCon bi, parrayTyCon bi)
              : []
 
--- |Get the names of all buildin instance functions for the PA class.
---
-initBuiltinPAs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)]
-initBuiltinPAs (Builtins { dphModules = mods }) insts
-  = liftM (initBuiltinDicts insts) (externalClass (dph_PArray_PRepr mods) (fsLit "PA"))
-
--- |Get the names of all builtin instance functions for the PR class.
---
-initBuiltinPRs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)]
-initBuiltinPRs (Builtins { dphModules = mods }) insts
-  = liftM (initBuiltinDicts insts) (externalClass (dph_PArray_PData mods) (fsLit "PR"))
-
--- |Get the names of all DPH instance functions for this class.
---
-initBuiltinDicts :: (InstEnv, InstEnv) -> Class -> [(Name, Var)]
-initBuiltinDicts insts cls = map find $ classInstances insts cls
-  where
-    find i | [Just tc] <- instanceRoughTcs i = (tc, instanceDFunId i)
-           | otherwise                       = pprPanic "Invalid DPH instance" (ppr i)
-
 
 -- Auxilliary look up functions ----------------
 
--- Lookup some variable given its name and the module that contains it.
+-- Lookup a variable given its name and the module that contains it.
 --
-externalVar :: Module -> FastString -> DsM Var
-externalVar mod fs
-  = dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs)
+externalVar :: FastString -> DsM Var
+externalVar fs = lookupDAPPRdrEnv (mkVarOccFS fs) >>= dsImportId
 
 -- Like `externalVar` but wrap the `Var` in a `CoreExpr`.
 --
-externalFun :: Module -> FastString -> DsM CoreExpr
-externalFun mod fs
- = do var <- externalVar mod fs
-      return $ Var var
+externalFun :: FastString -> DsM CoreExpr
+externalFun fs = liftM Var $ externalVar fs
 
--- Lookup some `TyCon` given its name and the module that contains it.
+-- Lookup a 'TyCon' in 'Data.Array.Parallel.Prim', given its name.
 --
-externalTyCon :: Module -> FastString -> DsM TyCon
-externalTyCon mod fs
-  = dsLookupTyCon =<< lookupOrig mod (mkTcOccFS fs)
+externalTyCon :: FastString -> DsM TyCon
+externalTyCon fs = lookupDAPPRdrEnv (mkTcOccFS fs) >>= dsImportTyCon
 
 -- Lookup some `Type` given its name and the module that contains it.
 --
-externalType :: Module -> FastString -> DsM Type
-externalType mod fs
- = do  tycon <- externalTyCon mod fs
+externalType :: FastString -> DsM Type
+externalType fs
+ = do  tycon <- externalTyCon fs
        return $ mkTyConApp tycon []
 
--- Lookup some `Class` given its name and the module that contains it.
+-- Lookup a 'Class' in 'Data.Array.Parallel.Prim', given its name.
 --
-externalClass :: Module -> FastString -> DsM Class
-externalClass mod fs
-  = fmap (maybe (panic "externalClass") id . tyConClass_maybe) $ dsLookupTyCon =<< lookupOrig mod (mkClsOccFS fs)
+externalClass :: FastString -> DsM Class
+externalClass fs 
+  = do { tycon <- lookupDAPPRdrEnv (mkClsOccFS fs) >>= dsImportTyCon
+       ; case tyConClass_maybe tycon of
+           Nothing  -> pprPanic "Vectorise.Builtins.Initialise" $ 
+                         ptext (sLit "Data.Array.Parallel.Prim.") <> 
+                         ftext fs <+> ptext (sLit "is not a type class")
+           Just cls -> return cls
+       }
diff --git a/compiler/vectorise/Vectorise/Builtins/Modules.hs b/compiler/vectorise/Vectorise/Builtins/Modules.hs
deleted file mode 100644 (file)
index af74f80..0000000
+++ /dev/null
@@ -1,60 +0,0 @@
-
--- | Modules that contain builtin functions used by the vectoriser.
-module Vectorise.Builtins.Modules
-       ( Modules(..)
-       , dph_Modules
-       , dph_Orphans)
-where
-import Module
-import FastString
-       
--- | Ids of the modules that contain our DPH builtins.
-data Modules 
-  = Modules 
-  { dph_PArray_Base             :: Module
-  , dph_PArray_Scalar           :: Module
-  , dph_PArray_ScalarInstances  :: Module
-  , dph_PArray_PRepr            :: Module
-  , dph_PArray_PReprInstances   :: Module
-  , dph_PArray_PData            :: Module
-  , dph_PArray_PDataInstances   :: Module
-  , dph_PArray_Types            :: Module
-       
-  , dph_Closure                        :: Module
-  , dph_Unboxed                        :: Module
-  , dph_Scalar                 :: Module
-
-  , dph_Prelude_Tuple           :: Module
-  }
-
-
--- | The locations of builtins in the current DPH library.
-dph_Modules :: PackageId -> Modules
-dph_Modules pkg 
-  = Modules 
-  { dph_PArray_Base             = mk (fsLit "Data.Array.Parallel.PArray.Base")
-  , dph_PArray_Scalar           = mk (fsLit "Data.Array.Parallel.PArray.Scalar")
-  , dph_PArray_ScalarInstances  = mk (fsLit "Data.Array.Parallel.PArray.ScalarInstances")
-  , dph_PArray_PRepr            = mk (fsLit "Data.Array.Parallel.PArray.PRepr")
-  , dph_PArray_PReprInstances   = mk (fsLit "Data.Array.Parallel.PArray.PReprInstances")
-  , dph_PArray_PData            = mk (fsLit "Data.Array.Parallel.PArray.PData")
-  , dph_PArray_PDataInstances   = mk (fsLit "Data.Array.Parallel.PArray.PDataInstances")
-  , dph_PArray_Types            = mk (fsLit "Data.Array.Parallel.PArray.Types")
-       
-  , dph_Closure                 = mk (fsLit "Data.Array.Parallel.Lifted.Closure")
-  , dph_Unboxed                 = mk (fsLit "Data.Array.Parallel.Lifted.Unboxed")
-  , dph_Scalar                  = mk (fsLit "Data.Array.Parallel.Lifted.Scalar")
-
-  , dph_Prelude_Tuple           = mk (fsLit "Data.Array.Parallel.Prelude.Tuple")
-  }
-  where        mk = mkModule pkg . mkModuleNameFS
-
-
-dph_Orphans :: [Modules -> Module]
-dph_Orphans
- = [ dph_PArray_Scalar
-   , dph_PArray_ScalarInstances
-   , dph_PArray_PReprInstances
-   , dph_PArray_PDataInstances
-   , dph_Scalar
-   ]
index a7578e4..465d58c 100644 (file)
@@ -12,7 +12,7 @@ module Vectorise.Env (
   setFamEnv,
   extendFamEnv,
   extendTyConsEnv,
-  extendPAFunsEnv,
+  setPAFunsEnv,
   setPRFunsEnv,
   modVectInfo
 ) where
@@ -134,7 +134,7 @@ initGlobalEnv info vectDecls instEnvs famInstEnvs
   , global_novect_vars          = mkVarSet novects
   , global_tycons               = mapNameEnv snd $ vectInfoTyCon info
   , global_datacons             = mapNameEnv snd $ vectInfoDataCon info
-  , global_pa_funs              = mapNameEnv snd $ vectInfoPADFun info
+  , global_pa_funs              = emptyNameEnv
   , global_pr_funs              = emptyNameEnv
   , global_inst_env             = instEnvs
   , global_fam_inst_env         = famInstEnvs
@@ -179,17 +179,15 @@ extendTyConsEnv :: [(Name, TyCon)] -> GlobalEnv -> GlobalEnv
 extendTyConsEnv ps genv
   = genv { global_tycons = extendNameEnvList (global_tycons genv) ps }
 
--- |Extend the list of PA functions in an environment.
+-- |Set the list of PA functions in an environment.
 --
-extendPAFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
-extendPAFunsEnv ps genv
-  = genv { global_pa_funs = extendNameEnvList (global_pa_funs genv) ps }
+setPAFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
+setPAFunsEnv ps genv = genv { global_pa_funs = mkNameEnv ps }
 
 -- |Set the list of PR functions in an environment.
 --
 setPRFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
-setPRFunsEnv ps genv
-  = genv { global_pr_funs = mkNameEnv ps }
+setPRFunsEnv ps genv = genv { global_pr_funs = mkNameEnv ps }
 
 -- |Compute vectorisation information that goes into 'ModGuts' (and is stored in interface files).
 -- The incoming 'vectInfo' is that from the 'HscEnv' and 'EPS'.  The outgoing one contains only the
@@ -197,13 +195,12 @@ setPRFunsEnv ps genv
 -- data constructors referenced in VECTORISE pragmas, even if they are defined in an imported
 -- module.
 --
-modVectInfo :: GlobalEnv -> [TyCon] -> [CoreVect]-> VectInfo -> VectInfo
-modVectInfo env tycons vectDecls info
+modVectInfo :: GlobalEnv -> [Id] -> [TyCon] -> [CoreVect]-> VectInfo -> VectInfo
+modVectInfo env mg_ids mg_tyCons vectDecls info
   = info 
     { vectInfoVar          = mk_env ids      (global_vars     env)
     , vectInfoTyCon        = mk_env tyCons   (global_tycons   env)
     , vectInfoDataCon      = mk_env dataCons (global_datacons env)
-    , vectInfoPADFun       = mk_env tyCons   (global_pa_funs  env)
     , vectInfoScalarVars   = global_scalar_vars   env `minusVarSet`  vectInfoScalarVars   info
     , vectInfoScalarTyCons = global_scalar_tycons env `minusNameSet` vectInfoScalarTyCons info
     }
@@ -211,10 +208,9 @@ modVectInfo env tycons vectDecls info
     vectIds        = [id    | Vect     id    _   <- vectDecls]
     vectTypeTyCons = [tycon | VectType _ tycon _ <- vectDecls]
     vectDataCons   = concatMap tyConDataCons vectTypeTyCons
-    ids            = {- typeEnvIds      tyenv ++ -} vectIds
-                     -- XXX: what Ids do you want here?
-    tyCons         = tycons ++ vectTypeTyCons
-    dataCons       = concatMap tyConDataCons tycons ++ vectDataCons
+    ids            = mg_ids ++ vectIds
+    tyCons         = mg_tyCons ++ vectTypeTyCons
+    dataCons       = concatMap tyConDataCons mg_tyCons ++ vectDataCons
     
     -- Produce an entry for every declaration that is mentioned in the domain of the 'inspectedEnv'
     mk_env decls inspectedEnv
index cef46fd..eaf0c1f 100644 (file)
@@ -1,4 +1,3 @@
-
 module Vectorise.Monad (
   module Vectorise.Monad.Base,
   module Vectorise.Monad.Naming,
@@ -17,10 +16,6 @@ module Vectorise.Monad (
   maybeCantVectoriseVarM,
   dumpVar,
   addGlobalScalar, 
-    
-  -- * Primitives
-  lookupPrimPArray,
-  lookupPrimMethod
 ) where
 
 import Vectorise.Monad.Base
@@ -31,22 +26,25 @@ import Vectorise.Monad.InstEnv
 import Vectorise.Builtins
 import Vectorise.Env
 
+import CoreSyn
+import DsMonad
 import HscTypes hiding ( MonadThings(..) )
 import DynFlags
 import MonadUtils (liftIO)
-import TyCon
+import InstEnv
+import Class
 import VarSet
 import VarEnv
 import Var
 import Id
-import DsMonad
+import Name
 import ErrUtils
 import Outputable
-import FastString
 
 import Control.Monad
 import System.IO
 
+
 -- |Run a vectorisation computation.
 --
 initV :: HscEnv
@@ -56,8 +54,7 @@ initV :: HscEnv
       -> IO (Maybe (VectInfo, a))
 initV hsc_env guts info thing_inside
   = do {
-         let type_env = typeEnvFromEntities [] (mg_tcs guts) (mg_clss guts) (mg_fam_insts guts)
-                        -- XXX should we try to get the Ids here?
+         let type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_clss guts) (mg_fam_insts guts)
        ; (_, Just res) <- initDs hsc_env (mg_module guts)
                                          (mg_rdr_env guts) type_env go
 
@@ -72,16 +69,15 @@ initV hsc_env guts info thing_inside
        }
   where
     dumpIfVtTrace = dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_vt_trace
+    
+    bindsToIds (NonRec v _)   = [v]
+    bindsToIds (Rec    binds) = map fst binds
+    
+    ids = concatMap bindsToIds (mg_binds guts)
 
     go 
-      = do {   -- pick a DPH backend
-           ; dflags <- getDOptsDs
-           ; case dphPackageMaybe dflags of
-               Nothing  -> failWithDs $ ptext selectBackendErr
-               Just pkg -> do {
-
-               -- set up tables of builtin entities
-           ; builtins        <- initBuiltins pkg
+      = do {   -- set up tables of builtin entities
+           ; builtins        <- initBuiltins
            ; builtin_vars    <- initBuiltinVars builtins
            ; builtin_tycons  <- initBuiltinTyCons builtins
 
@@ -89,14 +85,14 @@ initV hsc_env guts info thing_inside
            ; eps <- liftIO $ hscEPS hsc_env
            ; let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
                  instEnvs    = (eps_inst_env     eps, mg_inst_env     guts)
-           ; builtin_prs <- initBuiltinPRs builtins instEnvs
-           ; builtin_pas <- initBuiltinPAs builtins instEnvs
+                 builtin_pas = initClassDicts instEnvs (paClass builtins) -- grab all available 'PA' and..
+                 builtin_prs = initClassDicts instEnvs (prClass builtins) -- ..'PR' class instances
 
                -- construct the initial global environment
            ; let thing_inside' = traceVt "VectDecls" (ppr (mg_vect_decls guts)) >> thing_inside
            ; let genv = extendImportedVarsEnv builtin_vars
                         . extendTyConsEnv     builtin_tycons
-                        . extendPAFunsEnv     builtin_pas
+                        . setPAFunsEnv        builtin_pas
                         . setPRFunsEnv        builtin_prs
                         $ initGlobalEnv info (mg_vect_decls guts) instEnvs famInstEnvs
  
@@ -110,24 +106,37 @@ initV hsc_env guts info thing_inside
                                         mkDumpDoc "Warning: vectorisation failure:" reason
                                   ; return Nothing
                                   }
-           } }
+           }
+
+    new_info genv = modVectInfo genv ids (mg_tcs guts) (mg_vect_decls guts) info
 
-    new_info genv = modVectInfo genv (mg_tcs guts) (mg_vect_decls guts) info
+    -- For a given DPH class, produce a mapping from type constructor (in head position) to the instance
+    -- dfun for that type constructor and class.  (DPH class instances cannot overlap in head
+    -- constructors.)
+    --
+    initClassDicts :: (InstEnv, InstEnv) -> Class -> [(Name, Var)]
+    initClassDicts insts cls = map find $ classInstances insts cls
+      where
+        find i | [Just tc] <- instanceRoughTcs i = (tc, instanceDFunId i)
+               | otherwise                       = pprPanic invalidInstance (ppr i)
+
+    invalidInstance = "Invalid DPH instance (overlapping in head constructor)"
 
-    selectBackendErr = sLit "To use -fvectorise select a DPH backend with -fdph-par or -fdph-seq"
 
 -- Builtins -------------------------------------------------------------------
--- | Lift a desugaring computation using the `Builtins` into the vectorisation monad.
+
+-- |Lift a desugaring computation using the `Builtins` into the vectorisation monad.
+--
 liftBuiltinDs :: (Builtins -> DsM a) -> VM a
 liftBuiltinDs p = VM $ \bi genv lenv -> do { x <- p bi; return (Yes genv lenv x)}
 
-
--- | Project something from the set of builtins.
+-- |Project something from the set of builtins.
+--
 builtin :: (Builtins -> a) -> VM a
 builtin f = VM $ \bi genv lenv -> return (Yes genv lenv (f bi))
 
-
--- | Lift a function using the `Builtins` into the vectorisation monad.
+-- |Lift a function using the `Builtins` into the vectorisation monad.
+--
 builtins :: (a -> Builtins -> b) -> VM (a -> b)
 builtins f = VM $ \bi genv lenv -> return (Yes genv lenv (`f` bi))
 
@@ -174,13 +183,3 @@ addGlobalScalar var
   = do { traceVt "addGlobalScalar" (ppr var)
        ; updGEnv $ \env -> env{global_scalar_vars = extendVarSet (global_scalar_vars env) var}
        }
-
-
--- Primitives -----------------------------------------------------------------
-
-lookupPrimPArray :: TyCon -> VM (Maybe TyCon)
-lookupPrimPArray = liftBuiltinDs . primPArray
-
-lookupPrimMethod :: TyCon -> String -> VM (Maybe Var)
-lookupPrimMethod tycon = liftBuiltinDs . primMethod tycon
-
index 8dd0af7..255a6c5 100644 (file)
@@ -72,44 +72,44 @@ isAnnTypeArg _              = False
 -- |An empty array of the given type.
 --
 emptyPD :: Type -> VM CoreExpr
-emptyPD = paMethod emptyPDVar "emptyPD"
+emptyPD = paMethod emptyPDVar emptyPD_PrimVar
 
 -- |Produce an array containing copies of a given element.
 --
-replicatePD :: CoreExpr -- ^ Number of copies in the resulting array.
-            -> CoreExpr -- ^ Value to replicate.
+replicatePD :: CoreExpr     -- ^ Number of copies in the resulting array.
+            -> CoreExpr     -- ^ Value to replicate.
             -> VM CoreExpr
 replicatePD len x 
   = liftM (`mkApps` [len,x])
-        $ paMethod replicatePDVar "replicatePD" (exprType x)
+        $ paMethod replicatePDVar replicatePD_PrimVar (exprType x)
 
--- | Select some elements from an array that correspond to a particular tag value
----  and pack them into a new array.
---   eg  packByTagPD Int# [:23, 42, 95, 50, 27, 49:]  3 [:1, 2, 1, 2, 3, 2:] 2 
---          ==> [:42, 50, 49:]
+-- |Select some elements from an array that correspond to a particular tag value and pack them into a new
+-- array.
 --
-packByTagPD :: Type   -- ^ Element type.
-            -> CoreExpr -- ^ Source array.
-            -> CoreExpr -- ^ Length of resulting array.
-            -> CoreExpr -- ^ Tag values of elements in source array.
-            -> CoreExpr -- ^ The tag value for the elements to select.
+-- > packByTagPD Int# [:23, 42, 95, 50, 27, 49:]  3 [:1, 2, 1, 2, 3, 2:] 2 
+-- >   ==> [:42, 50, 49:]
+--
+packByTagPD :: Type       -- ^ Element type.
+            -> CoreExpr   -- ^ Source array.
+            -> CoreExpr   -- ^ Length of resulting array.
+            -> CoreExpr   -- ^ Tag values of elements in source array.
+            -> CoreExpr   -- ^ The tag value for the elements to select.
             -> VM CoreExpr
 packByTagPD ty xs len tags t
   = liftM (`mkApps` [xs, len, tags, t])
-          (paMethod packByTagPDVar "packByTagPD" ty)
+          (paMethod packByTagPDVar packByTagPD_PrimVar ty)
 
--- | Combine some arrays based on a selector.
---     The selector says which source array to choose for each element of the
---     resulting array.
+-- |Combine some arrays based on a selector.  The selector says which source array to choose for each
+-- element of the resulting array.
 --
-combinePD :: Type   -- ^ Element type
-          -> CoreExpr -- ^ Length of resulting array
-          -> CoreExpr -- ^ Selector.
-          -> [CoreExpr] -- ^ Arrays to combine.
+combinePD :: Type         -- ^ Element type
+          -> CoreExpr     -- ^ Length of resulting array
+          -> CoreExpr     -- ^ Selector.
+          -> [CoreExpr]   -- ^ Arrays to combine.
           -> VM CoreExpr
 combinePD ty len sel xs
   = liftM (`mkApps` (len : sel : xs))
-          (paMethod (combinePDVar n) ("combine" ++ show n ++ "PD") ty)
+          (paMethod (combinePDVar n) (combinePD_PrimVar n) ty)
   where
     n = length xs
 
index d41be1e..e87c7ca 100644 (file)
@@ -1,27 +1,26 @@
-
 module Vectorise.Utils.Base (
-       voidType,
-       newLocalVVar,
-
-       mkDataConTagLit,
-       mkDataConTag, dataConTagZ,
-       mkBuiltinTyConApp,
-       mkBuiltinTyConApps,
-       mkWrapType,
-       mkClosureTypes,
-       mkPReprType,
-       mkPArrayType, splitPrimTyCon,
-       mkPArray,
-       mkPDataType,
-       mkBuiltinCo,
-       mkVScrut,
-
-        preprSynTyCon,
-       pdataReprTyCon,
-       pdataReprDataCon,
-        prDFunOfTyCon
-)
-where
+  voidType,
+  newLocalVVar,
+
+  mkDataConTagLit,
+  mkDataConTag, dataConTagZ,
+  mkBuiltinTyConApp,
+  mkBuiltinTyConApps,
+  mkWrapType,
+  mkClosureTypes,
+  mkPReprType,
+  mkPArrayType, splitPrimTyCon,
+  mkPArray,
+  mkPDataType,
+  mkBuiltinCo,
+  mkVScrut,
+
+  preprSynTyCon,
+  pdataReprTyCon,
+  pdataReprDataCon,
+  prDFunOfTyCon
+) where
+
 import Vectorise.Monad
 import Vectorise.Vect
 import Vectorise.Builtins
@@ -96,24 +95,23 @@ mkPReprType :: Type -> VM Type
 mkPReprType ty = mkBuiltinTyConApp preprTyCon [ty]
 
 
------
+-- |Wrap a type into 'PArray', treating unboxed types specially.
+--
 mkPArrayType :: Type -> VM Type
 mkPArrayType ty
   | Just tycon <- splitPrimTyCon ty
-  = do
-      r <- lookupPrimPArray tycon
-      case r of
-        Just arr -> return $ mkTyConApp arr []
-        Nothing  -> cantVectorise "Primitive tycon not vectorised" (ppr tycon)
-
+  = do { arr <- builtin (parray_PrimTyCon tycon)
+       ; return $ mkTyConApp arr []
+       }
 mkPArrayType ty = mkBuiltinTyConApp parrayTyCon [ty]
 
+-- |Checks if a type constructor is defined in 'GHC.Prim' (e.g., 'Int#'); if so, returns it.
+--
 splitPrimTyCon :: Type -> Maybe TyCon
 splitPrimTyCon ty
   | Just (tycon, []) <- splitTyConApp_maybe ty
   , isPrimTyCon tycon
   = Just tycon
-
   | otherwise = Nothing
 
 
index 443850d..f3fe742 100644 (file)
@@ -1,13 +1,14 @@
+-- |Utils concerning closure construction and application.
 
--- | Utils concerning closure construction and application.
 module Vectorise.Utils.Closure (
-       mkClosure,
-       mkClosureApp,
-       buildClosure,
-       buildClosures,
-       buildEnv
+  mkClosure,
+  mkClosureApp,
+  buildClosure,
+  buildClosures,
+  buildEnv
 )
 where
+
 import Vectorise.Builtins
 import Vectorise.Vect
 import Vectorise.Monad
@@ -29,12 +30,12 @@ import FastString
 
 -- | Make a closure.
 mkClosure
-       :: Type         -- ^ Type of the argument.
-       -> Type         -- ^ Type of the result.
-       -> Type         -- ^ Type of the environment.
-       -> VExpr        -- ^ The function to apply.
-       -> VExpr        -- ^ The environment to use.
-       -> VM VExpr
+  :: Type   -- ^ Type of the argument.
+  -> Type   -- ^ Type of the result.
+  -> Type   -- ^ Type of the environment.
+  -> VExpr  -- ^ The function to apply.
+  -> VExpr  -- ^ The environment to use.
+  -> VM VExpr
 
 mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv)
  = do dict <- paDictOfType env_ty
@@ -46,11 +47,11 @@ mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv)
 
 -- | Make a closure application.
 mkClosureApp 
-       :: Type         -- ^ Type of the argument.
-       -> Type         -- ^ Type of the result.
-       -> VExpr        -- ^ Closure to apply.
-       -> VExpr        -- ^ Argument to use.
-       -> VM VExpr
+  :: Type   -- ^ Type of the argument.
+  -> Type   -- ^ Type of the result.
+  -> VExpr  -- ^ Closure to apply.
+  -> VExpr  -- ^ Argument to use.
+  -> VM VExpr
 
 mkClosureApp arg_ty res_ty (vclo, lclo) (varg, larg)
  = do vapply <- builtin applyVar
@@ -60,14 +61,13 @@ mkClosureApp arg_ty res_ty (vclo, lclo) (varg, larg)
               Var lapply `mkTyApps` [arg_ty, res_ty] `mkApps` [Var lc, lclo, larg])
 
 
-
 buildClosures 
-       :: [TyVar]
-       -> [VVar]
-       -> [Type]       -- ^ Type of the arguments.
-       -> Type         -- ^ Type of result.
-       -> VM VExpr
-       -> VM VExpr
+  :: [TyVar]
+  -> [VVar]
+  -> [Type] -- ^ Type of the arguments.
+  -> Type   -- ^ Type of result.
+  -> VM VExpr
+  -> VM VExpr
 
 buildClosures _   _    [] _ mk_body
  = mk_body
index 740a647..836a363 100644 (file)
@@ -1,12 +1,11 @@
-
 module Vectorise.Utils.PADict (
-       paDictArgType,
-       paDictOfType,
-       paMethod,
-        prDictOfReprType,
-        prDictOfPReprInstTyCon
-)
-where
+  paDictArgType,
+  paDictOfType,
+  paMethod,
+  prDictOfReprType,
+  prDictOfPReprInstTyCon
+) where
+
 import Vectorise.Monad
 import Vectorise.Builtins
 import Vectorise.Utils.Base
@@ -23,7 +22,7 @@ import FastString
 import Control.Monad
 
 
--- | Construct the PA argument type for the tyvar. For the tyvar (v :: *) it's
+-- |Construct the PA argument type for the tyvar. For the tyvar (v :: *) it's
 -- just PA v. For (v :: (* -> *) -> *) it's
 --
 -- > forall (a :: * -> *). (forall (b :: *). PA b -> PA (a b)) -> PA (v a)
@@ -50,7 +49,7 @@ paDictArgType tv = go (TyVarTy tv) (tyVarKind tv)
     go _ _ = return Nothing
 
 
--- | Get the PA dictionary for some type
+-- |Get the PA dictionary for some type
 --
 paDictOfType :: Type -> VM CoreExpr
 paDictOfType ty 
@@ -86,13 +85,12 @@ paDictOfType ty
 
     failure = cantVectorise "Can't construct PA dictionary for type" (ppr ty)
 
-paMethod :: (Builtins -> Var) -> String -> Type -> VM CoreExpr
-paMethod _ name ty
-  | Just tycon <- splitPrimTyCon ty
-  = liftM Var
-  . maybeCantVectoriseM "No PA method" (text name <+> text "for" <+> ppr tycon)
-  $ lookupPrimMethod tycon name
-
+-- |Produce code that refers to a method of the 'PA' class.
+--
+paMethod :: (Builtins -> Var) -> (TyCon -> Builtins -> Var) -> Type -> VM CoreExpr
+paMethod _ query ty
+  | Just tycon <- splitPrimTyCon ty             -- Is 'ty' from 'GHC.Prim' (e.g., 'Int#')?
+  = liftM Var $ builtin (query tycon)
 paMethod method _ ty
   = do
       fn   <- builtin method