Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/ae6161ec6f2466ca2d04f098f350ce06090003b1 >--------------------------------------------------------------- commit ae6161ec6f2466ca2d04f098f350ce06090003b1 Author: Manuel M T Chakravarty <[email protected]> Date: Sat Aug 20 23:08:10 2011 +1000 Until the type checker can use vectorised signatures, we restrict the RHS of VECTORISE pragmas to be a single identifier only. - This removes the need to be careful about the order of dictionaries during type inference. A property that is too fragile to try to maintain in the type checker. >--------------------------------------------------------------- compiler/rename/RnSource.lhs | 11 +++++++++-- compiler/typecheck/TcBinds.lhs | 22 +++++++++++++++------- 2 files changed, 24 insertions(+), 9 deletions(-) diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 64feaed..ac13c16 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 6f5e667..9f5fd4d 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 @@ -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 _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
