X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fvectorise%2FVectorise%2FType%2FPADict.hs;h=6b67f66678614ba6bbbe3f7bb2e93d7ee6535086;hp=77993846b10c5832ebea5a944e63de94748db6ce;hb=ed333003733fd3f3a3de015998f59ee1a709230a;hpb=907fa8af43e420e59ad1b78623f0ffe445c09e87

diff --git a/compiler/vectorise/Vectorise/Type/PADict.hs b/compiler/vectorise/Vectorise/Type/PADict.hs
index 7799384..6b67f66 100644
--- a/compiler/vectorise/Vectorise/Type/PADict.hs
+++ b/compiler/vectorise/Vectorise/Type/PADict.hs
@@ -15,56 +15,88 @@ import CoreUtils
 import CoreUnfold
 import TyCon
 import Type
-import OccName
+import TypeRep
 import Id
 import Var
 import Name
+import Class
+import Outputable
 
+-- debug		= False
+-- dtrace s x	= if debug then pprTrace "Vectoris.Type.PADict" s x else x
 
+-- | Build the PA dictionary for some type and hoist it to top level.
+--   The PA dictionary holds fns that convert values to and from their vectorised representations.
+buildPADict
+	:: TyCon	-- ^ tycon of the type being vectorised.
+	-> TyCon	-- ^ tycon of the type used for the vectorised representation.
+	-> TyCon	-- 
+	-> SumRepr	-- ^ representation used for the type being vectorised.
+	-> VM Var	-- ^ name of the top-level dictionary function.
 
-buildPADict :: TyCon -> TyCon -> TyCon -> SumRepr -> VM Var
 buildPADict vect_tc prepr_tc arr_tc repr
-  = polyAbstract tvs $ \args ->
-    do
+ = polyAbstract tvs $ \args ->
+ case args of
+  (_:_) -> pprPanic "Vectorise.Type.PADict.buildPADict" (text "why do we need superclass dicts?")
+  [] -> do
+      -- TODO: I'm forcing args to [] because I'm not sure why we need them.
+      --       class PA has superclass (PR (PRepr a)) but we're not using
+      --       the superclass dictionary to build the PA dictionary.
+
+      -- Get ids for each of the methods in the dictionary.
       method_ids <- mapM (method args) paMethods
 
-      pa_tc  <- builtin paTyCon
+      -- Expression to build the dictionary.
       pa_dc  <- builtin paDataCon
       let dict = mkLams (tvs ++ args)
                $ mkConApp pa_dc
                $ Type inst_ty : map (method_call args) method_ids
 
-          dfun_ty = mkForAllTys tvs
-                  $ mkFunTys (map varType args) (mkTyConApp pa_tc [inst_ty])
-
+      -- Build the type of the dictionary function.
+      pa_tc          <- builtin paTyCon
+      let pa_opitems = [(id, NoDefMeth) | id <- method_ids]
+      let pa_cls     = mkClass 
+			(tyConName pa_tc)
+			tvs		-- tyvars of class
+			[]		-- fundeps
+			[]		-- superclass predicates
+			[]		-- superclass dict selectors
+			[]		-- associated type families
+			pa_opitems	-- class op items
+			pa_tc		-- dictionary type constructor
+			
+      let dfun_ty = mkForAllTys tvs
+                  $ mkFunTys (map varType args) (PredTy $ ClassP pa_cls [inst_ty])
+
+      -- Set the unfolding for the inliner.
       raw_dfun <- newExportedVar dfun_name dfun_ty
-      let dfun = raw_dfun `setIdUnfolding` mkDFunUnfolding dfun_ty (map Var method_ids)
+      let dfun = raw_dfun `setIdUnfolding`  mkDFunUnfolding dfun_ty (map Var method_ids)
                           `setInlinePragma` dfunInlinePragma
 
+      -- Add the new binding to the top-level environment.
       hoistBinding dfun dict
       return dfun
   where
-    tvs = tyConTyVars vect_tc
-    arg_tys = mkTyVarTys tvs
-    inst_ty = mkTyConApp vect_tc arg_tys
+    tvs       = tyConTyVars vect_tc
+    arg_tys   = mkTyVarTys tvs
+    inst_ty   = mkTyConApp vect_tc arg_tys
 
     dfun_name = mkPADFunOcc (getOccName vect_tc)
 
     method args (name, build)
       = localV
       $ do
-          expr <- build vect_tc prepr_tc arr_tc repr
+          expr     <- build vect_tc prepr_tc arr_tc repr
           let body = mkLams (tvs ++ args) expr
-          raw_var <- newExportedVar (method_name name) (exprType body)
-          let var = raw_var
-                      `setIdUnfolding` mkInlineRule body (Just (length args))
+          raw_var  <- newExportedVar (method_name name) (exprType body)
+          let var  = raw_var
+                      `setIdUnfolding` mkInlineUnfolding (Just (length args)) body
                       `setInlinePragma` alwaysInlinePragma
           hoistBinding var body
           return var
 
     method_call args id = mkApps (Var id) (map Type arg_tys ++ map Var args)
-
-    method_name name = mkVarOcc $ occNameString dfun_name ++ ('$' : name)
+    method_name name    = mkVarOcc $ occNameString dfun_name ++ ('$' : name)
 
 
 paMethods :: [(String, TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr)]