X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectUtils.hs;h=df8c23ff5e26651de62f8e8cbc8d221f21813440;hb=346516b3930d677616e5108499d3a82b51f58853;hp=0727c947ce67527cd041f1d423c458d0b0145dc9;hpb=8bae351221fbd5eabe562641499c14d379816875;p=ghc-hetmet.git

diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs
index 0727c94..df8c23f 100644
--- a/compiler/vectorise/VectUtils.hs
+++ b/compiler/vectorise/VectUtils.hs
@@ -3,11 +3,11 @@ module VectUtils (
   collectAnnValBinders,
   splitClosureTy,
   mkPADictType, mkPArrayType,
-  paDictArgType, paDictOfType,
+  paDictArgType, paDictOfType, paDFunType,
   paMethod, lengthPA, replicatePA, emptyPA, liftPA,
   polyAbstract, polyApply, polyVApply,
   lookupPArrayFamInst,
-  hoistExpr, hoistPolyVExpr, takeHoisted,
+  hoistBinding, hoistExpr, hoistPolyVExpr, takeHoisted,
   buildClosure, buildClosures,
   mkClosureApp
 ) where
@@ -97,7 +97,7 @@ mkClosureTypes arg_tys res_ty
 mkPADictType :: Type -> VM Type
 mkPADictType ty
   = do
-      tc <- builtin paDictTyCon
+      tc <- builtin paTyCon
       return $ TyConApp tc [ty]
 
 mkPArrayType :: Type -> VM Type
@@ -140,11 +140,21 @@ paDictOfTyApp (TyVarTy tv) ty_args
       paDFunApply dfun ty_args
 paDictOfTyApp (TyConApp tc _) ty_args
   = do
-      pa_class <- builtin paClass
-      (dfun, ty_args') <- lookupInst pa_class [TyConApp tc ty_args]
-      paDFunApply (Var dfun) ty_args'
+      dfun <- traceMaybeV "paDictOfTyApp" (ppr tc) (lookupTyConPA tc)
+      paDFunApply (Var dfun) ty_args
 paDictOfTyApp ty ty_args = pprPanic "paDictOfTyApp" (ppr ty)
 
+paDFunType :: TyCon -> VM Type
+paDFunType tc
+  = do
+      margs <- mapM paDictArgType tvs
+      res   <- mkPADictType (mkTyConApp tc arg_tys)
+      return . mkForAllTys tvs
+             $ mkFunTys [arg | Just arg <- margs] res
+  where
+    tvs = tyConTyVars tc
+    arg_tys = mkTyVarTys tvs
+
 paDFunApply :: CoreExpr -> [Type] -> VM CoreExpr
 paDFunApply dfun tys
   = do
@@ -215,12 +225,15 @@ polyVApply expr tys
 lookupPArrayFamInst :: Type -> VM (TyCon, [Type])
 lookupPArrayFamInst ty = builtin parrayTyCon >>= (`lookupFamInst` [ty])
 
+hoistBinding :: Var -> CoreExpr -> VM ()
+hoistBinding v e = updGEnv $ \env ->
+  env { global_bindings = (v,e) : global_bindings env }
+
 hoistExpr :: FastString -> CoreExpr -> VM Var
 hoistExpr fs expr
   = do
       var <- newLocalVar fs (exprType expr)
-      updGEnv $ \env ->
-        env { global_bindings = (var, expr) : global_bindings env }
+      hoistBinding var expr
       return var
 
 hoistVExpr :: VExpr -> VM VVar