Fix and clean up 'PData' and 'Wrap' usage of the vectoriser
authorManuel M T Chakravarty <chak@cse.unsw.edu.au>
Wed, 23 Nov 2011 04:08:39 +0000 (15:08 +1100)
committerManuel M T Chakravarty <chak@cse.unsw.edu.au>
Wed, 23 Nov 2011 04:12:00 +0000 (15:12 +1100)
compiler/vectorise/Vectorise/Builtins/Initialise.hs
compiler/vectorise/Vectorise/Exp.hs
compiler/vectorise/Vectorise/Generic/Description.hs
compiler/vectorise/Vectorise/Generic/PAMethods.hs
compiler/vectorise/Vectorise/Type/Env.hs
compiler/vectorise/Vectorise/Type/PRepr.hs [deleted file]
compiler/vectorise/Vectorise/Utils/Base.hs
compiler/vectorise/Vectorise/Utils/PADict.hs

index 56ae67f..e2fddef 100644 (file)
@@ -199,7 +199,8 @@ initBuiltinVars (Builtins { })
 -- |Get a list of names to `TyCon`s in the mock prelude.
 --
 initBuiltinTyCons :: Builtins -> DsM [(Name, TyCon)]
--- FIXME: must be replaced by VECTORISE pragmas!!!
+-- FIXME: * must be replaced by VECTORISE pragmas!!!
+--        * then we can remove 'parrayTyCon' from the Builtins as well
 initBuiltinTyCons bi
   = do
       return $ (tyConName funTyCon, closureTyCon bi)
index 8afe149..d695fcb 100644 (file)
@@ -625,9 +625,8 @@ vectAlgCase _tycon _ty_args scrut bndr ty [(DataAlt dc, bndrs, body)]
           . vectBndrsIn bndrs
           $ vectExpr body
       let (vect_bndrs, lift_bndrs) = unzip vbndrs
-      (vscrut, lscrut, pdata_tc, _arg_tys) <- mkVScrut (vVar vbndr)
+      (vscrut, lscrut, pdata_dc) <- pdataUnwrapScrut (vVar vbndr)
       vect_dc <- maybeV dataConErr (lookupDataCon dc)
-      let [pdata_dc] = tyConDataCons pdata_tc
 
       let vcase = mk_wild_case vscrut vty vect_dc  vect_bndrs vect_body
           lcase = mk_wild_case lscrut lty pdata_dc lift_bndrs lift_body
@@ -657,8 +656,7 @@ vectAlgCase tycon _ty_args scrut bndr ty alts
       let (vect_dcs, vect_bndrss, lift_bndrss, vbodies) = unzip4 valts
 
       vexpr <- vectExpr scrut
-      (vect_scrut, lift_scrut, pdata_tc, _arg_tys) <- mkVScrut (vVar vbndr)
-      let [pdata_dc] = tyConDataCons pdata_tc
+      (vect_scrut, lift_scrut, pdata_dc) <- pdataUnwrapScrut (vVar vbndr)
 
       let (vect_bodies, lift_bodies) = unzip vbodies
 
index d0d4469..eed01b0 100644 (file)
@@ -1,16 +1,20 @@
-
--- | Compute a description of the generic representation that we use for 
---   a user defined data type.
+-- |Compute a description of the generic representation that we use for a user defined data type.
 --
---   During vectorisation, we generate a PRepr and PA instance for each user defined
---   data type. The PA dictionary contains methods to convert the user type to and
---   from our generic representation. This module computes a description of what
---   that generic representation is.
+-- During vectorisation, we generate a PRepr and PA instance for each user defined
+-- data type. The PA dictionary contains methods to convert the user type to and
+-- from our generic representation. This module computes a description of what
+-- that generic representation is.
 --
-module Vectorise.Generic.Description ( 
-  CompRepr (..), ProdRepr (..), ConRepr (..), SumRepr (..),
-  tyConRepr, sumReprType, conReprType, prodReprType, compReprType, compOrigType
-) where
+module Vectorise.Generic.Description 
+  ( CompRepr(..)
+  , ProdRepr(..)
+  , ConRepr(..)
+  , SumRepr(..)
+  , tyConRepr
+  , sumReprType
+  , compOrigType
+  ) 
+where
 
 import Vectorise.Utils
 import Vectorise.Monad
@@ -108,8 +112,8 @@ data CompRepr
 
 -------------------------------------------------------------------------------
 
--- | Determine the generic representation of a data type, given its tycon.
---   The `TyCon` contains a description of the whole data type.
+-- |Determine the generic representation of a data type, given its tycon.
+--
 tyConRepr :: TyCon -> VM SumRepr
 tyConRepr tc 
   = sum_repr (tyConDataCons tc)
@@ -129,9 +133,8 @@ tyConRepr tc
            sum_tc       <- builtin (sumTyCon arity)
            
            -- Get the 'PData' and 'PDatas' tycons for the sum.
-           let sumapp   = mkTyConApp sum_tc tys
-           psum_tc      <- liftM fst $ pdataReprTyCon  sumapp
-           psums_tc     <- liftM fst $ pdatasReprTyCon sumapp
+           psum_tc      <- pdataReprTyConExact  sum_tc
+           psums_tc     <- pdatasReprTyConExact sum_tc
            
            sel_ty       <- builtin (selTy      arity)
            sels_ty      <- builtin (selsTy     arity)
@@ -165,9 +168,8 @@ tyConRepr tc
            tup_tc       <- builtin (prodTyCon arity)
 
            -- Get the 'PData' and 'PDatas' tycons for the product.
-           let prodapp  = mkTyConApp tup_tc tys'
-           ptup_tc      <- liftM fst $ pdataReprTyCon  prodapp
-           ptups_tc     <- liftM fst $ pdatasReprTyCon prodapp
+           ptup_tc      <- pdataReprTyConExact  tup_tc
+           ptups_tc     <- pdatasReprTyConExact tup_tc
            
            return $ Prod 
                   { repr_tup_tc   = tup_tc
@@ -181,37 +183,35 @@ tyConRepr tc
     comp_repr ty = liftM (Keep ty) (prDictOfReprType ty)
                    `orElseV` return (Wrap ty)
 
-
--- | Yield the type of this sum representation.
+-- |Yield the type of this sum representation.
+--
 sumReprType :: SumRepr -> VM Type
 sumReprType EmptySum     = voidType
 sumReprType (UnarySum r) = conReprType r
 sumReprType (Sum { repr_sum_tc  = sum_tc, repr_con_tys = tys })
   = return $ mkTyConApp sum_tc tys
 
-
--- | Yield the type of this constructor representation.
+-- Yield the type of this constructor representation.
+--
 conReprType :: ConRepr -> VM Type
 conReprType (ConRepr _ r) = prodReprType r
 
-
--- | Yield the type of of this product representation.
+-- Yield the type of of this product representation.
+--
 prodReprType :: ProdRepr -> VM Type
 prodReprType EmptyProd     = voidType
 prodReprType (UnaryProd r) = compReprType r
 prodReprType (Prod { repr_tup_tc = tup_tc, repr_comp_tys = tys })
   = return $ mkTyConApp tup_tc tys
 
-
--- | Yield the type of this data constructor field \/ component representation.
+-- Yield the type of this data constructor field \/ component representation.
+--
 compReprType :: CompRepr -> VM Type
 compReprType (Keep ty _) = return ty
-compReprType (Wrap ty)
-  = do  wrap_tc <- builtin wrapTyCon
-        return $ mkTyConApp wrap_tc [ty]
-       
+compReprType (Wrap ty)   = mkWrapType ty
 
--- Yield the original component type of a data constructor component representation.
+-- |Yield the original component type of a data constructor component representation.
+--
 compOrigType :: CompRepr -> Type
 compOrigType (Keep ty _) = ty
 compOrigType (Wrap ty)   = ty
index c02deda..85e3336 100644 (file)
@@ -164,13 +164,13 @@ buildToPRepr vect_tc repr_tc _ _ repr
     -- CoreExp to convert a data constructor component to the generic representation.
     to_comp :: CoreExpr -> CompRepr -> VM CoreExpr
     to_comp expr (Keep _ _) = return expr
-    to_comp expr (Wrap ty)  
-     = do wrap_tc <- builtin wrapTyCon
-          return $ wrapNewTypeBody wrap_tc [ty] expr
+    to_comp expr (Wrap ty)  = wrapNewTypeBodyOfWrap expr ty
 
 
 -- buildFromPRepr -------------------------------------------------------------
--- | Build the 'fromPRepr' method of the PA class.
+
+-- |Build the 'fromPRepr' method of the PA class.
+--
 buildFromPRepr :: PAInstanceBuilder
 buildFromPRepr vect_tc repr_tc _ _ repr
   = do
@@ -217,14 +217,13 @@ buildFromPRepr vect_tc repr_tc _ _ repr
                    [(DataAlt tup_con, vars, con `mkApps` es)]
 
     from_comp expr (Keep _ _) = return expr
-    from_comp expr (Wrap ty)
-      = do
-          wrap <- builtin wrapTyCon
-          return $ unwrapNewTypeBody wrap [ty] expr
+    from_comp expr (Wrap ty)  = unwrapNewTypeBodyOfWrap expr ty
 
 
 -- buildToArrRepr -------------------------------------------------------------
--- | Build the 'toArrRepr' method of the PA class.
+
+-- |Build the 'toArrRepr' method of the PA class.
+--
 buildToArrPRepr :: PAInstanceBuilder
 buildToArrPRepr vect_tc prepr_tc pdata_tc _ r
  = do arg_ty <- mkPDataType el_ty
@@ -283,17 +282,14 @@ buildToArrPRepr vect_tc prepr_tc pdata_tc _ r
 
     to_con (ConRepr _ r)    = to_prod r
 
-    -- FIXME: this is bound to be wrong!
     to_comp expr (Keep _ _) = return expr
-    to_comp expr (Wrap ty)
-      = do
-          wrap_tc  <- builtin wrapTyCon
-          pwrap_tc <- pdataReprTyConExact (mkTyConApp wrap_tc [ty])
-          return $ wrapNewTypeBody pwrap_tc [ty] expr
+    to_comp expr (Wrap ty)  = wrapNewTypeBodyOfPDataWrap expr ty
 
 
 -- buildFromArrPRepr ----------------------------------------------------------
--- | Build the 'fromArrPRepr' method for the PA class.
+
+-- |Build the 'fromArrPRepr' method for the PA class.
+--
 buildFromArrPRepr :: PAInstanceBuilder
 buildFromArrPRepr vect_tc prepr_tc pdata_tc _ r
  = do arg_ty <- mkPDataType =<< mkPReprType el_ty
@@ -355,11 +351,9 @@ buildFromArrPRepr vect_tc prepr_tc pdata_tc _ r
     from_con res_ty res expr (ConRepr _ r) = from_prod res_ty res expr r
 
     from_comp _ res expr (Keep _ _) = return (res, [expr])
-    from_comp _ res expr (Wrap ty)
-     = do wrap_tc  <- builtin wrapTyCon
-          pwrap_tc <- pdataReprTyConExact (mkTyConApp wrap_tc [ty])
-          return (res, [unwrapNewTypeBody pwrap_tc [ty]
-                        $ unwrapFamInstScrut pwrap_tc [ty] expr])
+    from_comp _ res expr (Wrap ty)  = do { expr' <- unwrapNewTypeBodyOfPDataWrap expr ty
+                                         ; return (res, [expr'])
+                                         }
 
     fold f res_ty res exprs rs
       = foldrM f' (res, []) (zip exprs rs)
@@ -457,12 +451,8 @@ buildToArrPReprs vect_tc prepr_tc _ pdatas_tc r
     to_con xSums (ConRepr _ r)
         = to_prod xSums r
 
-    -- FIXME: this is bound to be wrong!
     to_comp expr (Keep _ _) = return expr
-    to_comp expr (Wrap ty)
-     = do wrap_tc       <- builtin wrapTyCon
-          (pwrap_tc, _) <- pdatasReprTyCon (mkTyConApp wrap_tc [ty])
-          return $ wrapNewTypeBody pwrap_tc [ty] expr
+    to_comp expr (Wrap ty)  = wrapNewTypeBodyOfPDatasWrap expr ty
 
 
 -- buildFromArrPReprs ---------------------------------------------------------
@@ -545,11 +535,9 @@ buildFromArrPReprs vect_tc prepr_tc _ pdatas_tc r
         = from_prod res_ty res expr r
 
     from_comp _ res expr (Keep _ _) = return (res, [expr])
-    from_comp _ res expr (Wrap ty)
-     = do wrap_tc        <- builtin wrapTyCon
-          (pwraps_tc, _) <- pdatasReprTyCon (mkTyConApp wrap_tc [ty])
-          return (res, [unwrapNewTypeBody pwraps_tc [ty]
-                        $ unwrapFamInstScrut pwraps_tc [ty] expr])
+    from_comp _ res expr (Wrap ty)  = do { expr' <- unwrapNewTypeBodyOfPDatasWrap expr ty
+                                         ; return (res, [expr'])
+                                         }
 
     fold f res_ty res exprs rs
       = foldrM f' (res, []) (zip exprs rs)
index affd4ca..6b75eca 100644 (file)
@@ -227,22 +227,18 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
        ; (_, binds) <- fixV $ \ ~(dfuns, _) ->
            do { defTyConPAs (zipLazy vect_tcs dfuns)
 
-                  -- query the 'PData' instance type constructors for type constructors that have a
+                  -- Query the 'PData' instance type constructors for type constructors that have a
                   -- VECTORISE pragma with an explicit right-hand side (this is Item (3) of
-                  -- "Note [Pragmas to vectorise tycons]" above)
-              ; pdata_withRHS_tcs <- mapM pdataReprTyConExact
-                                          [ mkTyConApp tycon tys
-                                          | (tycon, _) <- vectTyConsWithRHS
-                                          , let tys = mkTyVarTys (tyConTyVars tycon)
-                                          ]
-
-                  -- build workers for all vectorised data constructors (except scalar ones)
+                  -- "Note [Pragmas to vectorise tycons]" above).
+              ; pdata_withRHS_tcs <- mapM pdataReprTyConExact (map fst vectTyConsWithRHS)
+
+                  -- Build workers for all vectorised data constructors (except scalar ones)
               ; sequence_ $
                   zipWith3 vectDataConWorkers (orig_tcs  ++ map fst vectTyConsWithRHS)
                                               (vect_tcs  ++ map snd vectTyConsWithRHS)
                                               (pdata_tcs ++ pdata_withRHS_tcs)
 
-                  -- build a 'PA' dictionary for all type constructors (except scalar ones and those
+                  -- Build a 'PA' dictionary for all type constructors (except scalar ones and those
                   -- defined with an explicit right-hand side where the dictionary is user-supplied)
               ; dfuns <- sequence $
                            zipWith4 buildTyConPADict
diff --git a/compiler/vectorise/Vectorise/Type/PRepr.hs b/compiler/vectorise/Vectorise/Type/PRepr.hs
deleted file mode 100644 (file)
index 6e427cc..0000000
+++ /dev/null
@@ -1,369 +0,0 @@
-
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
-module Vectorise.Type.PRepr
-  ( buildPReprTyCon
-  , buildPAScAndMethods 
-  ) where
-
-import Vectorise.Utils
-import Vectorise.Monad
-import Vectorise.Builtins
-import Vectorise.Type.Repr
-import CoreSyn
-import CoreUtils
-import MkCore           ( mkWildCase )
-import TyCon
-import Type
-import BuildTyCl
-import OccName
-import Coercion
-import MkId
-
-import FastString
-import MonadUtils
-import Control.Monad
-
-
-mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type])
-mk_fam_inst fam_tc arg_tc
-  = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc])
-
-
-buildPReprTyCon :: TyCon -> TyCon -> SumRepr -> VM TyCon
-buildPReprTyCon orig_tc vect_tc repr
-  = do
-      name     <- mkLocalisedName mkPReprTyConOcc (tyConName orig_tc)
-      -- rhs_ty   <- buildPReprType vect_tc
-      rhs_ty   <- sumReprType repr
-      prepr_tc <- builtin preprTyCon
-      liftDs $ buildSynTyCon name
-                             tyvars
-                             (SynonymTyCon rhs_ty)
-                             (typeKind rhs_ty)
-                             NoParentTyCon
-                             (Just $ mk_fam_inst prepr_tc vect_tc)
-  where
-    tyvars = tyConTyVars vect_tc
-
-
------------------------------------------------------
-buildPAScAndMethods :: [(String, TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr)]
--- buildPAScandmethods says how to build the PR superclass and methods of PA
---    class class PR (PRepr a) => PA a where
---      toPRepr      :: a -> PRepr a
---      fromPRepr    :: PRepr a -> a
---      toArrPRepr   :: PData a -> PData (PRepr a)
---      fromArrPRepr :: PData (PRepr a) -> PData a
-
-buildPAScAndMethods = [("PR",           buildPRDict),
-                      ("toPRepr",      buildToPRepr),
-                      ("fromPRepr",    buildFromPRepr),
-                      ("toArrPRepr",   buildToArrPRepr),
-                      ("fromArrPRepr", buildFromArrPRepr)]
-
-buildPRDict :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr
-buildPRDict vect_tc prepr_tc _ _
-  = prDictOfPReprInstTyCon inst_ty prepr_tc arg_tys
-  where
-    arg_tys = mkTyVarTys (tyConTyVars vect_tc)
-    inst_ty = mkTyConApp vect_tc arg_tys
-
-buildToPRepr :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr
-buildToPRepr vect_tc repr_tc _ repr
-  = do
-      let arg_ty = mkTyConApp vect_tc ty_args
-      res_ty <- mkPReprType arg_ty
-      arg    <- newLocalVar (fsLit "x") arg_ty
-      result <- to_sum (Var arg) arg_ty res_ty repr
-      return $ Lam arg result
-  where
-    ty_args = mkTyVarTys (tyConTyVars vect_tc)
-
-    wrap_repr_inst = wrapFamInstBody repr_tc ty_args
-
-    to_sum _ _ _ EmptySum
-      = do
-          void <- builtin voidVar
-          return $ wrap_repr_inst $ Var void
-
-    to_sum arg arg_ty res_ty (UnarySum r)
-      = do
-          (pat, vars, body) <- con_alt r
-          return $ mkWildCase arg arg_ty res_ty
-                   [(pat, vars, wrap_repr_inst body)]
-
-    to_sum arg arg_ty res_ty (Sum { repr_sum_tc  = sum_tc
-                                  , repr_con_tys = tys
-                                  , repr_cons    =  cons })
-      = do
-          alts <- mapM con_alt cons
-          let alts' = [(pat, vars, wrap_repr_inst
-                                   $ mkConApp sum_con (map Type tys ++ [body]))
-                        | ((pat, vars, body), sum_con)
-                            <- zip alts (tyConDataCons sum_tc)]
-          return $ mkWildCase arg arg_ty res_ty alts'
-
-    con_alt (ConRepr con r)
-      = do
-          (vars, body) <- to_prod r
-          return (DataAlt con, vars, body)
-
-    to_prod EmptyProd
-      = do
-          void <- builtin voidVar
-          return ([], Var void)
-
-    to_prod (UnaryProd comp)
-      = do
-          var  <- newLocalVar (fsLit "x") (compOrigType comp)
-          body <- to_comp (Var var) comp
-          return ([var], body)
-
-    to_prod(Prod { repr_tup_tc   = tup_tc
-                 , repr_comp_tys = tys
-                 , repr_comps    = comps })
-      = do
-          vars  <- newLocalVars (fsLit "x") (map compOrigType comps)
-          exprs <- zipWithM to_comp (map Var vars) comps
-          return (vars, mkConApp tup_con (map Type tys ++ exprs))
-      where
-        [tup_con] = tyConDataCons tup_tc
-
-    to_comp expr (Keep _ _) = return expr
-    to_comp expr (Wrap ty)  = do
-                                wrap_tc <- builtin wrapTyCon
-                                return $ wrapNewTypeBody wrap_tc [ty] expr
-
-
-buildFromPRepr :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr
-buildFromPRepr vect_tc repr_tc _ repr
-  = do
-      arg_ty <- mkPReprType res_ty
-      arg <- newLocalVar (fsLit "x") arg_ty
-
-      result <- from_sum (unwrapFamInstScrut repr_tc ty_args (Var arg))
-                         repr
-      return $ Lam arg result
-  where
-    ty_args = mkTyVarTys (tyConTyVars vect_tc)
-    res_ty  = mkTyConApp vect_tc ty_args
-
-    from_sum _ EmptySum
-      = do
-          dummy <- builtin fromVoidVar
-          return $ Var dummy `App` Type res_ty
-
-    from_sum expr (UnarySum r) = from_con expr r
-    from_sum expr (Sum { repr_sum_tc  = sum_tc
-                       , repr_con_tys = tys
-                       , repr_cons    = cons })
-      = do
-          vars  <- newLocalVars (fsLit "x") tys
-          es    <- zipWithM from_con (map Var vars) cons
-          return $ mkWildCase expr (exprType expr) res_ty
-                   [(DataAlt con, [var], e)
-                      | (con, var, e) <- zip3 (tyConDataCons sum_tc) vars es]
-
-    from_con expr (ConRepr con r)
-      = from_prod expr (mkConApp con $ map Type ty_args) r
-
-    from_prod _ con EmptyProd = return con
-    from_prod expr con (UnaryProd r)
-      = do
-          e <- from_comp expr r
-          return $ con `App` e
-     
-    from_prod expr con (Prod { repr_tup_tc   = tup_tc
-                             , repr_comp_tys = tys
-                             , repr_comps    = comps
-                             })
-      = do
-          vars <- newLocalVars (fsLit "y") tys
-          es   <- zipWithM from_comp (map Var vars) comps
-          return $ mkWildCase expr (exprType expr) res_ty
-                   [(DataAlt tup_con, vars, con `mkApps` es)]
-      where
-        [tup_con] = tyConDataCons tup_tc  
-
-    from_comp expr (Keep _ _) = return expr
-    from_comp expr (Wrap ty)
-      = do
-          wrap <- builtin wrapTyCon
-          return $ unwrapNewTypeBody wrap [ty] expr
-
-
-buildToArrPRepr :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr
-buildToArrPRepr vect_tc prepr_tc pdata_tc r
-  = do
-      arg_ty <- mkPDataType el_ty
-      res_ty <- mkPDataType =<< mkPReprType el_ty
-      arg    <- newLocalVar (fsLit "xs") arg_ty
-
-      pdata_co <- mkBuiltinCo pdataTyCon
-      let Just repr_co = tyConFamilyCoercion_maybe prepr_tc
-          co           = mkAppCo pdata_co
-                       . mkSymCo
-                       $ mkAxInstCo repr_co ty_args
-
-          scrut   = unwrapFamInstScrut pdata_tc ty_args (Var arg)
-
-      (vars, result) <- to_sum r
-
-      return . Lam arg
-             $ mkWildCase scrut (mkTyConApp pdata_tc ty_args) res_ty
-               [(DataAlt pdata_dc, vars, mkCast result co)]
-  where
-    ty_args = mkTyVarTys $ tyConTyVars vect_tc
-    el_ty   = mkTyConApp vect_tc ty_args
-
-    [pdata_dc] = tyConDataCons pdata_tc
-
-
-    to_sum EmptySum = do
-                        pvoid <- builtin pvoidVar
-                        return ([], Var pvoid)
-    to_sum (UnarySum r) = to_con r
-    to_sum (Sum { repr_psum_tc = psum_tc
-                , repr_sel_ty  = sel_ty
-                , repr_con_tys = tys
-                , repr_cons    = cons
-                })
-      = do
-          (vars, exprs) <- mapAndUnzipM to_con cons
-          sel <- newLocalVar (fsLit "sel") sel_ty
-          return (sel : concat vars, mk_result (Var sel) exprs)
-      where
-        [psum_con] = tyConDataCons psum_tc
-        mk_result sel exprs = wrapFamInstBody psum_tc tys
-                            $ mkConApp psum_con
-                            $ map Type tys ++ (sel : exprs)
-
-    to_con (ConRepr _ r) = to_prod r
-
-    to_prod EmptyProd = do
-                          pvoid <- builtin pvoidVar
-                          return ([], Var pvoid)
-    to_prod (UnaryProd r)
-      = do
-          pty  <- mkPDataType (compOrigType r)
-          var  <- newLocalVar (fsLit "x") pty
-          expr <- to_comp (Var var) r
-          return ([var], expr)
-
-    to_prod (Prod { repr_ptup_tc  = ptup_tc
-                  , repr_comp_tys = tys
-                  , repr_comps    = comps })
-      = do
-          ptys <- mapM (mkPDataType . compOrigType) comps
-          vars <- newLocalVars (fsLit "x") ptys
-          es   <- zipWithM to_comp (map Var vars) comps
-          return (vars, mk_result es)
-      where
-        [ptup_con] = tyConDataCons ptup_tc
-        mk_result exprs = wrapFamInstBody ptup_tc tys
-                        $ mkConApp ptup_con
-                        $ map Type tys ++ exprs
-
-    to_comp expr (Keep _ _) = return expr
-
-    -- FIXME: this is bound to be wrong!
-    to_comp expr (Wrap ty)
-      = do
-          wrap_tc  <- builtin wrapTyCon
-          pwrap_tc <- pdataReprTyConExact (mkTyConApp wrap_tc [ty])
-        return $ wrapNewTypeBody pwrap_tc [ty] expr
-
-
-buildFromArrPRepr :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr
-buildFromArrPRepr vect_tc prepr_tc pdata_tc r
-  = do
-      arg_ty <- mkPDataType =<< mkPReprType el_ty
-      res_ty <- mkPDataType el_ty
-      arg    <- newLocalVar (fsLit "xs") arg_ty
-
-      pdata_co <- mkBuiltinCo pdataTyCon
-      let Just repr_co = tyConFamilyCoercion_maybe prepr_tc
-          co           = mkAppCo pdata_co
-                       $ mkAxInstCo repr_co var_tys
-
-          scrut  = mkCast (Var arg) co
-
-          mk_result args = wrapFamInstBody pdata_tc var_tys
-                         $ mkConApp pdata_con
-                         $ map Type var_tys ++ args
-
-      (expr, _) <- fixV $ \ ~(_, args) ->
-                     from_sum res_ty (mk_result args) scrut r
-
-      return $ Lam arg expr
-    
-      -- (args, mk) <- from_sum res_ty scrut r
-      
-      -- let result = wrapFamInstBody pdata_tc var_tys
-      --           . mkConApp pdata_dc
-      --           $ map Type var_tys ++ args
-
-      -- return $ Lam arg (mk result)
-  where
-    var_tys = mkTyVarTys $ tyConTyVars vect_tc
-    el_ty   = mkTyConApp vect_tc var_tys
-
-    [pdata_con] = tyConDataCons pdata_tc
-
-    from_sum _ res _ EmptySum = return (res, [])
-    from_sum res_ty res expr (UnarySum r) = from_con res_ty res expr r
-    from_sum res_ty res expr (Sum { repr_psum_tc = psum_tc
-                                  , repr_sel_ty  = sel_ty
-                                  , repr_con_tys = tys
-                                  , repr_cons    = cons })
-      = do
-          sel  <- newLocalVar (fsLit "sel") sel_ty
-          ptys <- mapM mkPDataType tys
-          vars <- newLocalVars (fsLit "xs") ptys
-          (res', args) <- fold from_con res_ty res (map Var vars) cons
-          let scrut = unwrapFamInstScrut psum_tc tys expr
-              body  = mkWildCase scrut (exprType scrut) res_ty
-                      [(DataAlt psum_con, sel : vars, res')]
-          return (body, Var sel : args)
-      where
-        [psum_con] = tyConDataCons psum_tc
-
-
-    from_con res_ty res expr (ConRepr _ r) = from_prod res_ty res expr r
-
-    from_prod _ res _ EmptyProd = return (res, [])
-    from_prod res_ty res expr (UnaryProd r)
-      = from_comp res_ty res expr r
-    from_prod res_ty res expr (Prod { repr_ptup_tc  = ptup_tc
-                                    , repr_comp_tys = tys
-                                    , repr_comps    = comps })
-      = do
-          ptys <- mapM mkPDataType tys
-          vars <- newLocalVars (fsLit "ys") ptys
-          (res', args) <- fold from_comp res_ty res (map Var vars) comps
-          let scrut = unwrapFamInstScrut ptup_tc tys expr
-              body  = mkWildCase scrut (exprType scrut) res_ty
-                      [(DataAlt ptup_con, vars, res')]
-          return (body, args)
-      where
-        [ptup_con] = tyConDataCons ptup_tc
-
-    from_comp _ res expr (Keep _ _) = return (res, [expr])
-    from_comp _ res expr (Wrap ty)
-      = do
-          wrap_tc  <- builtin wrapTyCon
-          pwrap_tc <- pdataReprTyConExact (mkTyConApp wrap_tc [ty])
-          return (res, [unwrapNewTypeBody pwrap_tc [ty]
-                        $ unwrapFamInstScrut pwrap_tc [ty] expr])
-
-    fold f res_ty res exprs rs = foldrM f' (res, []) (zip exprs rs)
-      where
-        f' (expr, r) (res, args) = do
-                                     (res', args') <- f res_ty res expr r
-                                     return (res', args' ++ args)
index a08174d..6a57665 100644 (file)
@@ -1,23 +1,26 @@
-module Vectorise.Utils.Base (
-  voidType,
-  newLocalVVar,
-
-  mkDataConTagLit,
-  mkDataConTag, dataConTagZ,
-  mkBuiltinTyConApp,
-  mkBuiltinTyConApps,
-  mkWrapType,
-  mkClosureTypes,
-  mkPReprType,
-  mkPArrayType, splitPrimTyCon,
-  mkPArray,
-  mkPDataType,  mkPDatasType,
-  mkBuiltinCo,
-  mkVScrut,
-
-  pdataReprTyCon, pdataReprTyConExact, pdatasReprTyCon,
-  pdataReprDataCon, pdatasReprDataCon,
-  prDFunOfTyCon
+module Vectorise.Utils.Base 
+  ( voidType
+  , newLocalVVar
+
+  , mkDataConTag, dataConTagZ
+  , mkWrapType
+  , mkClosureTypes
+  , mkPReprType
+  , mkPDataType, mkPDatasType
+  , splitPrimTyCon
+  , mkBuiltinCo
+
+  , wrapNewTypeBodyOfWrap
+  , unwrapNewTypeBodyOfWrap
+  , wrapNewTypeBodyOfPDataWrap
+  , unwrapNewTypeBodyOfPDataWrap
+  , wrapNewTypeBodyOfPDatasWrap
+  , unwrapNewTypeBodyOfPDatasWrap
+  
+  , pdataReprTyCon
+  , pdataReprTyConExact
+  , pdatasReprTyConExact
+  , pdataUnwrapScrut
 ) where
 
 import Vectorise.Monad
@@ -28,24 +31,20 @@ import CoreSyn
 import CoreUtils
 import Coercion
 import Type
-import TypeRep
 import TyCon
 import DataCon
 import MkId
-import Literal
-import Outputable
 import FastString
-import ListSetOps
-
-import Control.Monad (liftM)
 
 
 -- Simple Types ---------------------------------------------------------------
+
 voidType :: VM Type
 voidType = mkBuiltinTyConApp voidTyCon []
 
 
 -- Name Generation ------------------------------------------------------------
+
 newLocalVVar :: FastString -> Type -> VM VVar
 newLocalVVar fs vty
   = do
@@ -56,70 +55,64 @@ newLocalVVar fs vty
 
 
 -- Constructors ---------------------------------------------------------------
-mkDataConTagLit :: DataCon -> Literal
-mkDataConTagLit = mkMachInt . toInteger . dataConTagZ
-
 
 mkDataConTag :: DataCon -> CoreExpr
 mkDataConTag = mkIntLitInt . dataConTagZ
 
-
 dataConTagZ :: DataCon -> Int
 dataConTagZ con = dataConTag con - fIRST_TAG
 
 
 -- Type Construction ----------------------------------------------------------
--- | Make an application of a builtin type constructor to some arguments.
-mkBuiltinTyConApp :: (Builtins -> TyCon) -> [Type] -> VM Type
-mkBuiltinTyConApp get_tc tys
- = do tc     <- builtin get_tc
-      return $ mkTyConApp tc tys
-
 
-mkBuiltinTyConApps :: (Builtins -> TyCon) -> [Type] -> Type -> VM Type
-mkBuiltinTyConApps get_tc tys ty
- = do tc     <- builtin get_tc
-      return $ foldr (mk tc) ty tys
-  where
-    mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2]
-
-
--- | Make an application of the 'Wrap' type constructor.
+-- |Make an application of the 'Wrap' type constructor.
+--
 mkWrapType :: Type -> VM Type
-mkWrapType ty  = mkBuiltinTyConApp wrapTyCon [ty]
-
+mkWrapType ty = mkBuiltinTyConApp wrapTyCon [ty]
 
--- | Make an application of the closure type constructor.
+-- |Make an application of the closure type constructor.
+--
 mkClosureTypes :: [Type] -> Type -> VM Type
 mkClosureTypes = mkBuiltinTyConApps closureTyCon
 
-
--- | Make an application of the 'PRepr' type constructor.
+-- |Make an application of the 'PRepr' type constructor.
+--
 mkPReprType :: Type -> VM Type
 mkPReprType ty = mkBuiltinTyConApp preprTyCon [ty]
 
-
--- | Wrap a type into 'PArray', treating unboxed types specially.
-mkPArrayType :: Type -> VM Type
-mkPArrayType ty
-  | Just tycon <- splitPrimTyCon ty
-  = do { arr <- builtin (parray_PrimTyCon tycon)
-       ; return $ mkTyConApp arr []
-       }
-mkPArrayType ty = mkBuiltinTyConApp parrayTyCon [ty]
-
-
 -- | Make an appliction of the 'PData' tycon to some argument.
+--
 mkPDataType :: Type -> VM Type
-mkPDataType ty  = mkBuiltinTyConApp pdataTyCon [ty]
-
+mkPDataType ty = mkBuiltinTyConApp pdataTyCon [ty]
 
 -- | Make an application of the 'PDatas' tycon to some argument.
+--
 mkPDatasType :: Type -> VM Type
 mkPDatasType ty = mkBuiltinTyConApp pdatasTyCon [ty]
 
+-- Make an application of a builtin type constructor to some arguments.
+--
+mkBuiltinTyConApp :: (Builtins -> TyCon) -> [Type] -> VM Type
+mkBuiltinTyConApp get_tc tys
+  = do { tc <- builtin get_tc
+       ; return $ mkTyConApp tc tys
+       }
+
+-- Make a cascading application of a builtin type constructor.
+--
+mkBuiltinTyConApps :: (Builtins -> TyCon) -> [Type] -> Type -> VM Type
+mkBuiltinTyConApps get_tc tys ty
+ = do { tc <- builtin get_tc
+      ; return $ foldr (mk tc) ty tys
+      }
+  where
+    mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2]
+
+
+-- Type decomposition ---------------------------------------------------------
 
 -- |Checks if a type constructor is defined in 'GHC.Prim' (e.g., 'Int#'); if so, returns it.
+--
 splitPrimTyCon :: Type -> Maybe TyCon
 splitPrimTyCon ty
   | Just (tycon, []) <- splitTyConApp_maybe ty
@@ -128,38 +121,73 @@ splitPrimTyCon ty
   | otherwise = Nothing
 
 
+-- Coercion Construction -----------------------------------------------------
 
--- CoreExpr Construction ------------------------------------------------------
--- | Make an application of the 'PArray' data constructor.
-mkPArray 
-        :: Type         -- ^ Element type
-        -> CoreExpr     -- ^ 'Int'   for the array length.
-        -> CoreExpr     -- ^ 'PData' for the array data.
-        -> VM CoreExpr
+-- |Make a coersion to some builtin type.
+--
+mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion
+mkBuiltinCo get_tc
+  = do { tc <- builtin get_tc
+       ; return $ mkTyConAppCo tc []
+       }
 
-mkPArray ty len dat 
- = do   tc <- builtin parrayTyCon
-        let [dc] = tyConDataCons tc
-        return $ mkConApp dc [Type ty, len, dat]
 
+-- Wrapping and unwrapping the 'Wrap' newtype ---------------------------------
 
--- Coercion Construction -----------------------------------------------------
--- | Make a coersion to some builtin type.
-mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion
-mkBuiltinCo get_tc
- = do tc     <- builtin get_tc
-      return $ mkTyConAppCo tc []
+-- |Apply the constructor wrapper of the 'Wrap' /newtype/.
+--
+wrapNewTypeBodyOfWrap :: CoreExpr -> Type -> VM CoreExpr
+wrapNewTypeBodyOfWrap e ty
+  = do { wrap_tc <- builtin wrapTyCon
+       ; return $ wrapNewTypeBody wrap_tc [ty] e
+       }
+
+-- |Strip the constructor wrapper of the 'Wrap' /newtype/.
+--
+unwrapNewTypeBodyOfWrap :: CoreExpr -> Type -> VM CoreExpr
+unwrapNewTypeBodyOfWrap e ty
+  = do { wrap_tc <- builtin wrapTyCon
+       ; return $ unwrapNewTypeBody wrap_tc [ty] e
+       }
 
+-- |Apply the constructor wrapper of the 'PData' /newtype/ instance of 'Wrap'.
+--
+wrapNewTypeBodyOfPDataWrap :: CoreExpr -> Type -> VM CoreExpr
+wrapNewTypeBodyOfPDataWrap e ty
+  = do { wrap_tc  <- builtin wrapTyCon
+       ; pwrap_tc <- pdataReprTyConExact wrap_tc
+       ; return $ wrapFamInstBody pwrap_tc [ty] (wrapNewTypeBody pwrap_tc [ty] e)
+       }
 
--------------------------------------------------------------------------------
+-- |Strip the constructor wrapper of the 'PData' /newtype/ instance of 'Wrap'.
+--
+unwrapNewTypeBodyOfPDataWrap :: CoreExpr -> Type -> VM CoreExpr
+unwrapNewTypeBodyOfPDataWrap e ty
+  = do { wrap_tc  <- builtin wrapTyCon
+       ; pwrap_tc <- pdataReprTyConExact wrap_tc
+       ; return $ unwrapNewTypeBody pwrap_tc [ty] (unwrapFamInstScrut pwrap_tc [ty] e)
+       }
 
-mkVScrut :: VExpr -> VM (CoreExpr, CoreExpr, TyCon, [Type])
-mkVScrut (ve, le)
-  = do
-      (tc, arg_tys) <- pdataReprTyCon ty
-      return (ve, unwrapFamInstScrut tc arg_tys le, tc, arg_tys)
-  where
-    ty = exprType ve
+-- |Apply the constructor wrapper of the 'PDatas' /newtype/ instance of 'Wrap'.
+--
+wrapNewTypeBodyOfPDatasWrap :: CoreExpr -> Type -> VM CoreExpr
+wrapNewTypeBodyOfPDatasWrap e ty
+  = do { wrap_tc  <- builtin wrapTyCon
+       ; pwrap_tc <- pdatasReprTyConExact wrap_tc
+       ; return $ wrapFamInstBody pwrap_tc [ty] (wrapNewTypeBody pwrap_tc [ty] e)
+       }
+
+-- |Strip the constructor wrapper of the 'PDatas' /newtype/ instance of 'Wrap'.
+--
+unwrapNewTypeBodyOfPDatasWrap :: CoreExpr -> Type -> VM CoreExpr
+unwrapNewTypeBodyOfPDatasWrap e ty
+  = do { wrap_tc  <- builtin wrapTyCon
+       ; pwrap_tc <- pdatasReprTyConExact wrap_tc
+       ; return $ unwrapNewTypeBody pwrap_tc [ty] (unwrapFamInstScrut pwrap_tc [ty] e)
+       }
+
+
+-- 'PData' representation types ----------------------------------------------
 
 -- |Get the representation tycon of the 'PData' data family for a given type.
 --
@@ -175,43 +203,41 @@ mkVScrut (ve, le)
 pdataReprTyCon :: Type -> VM (TyCon, [Type])
 pdataReprTyCon ty = builtin pdataTyCon >>= (`lookupFamInst` [ty])
 
--- |Get the representation tycon of the 'PData' data family for a given type which must match the
--- type index in the looked up 'PData' instance exactly.
---
-pdataReprTyConExact :: Type -> VM TyCon
-pdataReprTyConExact ty
-  = do { (tycon, tys) <- pdataReprTyCon ty
-       ; if uniqueTyVars tys
-         then
-           return tycon
-         else
-           cantVectorise "No exact 'PData' family instance for" (ppr ty)
-       } 
-  where
-    uniqueTyVars tys = all isTyVarTy tys && hasNoDups (map extractTyVar tys)
-      where
-        extractTyVar (TyVarTy tv) = tv
-        extractTyVar _            = panic "Vectorise.Utils.Base: extractTyVar"
-
-pdataReprDataCon :: Type -> VM (DataCon, [Type])
-pdataReprDataCon ty
-  = do { (tc, arg_tys) <- pdataReprTyCon ty
-       ; let [dc] = tyConDataCons tc
-       ; return (dc, arg_tys)
+-- |Get the representation tycon of the 'PData' data family for a given type constructor.
+--
+-- For example, for a binary type constructor 'T', we determine the representation type constructor
+-- for 'PData (T a b)'.
+--
+pdataReprTyConExact :: TyCon -> VM TyCon
+pdataReprTyConExact tycon
+  = do {   -- look up the representation tycon; if there is a match at all, it will be be exact
+       ;   -- (i.e.,' _tys' will be distinct type variables)
+       ; (ptycon, _tys) <- pdataReprTyCon (tycon `mkTyConApp` mkTyVarTys (tyConTyVars tycon))
+       ; return ptycon
        }
 
-pdatasReprTyCon :: Type -> VM (TyCon, [Type])
-pdatasReprTyCon ty = builtin pdatasTyCon >>= (`lookupFamInst` [ty])
+-- |Get the representation tycon of the 'PDatas' data family for a given type constructor.
+--
+-- For example, for a binary type constructor 'T', we determine the representation type constructor
+-- for 'PDatas (T a b)'.
+--
+pdatasReprTyConExact :: TyCon -> VM TyCon
+pdatasReprTyConExact tycon
+  = do {   -- look up the representation tycon; if there is a match at all, it will be be exact
+       ;   -- (i.e.,' _tys' will be distinct type variables)
+       ; (ptycon, _tys) <- pdatasReprTyCon (tycon `mkTyConApp` mkTyVarTys (tyConTyVars tycon))
+       ; return ptycon
+       }
+  where
+    pdatasReprTyCon ty = builtin pdatasTyCon >>= (`lookupFamInst` [ty])
 
-pdatasReprDataCon :: Type -> VM (DataCon, [Type])
-pdatasReprDataCon ty
-  = do { (tc, arg_tys) <- pdatasReprTyCon ty
+-- |Unwrap a 'PData' representation scrutinee.
+--
+pdataUnwrapScrut :: VExpr -> VM (CoreExpr, CoreExpr, DataCon)
+pdataUnwrapScrut (ve, le)
+  = do { (tc, arg_tys) <- pdataReprTyCon ty
        ; let [dc] = tyConDataCons tc
-       ; return (dc, arg_tys)
+       ; return (ve, unwrapFamInstScrut tc arg_tys le, dc)
        }
-
-prDFunOfTyCon :: TyCon -> VM CoreExpr
-prDFunOfTyCon tycon
-  = liftM Var
-  . maybeCantVectoriseM "No PR dictionary for tycon" (ppr tycon)
-  $ lookupTyConPR tycon
+  where
+    ty = exprType ve
index 5a38ecd..164ebae 100644 (file)
@@ -75,11 +75,12 @@ paDictOfType ty
     -- the representation type if the tycon is polymorphic
     paDictOfTyApp (TyConApp tc []) ty_args
      = do
-         dfun <- maybeCantVectoriseM "No PA dictionary for type constructor"
-                                      (ppr tc <+> text "in" <+> ppr ty)
+         dfun <- maybeCantVectoriseM noPADictErr (ppr tc <+> text "in" <+> ppr ty)
                 $ lookupTyConPA tc
          dicts <- mapM paDictOfType ty_args
          return $ Var dfun `mkTyApps` ty_args `mkApps` dicts
+     where
+       noPADictErr = "No PA dictionary for type constructor (did you import 'Data.Array.Parallel'?)"
 
     paDictOfTyApp _ _ = failure