Merge branch 'master' of http://darcs.haskell.org/ghc

compiler/typecheck/TcCanonical.lhs

@@ -1296,7 +1296,7 @@ canEqLeafTyVarLeft d fl eqv tv s2       -- eqv : tv ~ s2
 
        ; if no_flattening_happened then
              if isNothing occ_check_result then 
-                 canEqFailure d fl eqv 
+                 canEqFailure d fl (setVarType eqv $ mkEqPred (mkTyVarTy tv, xi2'))
              else 
                  continueWith $ CTyEqCan { cc_id     = eqv
                                          , cc_flavor = fl

compiler/typecheck/TcSplice.lhs

@@ -32,6 +32,7 @@ import TcHsSyn
 import TcSimplify
 import TcUnify
 import Type
+import Kind
 import TcType
 import TcEnv
 import TcMType
@@ -1188,29 +1189,30 @@ reifyTyCon tc
   = do { let flavour = reifyFamFlavour tc
              tvs     = tyConTyVars tc
              kind    = tyConKind tc
-             kind'
-               | isLiftedTypeKind kind = Nothing
-               | otherwise             = Just $ reifyKind kind
+       ; kind' <- if isLiftedTypeKind kind then return Nothing
+                  else fmap Just (reifyKind kind)
 
        ; fam_envs <- tcGetFamInstEnvs
        ; instances <- mapM reifyFamilyInstance (familyInstances fam_envs tc)
+       ; tvs' <- reifyTyVars tvs
        ; return (TH.FamilyI
-                    (TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind')
+                    (TH.FamilyD flavour (reifyName tc) tvs' kind')
                     instances) }
 
   | isSynTyCon tc
   = do { let (tvs, rhs) = synTyConDefn tc
        ; rhs' <- reifyType rhs
+       ; tvs' <- reifyTyVars tvs
        ; return (TH.TyConI
-                   (TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs'))
+                   (TH.TySynD (reifyName tc) tvs' rhs'))
        }
 
   | otherwise
   = do  { cxt <- reifyCxt (tyConStupidTheta tc)
         ; let tvs = tyConTyVars tc
         ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
+        ; r_tvs <- reifyTyVars tvs
         ; let name = reifyName tc
-              r_tvs  = reifyTyVars tvs
               deriv = []        -- Don't know about deriving
               decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
                    | otherwise     = TH.DataD    cxt name r_tvs cons        deriv
@@ -1245,7 +1247,8 @@ reifyDataCon tys dc
              return main_con
          else do
          { cxt <- reifyCxt theta'
-         ; return (TH.ForallC (reifyTyVars ex_tvs') cxt main_con) } }
+         ; ex_tvs'' <- reifyTyVars ex_tvs'
+         ; return (TH.ForallC ex_tvs'' cxt main_con) } }
 
 ------------------------------
 reifyClass :: Class -> TcM TH.Info
@@ -1254,7 +1257,8 @@ reifyClass cls
         ; inst_envs <- tcGetInstEnvs
         ; insts <- mapM reifyClassInstance (InstEnv.classInstances inst_envs cls)
         ; ops <- mapM reify_op op_stuff
-        ; let dec = TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops
+        ; tvs' <- reifyTyVars tvs
+        ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' ops
         ; return (TH.ClassI dec insts ) }
   where
     (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
@@ -1307,24 +1311,23 @@ reify_for_all :: TypeRep.Type -> TcM TH.Type
 reify_for_all ty
   = do { cxt' <- reifyCxt cxt;
        ; tau' <- reifyType tau
-       ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
+       ; tvs' <- reifyTyVars tvs
+       ; return (TH.ForallT tvs' cxt' tau') }
   where
     (tvs, cxt, tau) = tcSplitSigmaTy ty
 
 reifyTypes :: [Type] -> TcM [TH.Type]
 reifyTypes = mapM reifyType
 
-reifyKind :: Kind -> TH.Kind
+reifyKind :: Kind -> TcM TH.Kind
 reifyKind  ki
-  = let (kis, ki') = splitKindFunTys ki
-        kis_rep    = map reifyKind kis
-        ki'_rep    = reifyNonArrowKind ki'
-    in
-    foldr TH.ArrowK ki'_rep kis_rep
+  = do { let (kis, ki') = splitKindFunTys ki
+       ; ki'_rep <- reifyNonArrowKind ki'
+       ; kis_rep <- mapM reifyKind kis
+       ; return (foldr TH.ArrowK ki'_rep kis_rep) }
   where
-    reifyNonArrowKind k | isLiftedTypeKind k = TH.StarK
-                        | otherwise          = pprPanic "Exotic form of kind"
-                                                        (ppr k)
+    reifyNonArrowKind k | isLiftedTypeKind k = return TH.StarK 
+                        | otherwise          = noTH (sLit "this kind") (ppr k)
 
 reifyCxt :: [PredType] -> TcM [TH.Pred]
 reifyCxt   = mapM reifyPred
@@ -1338,11 +1341,12 @@ reifyFamFlavour tc | isSynFamilyTyCon tc = TH.TypeFam
                    | otherwise
                    = panic "TcSplice.reifyFamFlavour: not a type family"
 
-reifyTyVars :: [TyVar] -> [TH.TyVarBndr]
-reifyTyVars = map reifyTyVar
+reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr]
+reifyTyVars = mapM reifyTyVar
   where
-    reifyTyVar tv | isLiftedTypeKind kind = TH.PlainTV  name
-                  | otherwise             = TH.KindedTV name (reifyKind kind)
+    reifyTyVar tv | isLiftedTypeKind kind = return (TH.PlainTV  name)
+                  | otherwise             = do kind' <- reifyKind kind
+                                               return (TH.KindedTV name kind')
       where
         kind = tyVarKind tv
         name = reifyName tv

compiler/vectorise/Vectorise.hs

@@ -218,15 +218,23 @@ vectTopBind b@(Rec bs)
 -- Add a vectorised binding to an imported top-level variable that has a VECTORISE [SCALAR] pragma
 -- in this module.
 --
+-- RESTIRCTION: Currently, we cannot use the pragma vor mutually recursive definitions.
+--
 vectImpBind :: Id -> VM CoreBind
 vectImpBind var
   = do {   -- Vectorise the right-hand side, create an appropriate top-level binding and add it
            -- to the vectorisation map.  For the non-lifted version, we refer to the original
            -- definition — i.e., 'Var var'.
-       ; (inline, isScalar, expr') <- vectTopRhs [] var (Var var)
-       ; var' <- vectTopBinder var inline expr'
-       ; when isScalar $ 
-           addGlobalScalarVar var
+           -- NB: To support recursive definitions, we tie a lazy knot.
+       ; (var', _, expr') <- fixV $
+           \ ~(_, inline, rhs) ->
+             do { var' <- vectTopBinder var inline rhs
+                ; (inline, isScalar, expr') <- vectTopRhs [] var (Var var)
+
+                ; when isScalar $ 
+                    addGlobalScalarVar var
+                ; return (var', inline, expr')
+                }
 
            -- We add any newly created hoisted top-level bindings.
        ; hs <- takeHoisted

compiler/vectorise/Vectorise/Exp.hs

@@ -318,6 +318,10 @@ vectDictExpr (Coercion coe)
 -- requires the full blown vectorisation transformation; instead, they can be lifted by application
 -- of a member of the zipWith family (i.e., 'map', 'zipWith', zipWith3', etc.)
 --
+-- Dictionary functions are also scalar functions (as dictionaries themselves are not vectorised,
+-- instead they become dictionaries of vectorised methods).  We treat them differently, though see
+-- "Note [Scalar dfuns]" in 'Vectorise'.
+--
 vectScalarFun :: Bool       -- ^ Was the function marked as scalar by the user?
               -> [Var]      -- ^ Functions names in same recursive binding group
               -> CoreExpr   -- ^ Expression to be vectorised
@@ -344,14 +348,20 @@ vectScalarFun forceScalar recFns expr
     --           need to be members of the 'Scalar' class (that in its current form would better
     --           be called 'Primitive'). *ALSO* the hardcoded list of types is ugly!
     is_primitive_ty ty
+      | isPredTy ty               -- dictionaries never get into the environment
+      = True
       | Just (tycon, _) <- splitTyConApp_maybe ty
       = tyConName tycon `elem` [boolTyConName, intTyConName, word8TyConName, doubleTyConName]
-      | otherwise = False
+      | otherwise 
+      = False
 
     is_scalar_ty scalarTyCons ty 
+      | isPredTy ty               -- dictionaries never get into the environment
+      = True
       | Just (tycon, _) <- splitTyConApp_maybe ty
       = tyConName tycon `elemNameSet` scalarTyCons
-      | otherwise = False
+      | otherwise 
+      = False
 
     -- Checks whether an expression contain a non-scalar subexpression. 
     --
@@ -427,9 +437,17 @@ vectScalarFun forceScalar recFns expr
 
     uses_alt funs (_, _bs, e) = uses funs e 
 
+-- Generate code for a scalar function by generating a scalar closure.  If the function is a
+-- dictionary function, vectorise it as dictionary code.
+-- 
 mkScalarFun :: [Type] -> Type -> CoreExpr -> VM VExpr
 mkScalarFun arg_tys res_ty expr
-  = do { traceVt "mkScalarFun: " $ ppr expr
+  | isPredTy res_ty
+  = do { vExpr <- vectDictExpr expr
+       ; return (vExpr, unused)
+       }
+  | otherwise
+  = do { traceVt "mkScalarFun: " $ ppr expr $$ ptext (sLit "  ::") <+> ppr (mkFunTys arg_tys res_ty)
 
        ; fn_var  <- hoistExpr (fsLit "fn") expr DontInline
        ; zipf    <- zipScalars arg_tys res_ty
@@ -438,6 +456,8 @@ mkScalarFun arg_tys res_ty expr
        ; lclo    <- liftPD (Var clo_var)
        ; return (Var clo_var, lclo)
        }
+  where
+    unused = error "Vectorise.Exp.mkScalarFun: we don't lift dictionary expressions"
 
 -- |Vectorise a dictionary function that has a 'VECTORISE SCALAR instance' pragma.
 --