diff options
| -rw-r--r-- | compiler/rename/RnSource.lhs | 11 | ||||
| -rw-r--r-- | compiler/typecheck/TcBinds.lhs | 24 |
2 files changed, 25 insertions, 10 deletions
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 64feaed8e4..ac13c163d9 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -662,11 +662,18 @@ rnHsVectDecl (HsVect var Nothing) = do { var' <- lookupLocatedTopBndrRn var ; return (HsVect var' Nothing, unitFV (unLoc var')) } -rnHsVectDecl (HsVect var (Just rhs)) +-- 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 var (Just rhs@(L _ (HsVar _)))) = do { var' <- lookupLocatedTopBndrRn var ; (rhs', fv_rhs) <- rnLExpr rhs ; return (HsVect var' (Just rhs'), fv_rhs `addOneFV` unLoc var') } +rnHsVectDecl (HsVect _var (Just _rhs)) + = failWith $ vcat + [ ptext (sLit "IMPLEMENTATION RESTRICTION: right-hand side of a VECTORISE pragma") + , ptext (sLit "must be an identifier") + ] rnHsVectDecl (HsNoVect var) = do { var' <- lookupLocatedTopBndrRn var ; return (HsNoVect var', unitFV (unLoc var')) @@ -681,7 +688,7 @@ rnHsVectDecl (HsVectTypeIn tycon (Just ty)) ; return (HsVectTypeIn tycon' (Just ty'), fv_ty `addOneFV` unLoc tycon') } where - vect_doc = text "In the VECTORISE pragma for type constructor" <+> quotes (ppr tycon) + vect_doc = ptext (sLit "In the VECTORISE pragma for type constructor") <+> quotes (ppr tycon) rnHsVectDecl (HsVectTypeOut _ _) = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectTypeOut'" \end{code} diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 6f5e667787..9f5fd4d350 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -641,19 +641,26 @@ tcVectDecls decls -------------- tcVect :: VectDecl Name -> TcM (VectDecl TcId) --- We can't typecheck the expression of a vectorisation declaration against the vectorised type --- of the original definition as this requires internals of the vectoriser not available during --- type checking. Instead, we infer the type of the expression and leave it to the vectoriser --- to check the compatibility of the Core types. +-- FIXME: We can't typecheck the expression of a vectorisation declaration against the vectorised +-- type of the original definition as this requires internals of the vectoriser not available +-- during type checking. Instead, constrain the rhs of a vectorisation declaration to be a single +-- identifier (this is checked in 'rnHsVectDecl'). tcVect (HsVect name Nothing) = addErrCtxt (vectCtxt name) $ do { id <- wrapLocM tcLookupId name ; return $ HsVect id Nothing } -tcVect (HsVect name@(L loc _) (Just rhs)) - = addErrCtxt (vectCtxt name) $ - do { _id <- wrapLocM tcLookupId name -- need to ensure that the name is already defined +tcVect (HsVect lname@(L loc name) (Just rhs)) + = addErrCtxt (vectCtxt lname) $ + do { id <- tcLookupId name + + ; let L rhs_loc (HsVar rhs_var_name) = rhs + ; rhs_id <- tcLookupId rhs_var_name + ; let typedId = setIdType id (idType rhs_id) + ; return $ HsVect (L loc typedId) (Just $ L rhs_loc (HsVar rhs_id)) + } +{- OLD CODE: -- turn the vectorisation declaration into a single non-recursive binding ; let bind = L loc $ mkTopFunBind name [mkSimpleMatch [] rhs] sigFun = const Nothing @@ -661,7 +668,7 @@ tcVect (HsVect name@(L loc _) (Just rhs)) -- perform type inference (including generalisation) ; (binds, [id'], _) <- tcPolyInfer False True sigFun pragFun NonRecursive [bind] - + ; traceTc "tcVect inferred type" $ ppr (varType id') ; traceTc "tcVect bindings" $ ppr binds @@ -678,6 +685,7 @@ tcVect (HsVect name@(L loc _) (Just rhs)) -- to the vectoriser - see "Note [Typechecked vectorisation pragmas]" in HsDecls ; return $ HsVect (L loc id') (Just rhsWrapped) } + -} tcVect (HsNoVect name) = addErrCtxt (vectCtxt name) $ do { id <- wrapLocM tcLookupId name |