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

5 files changed, 11 insertions, 104 deletions

diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index 8478ab0322..937ffaf248 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -272,10 +272,6 @@ rnExpr (ExplicitList x _  exps)
            else
             return  (ExplicitList x Nothing exps', fvs) }
 
-rnExpr (ExplicitPArr x exps)
-  = do { (exps', fvs) <- rnExprs exps
-       ; return  (ExplicitPArr x exps', fvs) }
-
 rnExpr (ExplicitTuple x tup_args boxity)
   = do { checkTupleSection tup_args
        ; checkTupSize (length tup_args)
@@ -342,10 +338,6 @@ rnExpr (ArithSeq x _ seq)
            else
             return (ArithSeq x Nothing new_seq, fvs) }
 
-rnExpr (PArrSeq x seq)
-  = do { (new_seq, fvs) <- rnArithSeq seq
-       ; return (PArrSeq x new_seq, fvs) }
-
 {-
 These three are pattern syntax appearing in expressions.
 Since all the symbols are reservedops we can simply reject them.
@@ -841,7 +833,7 @@ rnStmt ctxt rnBody (L loc (BodyStmt _ body _ _)) thing_inside
         ; (guard_op, fvs2) <- if isListCompExpr ctxt
                               then lookupStmtName ctxt guardMName
                               else return (noSyntaxExpr, emptyFVs)
-                              -- Only list/parr/monad comprehensions use 'guard'
+                              -- Only list/monad comprehensions use 'guard'
                               -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ]
                               -- Here "gd" is a guard
         ; (thing, fvs3)    <- thing_inside []
@@ -1020,12 +1012,11 @@ lookupStmtNamePoly ctxt name
     not_rebindable = return (HsVar noExt (noLoc name), emptyFVs)
 
 -- | Is this a context where we respect RebindableSyntax?
--- but ListComp/PArrComp are never rebindable
+-- but ListComp are never rebindable
 -- Neither is ArrowExpr, which has its own desugarer in DsArrows
 rebindableContext :: HsStmtContext Name -> Bool
 rebindableContext ctxt = case ctxt of
   ListComp        -> False
-  PArrComp        -> False
   ArrowExpr       -> False
   PatGuard {}     -> False
 
@@ -1818,7 +1809,6 @@ isStrictPattern (L _ pat) =
     ListPat{}       -> True
     TuplePat{}      -> True
     SumPat{}        -> True
-    PArrPat{}       -> True
     ConPatIn{}      -> True
     ConPatOut{}     -> True
     LitPat{}        -> True
@@ -1977,7 +1967,6 @@ checkLastStmt ctxt lstmt@(L loc stmt)
   = case ctxt of
       ListComp  -> check_comp
       MonadComp -> check_comp
-      PArrComp  -> check_comp
       ArrowExpr -> check_do
       DoExpr    -> check_do
       MDoExpr   -> check_do
@@ -2028,7 +2017,7 @@ pprStmtCat (XStmtLR {})         = panic "pprStmtCat: XStmtLR"
 emptyInvalid :: Validity  -- Payload is the empty document
 emptyInvalid = NotValid Outputable.empty
 
-okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt
+okStmt, okDoStmt, okCompStmt, okParStmt
    :: DynFlags -> HsStmtContext Name
    -> Stmt GhcPs (Located (body GhcPs)) -> Validity
 -- Return Nothing if OK, (Just extra) if not ok
@@ -2044,7 +2033,6 @@ okStmt dflags ctxt stmt
       GhciStmtCtxt       -> okDoStmt   dflags ctxt stmt
       ListComp           -> okCompStmt dflags ctxt stmt
       MonadComp          -> okCompStmt dflags ctxt stmt
-      PArrComp           -> okPArrStmt dflags ctxt stmt
       TransStmtCtxt ctxt -> okStmt dflags ctxt stmt
 
 -------------
@@ -2091,21 +2079,6 @@ okCompStmt dflags _ stmt
        ApplicativeStmt {} -> emptyInvalid
        XStmtLR{} -> panic "okCompStmt"
 
-----------------
-okPArrStmt dflags _ stmt
-  = case stmt of
-       BindStmt {} -> IsValid
-       LetStmt {}  -> IsValid
-       BodyStmt {} -> IsValid
-       ParStmt {}
-         | LangExt.ParallelListComp `xopt` dflags -> IsValid
-         | otherwise -> NotValid (text "Use ParallelListComp")
-       TransStmt {} -> emptyInvalid
-       RecStmt {}   -> emptyInvalid
-       LastStmt {}  -> emptyInvalid  -- Should not happen (dealt with by checkLastStmt)
-       ApplicativeStmt {} -> emptyInvalid
-       XStmtLR{} -> panic "okPArrStmt"
-
 ---------
 checkTupleSection :: [LHsTupArg GhcPs] -> RnM ()
 checkTupleSection args
diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs
index 8f7c2e2309..4601b948d2 100644
--- a/compiler/rename/RnPat.hs
+++ b/compiler/rename/RnPat.hs
@@ -483,10 +483,6 @@ rnPatAndThen mk (ListPat _ pats)
                      ; return (ListPat (Just to_list_name) pats')}
           False -> return (ListPat Nothing pats') }
 
-rnPatAndThen mk (PArrPat x pats)
-  = do { pats' <- rnLPatsAndThen mk pats
-       ; return (PArrPat x pats') }
-
 rnPatAndThen mk (TuplePat x pats boxed)
   = do { liftCps $ checkTupSize (length pats)
        ; pats' <- rnLPatsAndThen mk pats
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 502be23bc0..5e01f285b4 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -99,7 +99,6 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
                             hs_fords   = foreign_decls,
                             hs_defds   = default_decls,
                             hs_ruleds  = rule_decls,
-                            hs_vects   = vect_decls,
                             hs_docs    = docs })
  = do {
    -- (A) Process the fixity declarations, creating a mapping from
@@ -187,12 +186,11 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
    (rn_rule_decls,    src_fvs2) <- setXOptM LangExt.ScopedTypeVariables $
                                    rnList rnHsRuleDecls rule_decls ;
                            -- Inside RULES, scoped type variables are on
-   (rn_vect_decls,    src_fvs3) <- rnList rnHsVectDecl    vect_decls ;
-   (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ;
-   (rn_ann_decls,     src_fvs5) <- rnList rnAnnDecl       ann_decls ;
-   (rn_default_decls, src_fvs6) <- rnList rnDefaultDecl   default_decls ;
-   (rn_deriv_decls,   src_fvs7) <- rnList rnSrcDerivDecl  deriv_decls ;
-   (rn_splice_decls,  src_fvs8) <- rnList rnSpliceDecl    splice_decls ;
+   (rn_foreign_decls, src_fvs3) <- rnList rnHsForeignDecl foreign_decls ;
+   (rn_ann_decls,     src_fvs4) <- rnList rnAnnDecl       ann_decls ;
+   (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl   default_decls ;
+   (rn_deriv_decls,   src_fvs6) <- rnList rnSrcDerivDecl  deriv_decls ;
+   (rn_splice_decls,  src_fvs7) <- rnList rnSpliceDecl    splice_decls ;
       -- Haddock docs; no free vars
    rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
 
@@ -210,13 +208,12 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
                              hs_annds  = rn_ann_decls,
                              hs_defds  = rn_default_decls,
                              hs_ruleds = rn_rule_decls,
-                             hs_vects  = rn_vect_decls,
                              hs_docs   = rn_docs } ;
 
         tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ;
         other_def  = (Just (mkNameSet tcf_bndrs), emptyNameSet) ;
-        other_fvs  = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, src_fvs5,
-                              src_fvs6, src_fvs7, src_fvs8] ;
+        other_fvs  = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
+                              src_fvs5, src_fvs6, src_fvs7] ;
                 -- It is tiresome to gather the binders from type and class decls
 
         src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;
@@ -1106,53 +1103,6 @@ badRuleLhsErr name lhs bad_e
             HsUnboundVar _ uv -> text "Not in scope:" <+> ppr uv
             _ -> text "Illegal expression:" <+> ppr bad_e
 
-{-
-*********************************************************
-*                                                      *
-\subsection{Vectorisation declarations}
-*                                                      *
-*********************************************************
--}
-
-rnHsVectDecl :: VectDecl GhcPs -> RnM (VectDecl GhcRn, FreeVars)
--- FIXME: For the moment, the right-hand side is restricted to be a variable as we cannot properly
---        typecheck a complex right-hand side without invoking 'vectType' from the vectoriser.
-rnHsVectDecl (HsVect _ s var rhs@(L _ (HsVar _ _)))
-  = do { var' <- lookupLocatedOccRn var
-       ; (rhs', fv_rhs) <- rnLExpr rhs
-       ; return (HsVect noExt s var' rhs', fv_rhs `addOneFV` unLoc var')
-       }
-rnHsVectDecl (HsVect _ _ _var _rhs)
-  = failWith $ vcat
-               [ text "IMPLEMENTATION RESTRICTION: right-hand side of a VECTORISE pragma"
-               , text "must be an identifier"
-               ]
-rnHsVectDecl (HsNoVect _ s var)
-  = do { var' <- lookupLocatedTopBndrRn var           -- only applies to local (not imported) names
-       ; return (HsNoVect noExt s var', unitFV (unLoc var'))
-       }
-rnHsVectDecl (HsVectType (VectTypePR s tycon Nothing) isScalar)
-  = do { tycon' <- lookupLocatedOccRn tycon
-       ; return ( HsVectType (VectTypePR s tycon' Nothing) isScalar
-                , unitFV (unLoc tycon'))
-       }
-rnHsVectDecl (HsVectType (VectTypePR s tycon (Just rhs_tycon)) isScalar)
-  = do { tycon'     <- lookupLocatedOccRn tycon
-       ; rhs_tycon' <- lookupLocatedOccRn rhs_tycon
-       ; return ( HsVectType (VectTypePR s tycon' (Just rhs_tycon')) isScalar
-                , mkFVs [unLoc tycon', unLoc rhs_tycon'])
-       }
-rnHsVectDecl (HsVectClass (VectClassPR s cls))
-  = do { cls' <- lookupLocatedOccRn cls
-       ; return (HsVectClass (VectClassPR s cls'), unitFV (unLoc cls'))
-       }
-rnHsVectDecl (HsVectInst instTy)
-  = do { (instTy', fvs) <- rnLHsInstType (text "a VECTORISE pragma") instTy
-       ; return (HsVectInst instTy', fvs)
-       }
-rnHsVectDecl (XVectDecl {})
-  = panic "RnSource.rnHsVectDecl: Unexpected 'XVectDecl'"
-
 {- **************************************************************
          *                                                      *
       Renaming type, class, instance and role declarations
@@ -2187,8 +2137,6 @@ add gp@(HsGroup {hs_annds  = ts}) l (AnnD _ d) ds
   = addl (gp { hs_annds = L l d : ts }) ds
 add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD _ d) ds
   = addl (gp { hs_ruleds = L l d : ts }) ds
-add gp@(HsGroup {hs_vects  = ts}) l (VectD _ d) ds
-  = addl (gp { hs_vects = L l d : ts }) ds
 add gp l (DocD _ d) ds
   = addl (gp { hs_docs = (L l d) : (hs_docs gp) })  ds
 add (HsGroup {}) _ (SpliceD _ (XSpliceDecl _)) _ = panic "RnSource.add"
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index b51a178e82..1f08856142 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -350,7 +350,7 @@ rnImplicitBndrs bind_free_tvs
 
 rnLHsInstType :: SDoc -> LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars)
 -- Rename the type in an instance.
--- The 'doc_str' is "an instance declaration" or "a VECTORISE pragma"
+-- The 'doc_str' is "an instance declaration".
 -- Do not try to decompose the inst_ty in case it is malformed
 rnLHsInstType doc inst_ty = rnHsSigType (GenericCtx doc) inst_ty
 
@@ -608,11 +608,6 @@ rnHsTyKi env t@(HsKindSig _ ty k)
        ; (k', fvs2)  <- rnLHsTyKi (env { rtke_level = KindLevel }) k
        ; return (HsKindSig noExt ty' k', fvs1 `plusFV` fvs2) }
 
-rnHsTyKi env t@(HsPArrTy _ ty)
-  = do { notInKinds env t
-       ; (ty', fvs) <- rnLHsTyKi env ty
-       ; return (HsPArrTy noExt ty', fvs) }
-
 -- Unboxed tuples are allowed to have poly-typed arguments.  These
 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
 rnHsTyKi env tupleTy@(HsTupleTy _ tup_con tys)
@@ -1149,7 +1144,6 @@ collectAnonWildCards lty = go lty
       HsAppTy _ ty1 ty2              -> go ty1 `mappend` go ty2
       HsFunTy _ ty1 ty2              -> go ty1 `mappend` go ty2
       HsListTy _ ty                  -> go ty
-      HsPArrTy _ ty                  -> go ty
       HsTupleTy _ _ tys              -> gos tys
       HsSumTy _ tys                  -> gos tys
       HsOpTy _ ty1 _ ty2             -> go ty1 `mappend` go ty2
@@ -1839,7 +1833,6 @@ extract_lty t_or_k (L _ ty) acc
       HsAppTy _ ty1 ty2           -> extract_lty t_or_k ty1 =<<
                                      extract_lty t_or_k ty2 acc
       HsListTy _ ty               -> extract_lty t_or_k ty acc
-      HsPArrTy _ ty               -> extract_lty t_or_k ty acc
       HsTupleTy _ _ tys           -> extract_ltys t_or_k tys acc
       HsSumTy _ tys               -> extract_ltys t_or_k tys acc
       HsFunTy _ ty1 ty2           -> extract_lty t_or_k ty1 =<<
diff --git a/compiler/rename/RnUtils.hs b/compiler/rename/RnUtils.hs
index bbac43d304..99272c2943 100644
--- a/compiler/rename/RnUtils.hs
+++ b/compiler/rename/RnUtils.hs
@@ -374,7 +374,6 @@ data HsDocContext
   | GHCiCtx
   | SpliceTypeCtx (LHsType GhcPs)
   | ClassInstanceCtx
-  | VectDeclCtx (Located RdrName)
   | GenericCtx SDoc   -- Maybe we want to use this more!
 
 withHsDocContext :: HsDocContext -> SDoc -> SDoc
@@ -409,5 +408,3 @@ pprHsDocContext (ConDeclCtx [name])
    = text "the definition of data constructor" <+> quotes (ppr name)
 pprHsDocContext (ConDeclCtx names)
    = text "the definition of data constructors" <+> interpp'SP names
-pprHsDocContext (VectDeclCtx tycon)
-   = text "the VECTORISE pragma for type constructor" <+> quotes (ppr tycon)