X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fvectorise%2FVectorise%2FType%2FPADict.hs;h=a15f671352e2b4ac75011b5033d4009272b68a5b;hp=5feeb2aaafa6dd0254878a2da6e075fd90b81f30;hb=d70f8919d9fde9bf0ec1438cafb617588400e09c;hpb=638bc3e317b7c2b0d88bd02edaa85a76cb60079a

diff --git a/compiler/vectorise/Vectorise/Type/PADict.hs b/compiler/vectorise/Vectorise/Type/PADict.hs
index 5feeb2a..a15f671 100644
--- a/compiler/vectorise/Vectorise/Type/PADict.hs
+++ b/compiler/vectorise/Vectorise/Type/PADict.hs
@@ -15,10 +15,15 @@ import CoreUtils
 import CoreUnfold
 import TyCon
 import Type
+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.
@@ -30,18 +35,30 @@ buildPADict
 	-> VM Var	-- ^ name of the top-level dictionary function.
 
 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 Just pa_cls	= tyConClass_maybe pa_tc
+
+      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