vectorise: Put it out of its misery

Poor DPH and its vectoriser have long been languishing; sadly it seems there is
little chance that the effort will be rekindled. Every few years we discuss
what to do with this mass of code and at least once we have agreed that it
should be archived on a branch and removed from `master`. Here we do just that,
eliminating heaps of dead code in the process.

Here we drop the ParallelArrays extension, the vectoriser, and the `vector` and
`primitive` submodules.

Test Plan: Validate

Reviewers: simonpj, simonmar, hvr, goldfire, alanz

Reviewed By: simonmar

Subscribers: goldfire, rwbarton, thomie, mpickering, carter

Differential Revision: https://phabricator.haskell.org/D4761

1 files changed, 0 insertions, 358 deletions

diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs
deleted file mode 100644
index 0181c6cdd1..0000000000
--- a/compiler/vectorise/Vectorise.hs
+++ /dev/null
@@ -1,358 +0,0 @@
--- Main entry point to the vectoriser.  It is invoked iff the option '-fvectorise' is passed.
---
--- This module provides the function 'vectorise', which vectorises an entire (desugared) module.
--- It vectorises all type declarations and value bindings.  It also processes all VECTORISE pragmas
--- (aka vectorisation declarations), which can lead to the vectorisation of imported data types
--- and the enrichment of imported functions with vectorised versions.
-
-module Vectorise ( vectorise )
-where
-
-import GhcPrelude
-
-import Vectorise.Type.Env
-import Vectorise.Type.Type
-import Vectorise.Convert
-import Vectorise.Utils.Hoisting
-import Vectorise.Exp
-import Vectorise.Env
-import Vectorise.Monad
-
-import HscTypes hiding      ( MonadThings(..) )
-import CoreUnfold           ( mkInlineUnfoldingWithArity )
-import PprCore
-import CoreSyn
-import CoreMonad            ( CoreM, getHscEnv )
-import Type
-import Id
-import DynFlags
-import Outputable
-import Util                 ( zipLazy )
-import MonadUtils
-
-import Control.Monad
-
-
--- |Vectorise a single module.
---
-vectorise :: ModGuts -> CoreM ModGuts
-vectorise guts
- = do { hsc_env <- getHscEnv
-      ; liftIO $ vectoriseIO hsc_env guts
-      }
-
--- Vectorise a single monad, given the dynamic compiler flags and HscEnv.
---
-vectoriseIO :: HscEnv -> ModGuts -> IO ModGuts
-vectoriseIO hsc_env guts
- = do {   -- Get information about currently loaded external packages.
-      ; eps <- hscEPS hsc_env
-
-          -- Combine vectorisation info from the current module, and external ones.
-      ; let info = hptVectInfo hsc_env `plusVectInfo` eps_vect_info eps
-
-          -- Run the main VM computation.
-      ; Just (info', guts') <- initV hsc_env guts info (vectModule guts)
-      ; return (guts' { mg_vect_info = info' })
-      }
-
--- Vectorise a single module, in the VM monad.
---
-vectModule :: ModGuts -> VM ModGuts
-vectModule guts@(ModGuts { mg_tcs        = tycons
-                         , mg_binds      = binds
-                         , mg_fam_insts  = fam_insts
-                         , mg_vect_decls = vect_decls
-                         })
- = do { dumpOptVt Opt_D_dump_vt_trace "Before vectorisation" $
-          pprCoreBindings binds
-
-          -- Pick out all 'VECTORISE [SCALAR] type' and 'VECTORISE class' pragmas
-      ; let ty_vect_decls  = [vd | vd@(VectType _ _ _) <- vect_decls]
-            cls_vect_decls = [vd | vd@(VectClass _)    <- vect_decls]
-
-          -- Vectorise the type environment.  This will add vectorised
-          -- type constructors, their representations, and the
-          -- corresponding data constructors.  Moreover, we produce
-          -- bindings for dfuns and family instances of the classes
-          -- and type families used in the DPH library to represent
-          -- array types.
-      ; (new_tycons, new_fam_insts, tc_binds) <- vectTypeEnv tycons ty_vect_decls cls_vect_decls
-
-          -- Family instance environment for /all/ home-package modules including those instances
-          -- generated by 'vectTypeEnv'.
-      ; (_, fam_inst_env) <- readGEnv global_fam_inst_env
-
-          -- Vectorise all the top level bindings and VECTORISE declarations on imported identifiers
-          -- NB: Need to vectorise the imported bindings first (local bindings may depend on them).
-      ; let impBinds = [(imp_id, expr) | Vect imp_id expr <- vect_decls, isGlobalId imp_id]
-      ; binds_imp <- mapM vectImpBind impBinds
-      ; binds_top <- mapM vectTopBind binds
-
-      ; return $ guts { mg_tcs          = tycons ++ new_tycons
-                        -- we produce no new classes or instances, only new class type constructors
-                        -- and dfuns
-                      , mg_binds        = Rec tc_binds : (binds_top ++ binds_imp)
-                      , mg_fam_inst_env = fam_inst_env
-                      , mg_fam_insts    = fam_insts ++ new_fam_insts
-                      }
-      }
-
--- Try to vectorise a top-level binding.  If it doesn't vectorise, or if it is entirely scalar, then
--- omit vectorisation of that binding.
---
--- For example, for the binding
---
--- @
---    foo :: Int -> Int
---    foo = \x -> x + x
--- @
---
--- we get
--- @
---    foo  :: Int -> Int
---    foo  = \x -> vfoo $: x
---
---    v_foo :: Closure void vfoo lfoo
---    v_foo = closure vfoo lfoo void
---
---    vfoo :: Void -> Int -> Int
---    vfoo = ...
---
---    lfoo :: PData Void -> PData Int -> PData Int
---    lfoo = ...
--- @
---
--- @vfoo@ is the "vectorised", or scalar, version that does the same as the original function foo,
--- but takes an explicit environment.
---
--- @lfoo@ is the "lifted" version that works on arrays.
---
--- @v_foo@ combines both of these into a `Closure` that also contains the environment.
---
--- The original binding @foo@ is rewritten to call the vectorised version present in the closure.
---
--- Vectorisation may be suppressed by annotating a binding with a 'NOVECTORISE' pragma.  If this
--- pragma is used in a group of mutually recursive bindings, either all or no binding must have
--- the pragma.  If only some bindings are annotated, a fatal error is being raised. (In the case of
--- scalar bindings, we only omit vectorisation if all bindings in a group are scalar.)
---
--- FIXME: Once we support partial vectorisation, we may be able to vectorise parts of a group, or
---   we may emit a warning and refrain from vectorising the entire group.
---
-vectTopBind :: CoreBind -> VM CoreBind
-vectTopBind b@(NonRec var expr)
-  = do
-    { traceVt "= Vectorise non-recursive top-level variable" (ppr var)
-
-    ; (hasNoVect, vectDecl) <- lookupVectDecl var
-    ; if hasNoVect
-      then do
-      {   -- 'NOVECTORISE' pragma => leave this binding as it is
-      ; traceVt "NOVECTORISE" $ ppr var
-      ; return b
-      }
-      else do
-    { vectRhs <- case vectDecl of
-        Just (_, expr') ->
-            -- 'VECTORISE' pragma => just use the provided vectorised rhs
-          do
-          { traceVt "VECTORISE" $ ppr var
-          ; addGlobalParallelVar var
-          ; return $ Just (False, inlineMe, expr')
-          }
-        Nothing         ->
-            -- no pragma => standard vectorisation of rhs
-          do
-          { traceVt "[Vanilla]" $ ppr var <+> char '=' <+> ppr expr
-          ; vectTopExpr var expr
-          }
-    ; hs <- takeHoisted -- make sure we clean those out (even if we skip)
-    ; case vectRhs of
-      { Nothing ->
-          -- scalar binding => leave this binding as it is
-          do
-          { traceVt "scalar binding [skip]" $ ppr var
-          ; return b
-          }
-      ; Just (parBind, inline, expr') -> do
-    {
-       -- vanilla case => create an appropriate top-level binding & add it to the vectorisation map
-    ; when parBind $
-        addGlobalParallelVar var
-    ; var' <- vectTopBinder var inline expr'
-
-        -- We replace the original top-level binding by a value projected from the vectorised
-        -- closure and add any newly created hoisted top-level bindings.
-    ; cexpr <- tryConvert var var' expr
-    ; return . Rec $ (var, cexpr) : (var', expr') : hs
-    } } } }
-    `orElseErrV`
-    do
-    { emitVt "  Could NOT vectorise top-level binding" $ ppr var
-    ; return b
-    }
-vectTopBind b@(Rec binds)
-  = do
-    { traceVt "= Vectorise recursive top-level variables" $ ppr vars
-
-    ; vectDecls <- mapM lookupVectDecl vars
-    ; let hasNoVects = map fst vectDecls
-    ; if and hasNoVects
-      then do
-      {   -- 'NOVECTORISE' pragmas => leave this entire binding group as it is
-      ; traceVt "NOVECTORISE" $ ppr vars
-      ; return b
-      }
-      else do
-    { if or hasNoVects
-      then do
-        {   -- Inconsistent 'NOVECTORISE' pragmas => bail out
-        ; dflags <- getDynFlags
-        ; cantVectorise dflags noVectoriseErr (ppr b)
-        }
-      else do
-    { traceVt "[Vanilla]" $ vcat [ppr var <+> char '=' <+> ppr expr | (var, expr) <- binds]
-
-       -- For all bindings *with* a pragma, just use the pragma-supplied vectorised expression
-    ; newBindsWPragma  <- concat <$>
-                          sequence [ vectTopBindAndConvert bind inlineMe expr'
-                                   | (bind, (_, Just (_, expr'))) <- zip binds vectDecls]
-
-        -- Standard vectorisation of all rhses that are *without* a pragma.
-        -- NB: The reason for 'fixV' is rather subtle: 'vectTopBindAndConvert' adds entries for
-        --     the bound variables in the recursive group to the vectorisation map, which in turn
-        --     are needed by 'vectPolyExprs' (unless it returns 'Nothing').
-    ; let bindsWOPragma = [bind | (bind, (_, Nothing)) <- zip binds vectDecls]
-    ; (newBinds, _) <- fixV $
-        \ ~(_, exprs') ->
-          do
-          {   -- Create appropriate top-level bindings, enter them into the vectorisation map, and
-              -- vectorise the right-hand sides
-          ; newBindsWOPragma <- concat <$>
-                                sequence [vectTopBindAndConvert bind inline expr
-                                         | (bind, ~(inline, expr)) <- zipLazy bindsWOPragma exprs']
-                                         -- irrefutable pattern and 'zipLazy' to tie the knot;
-                                         -- hence, can't use 'zipWithM'
-          ; vectRhses <- vectTopExprs bindsWOPragma
-          ; hs <- takeHoisted -- make sure we clean those out (even if we skip)
-
-          ; case vectRhses of
-              Nothing ->
-                -- scalar bindings => skip all bindings except those with pragmas and retract the
-                --   entries into the vectorisation map for the scalar bindings
-                do
-                { traceVt "scalar bindings [skip]" $ ppr vars
-                ; mapM_ (undefGlobalVar . fst) bindsWOPragma
-                ; return (bindsWOPragma ++ newBindsWPragma, exprs')
-                }
-              Just (parBind, exprs') ->
-                -- vanilla case => record parallel variables and return the final bindings
-                do
-                { when parBind $
-                    mapM_ addGlobalParallelVar vars
-                ; return (newBindsWOPragma ++ newBindsWPragma ++ hs, exprs')
-                }
-          }
-    ; return $ Rec newBinds
-    } } }
-    `orElseErrV`
-    do
-    { emitVt "  Could NOT vectorise top-level bindings" $ ppr vars
-    ; return b
-    }
-  where
-    vars = map fst binds
-    noVectoriseErr = "NOVECTORISE must be used on all or no bindings of a recursive group"
-
-    -- Replace the original top-level bindings by a values projected from the vectorised
-    -- closures and add any newly created hoisted top-level bindings to the group.
-    vectTopBindAndConvert (var, expr) inline expr'
-      = do
-        { var'  <- vectTopBinder var inline expr'
-        ; cexpr <- tryConvert var var' expr
-        ; return [(var, cexpr), (var', expr')]
-        }
-
--- Add a vectorised binding to an imported top-level variable that has a VECTORISE pragma
--- in this module.
---
--- RESTRICTION: Currently, we cannot use the pragma for mutually recursive definitions.
---
-vectImpBind :: (Id, CoreExpr) -> VM CoreBind
-vectImpBind (var, expr)
-  = do
-    { traceVt "= Add vectorised binding to imported variable" (ppr var)
-
-    ; var' <- vectTopBinder var inlineMe expr
-    ; return $ NonRec var' expr
-    }
-
--- |Make the vectorised version of this top level binder, and add the mapping between it and the
--- original to the state. For some binder @foo@ the vectorised version is @$v_foo@
---
--- NOTE: 'vectTopBinder' *MUST* be lazy in inline and expr because of how it is used inside of
---       'fixV' in 'vectTopBind'.
---
-vectTopBinder :: Var      -- ^ Name of the binding.
-              -> Inline   -- ^ Whether it should be inlined, used to annotate it.
-              -> CoreExpr -- ^ RHS of binding, used to set the 'Unfolding' of the returned 'Var'.
-              -> VM Var   -- ^ Name of the vectorised binding.
-vectTopBinder var inline expr
- = do {   -- Vectorise the type attached to the var.
-      ; vty  <- vectType (idType var)
-
-          -- If there is a vectorisation declaration for this binding, make sure its type matches
-      ; (_, vectDecl) <- lookupVectDecl var
-      ; case vectDecl of
-          Nothing             -> return ()
-          Just (vdty, _)
-            | eqType vty vdty -> return ()
-            | otherwise       ->
-              do
-              { dflags <- getDynFlags
-              ; cantVectorise dflags ("Type mismatch in vectorisation pragma for " ++ showPpr dflags var) $
-                  (text "Expected type" <+> ppr vty)
-                  $$
-                  (text "Inferred type" <+> ppr vdty)
-              }
-          -- Make the vectorised version of binding's name, and set the unfolding used for inlining
-      ; var' <- liftM (`setIdUnfolding` unfolding)
-                $  mkVectId var vty
-
-          -- Add the mapping between the plain and vectorised name to the state.
-      ; defGlobalVar var var'
-
-      ; return var'
-    }
-  where
-    unfolding = case inline of
-                  Inline arity -> mkInlineUnfoldingWithArity arity expr
-                  DontInline   -> noUnfolding
-{-
-!!!TODO: dfuns and unfoldings:
-           -- Do not inline the dfun; instead give it a magic DFunFunfolding
-           -- See Note [ClassOp/DFun selection]
-           -- See also note [Single-method classes]
-        dfun_id_w_fun
-           | isNewTyCon class_tc
-           = dfun_id `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
-           | otherwise
-           = dfun_id `setIdUnfolding`  mkDFunUnfolding dfun_ty dfun_args
-                     `setInlinePragma` dfunInlinePragma
- -}
-
--- |Project out the vectorised version of a binding from some closure, or return the original body
--- if that doesn't work.
---
-tryConvert :: Var       -- ^Name of the original binding (eg @foo@)
-           -> Var       -- ^Name of vectorised version of binding (eg @$vfoo@)
-           -> CoreExpr  -- ^The original body of the binding.
-           -> VM CoreExpr
-tryConvert var vect_var rhs
-  = fromVect (idType var) (Var vect_var)
-    `orElseErrV`
-    do
-    { emitVt "  Could NOT call vectorised from original version" $ ppr var <+> dcolon <+> ppr (idType var)
-    ; return rhs
-    }