projects / ghc-hetmet.git / commitdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | patch | inline | side by side (parent: 2e4068a)
Remove Embed and related stuff from vectorisation
authorRoman Leshchinskiy <rl@cse.unsw.edu.au>
Fri, 24 Aug 2007 02:30:30 +0000 (02:30 +0000)
committerRoman Leshchinskiy <rl@cse.unsw.edu.au>
Fri, 24 Aug 2007 02:30:30 +0000 (02:30 +0000)
compiler/prelude/PrelNames.lhs patch | blob | history
compiler/vectorise/VectBuiltIn.hs patch | blob | history
compiler/vectorise/VectUtils.hs patch | blob | history

diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 9839290..49ff539 100644 (file)
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -218,7 +218,7 @@ genericTyConNames = [crossTyConName, plusTyConName, genUnitTyConName]
 
 ndpNames :: [Name]
 ndpNames = [ parrayTyConName, paTyConName, preprTyConName, prTyConName
-           , embedTyConName
+           , mkPRName
            , closureTyConName
            , mkClosureName, applyClosureName
            , mkClosurePName, applyClosurePName
@@ -698,7 +698,7 @@ parrayTyConName     = tcQual   nDP_PARRAY FSLIT("PArray") parrayTyConKey
 paTyConName         = tcQual   nDP_PARRAY FSLIT("PA")     paTyConKey
 preprTyConName      = tcQual   nDP_PARRAY FSLIT("PRepr")  preprTyConKey
 prTyConName         = clsQual  nDP_PARRAY FSLIT("PR")     prTyConKey
-embedTyConName      = tcQual   nDP_REPR   FSLIT("Embed")  embedTyConKey
+mkPRName            = varQual  nDP_PARRAY FSLIT("mkPR")   mkPRIdKey
 lengthPAName        = varQual  nDP_PARRAY FSLIT("lengthPA")    lengthPAIdKey
 replicatePAName     = varQual  nDP_PARRAY FSLIT("replicatePA") replicatePAIdKey
 emptyPAName         = varQual  nDP_PARRAY FSLIT("emptyPA") emptyPAIdKey
@@ -893,8 +893,7 @@ parrayTyConKey                          = mkPreludeTyConUnique 135
 closureTyConKey                         = mkPreludeTyConUnique 136
 paTyConKey                              = mkPreludeTyConUnique 137
 preprTyConKey                           = mkPreludeTyConUnique 138
-embedTyConKey                           = mkPreludeTyConUnique 139
-prTyConKey                              = mkPreludeTyConUnique 140
+prTyConKey                              = mkPreludeTyConUnique 139
 
 
 ---------------- Template Haskell -------------------
@@ -1088,6 +1087,7 @@ emptyPAIdKey                  = mkPreludeMiscIdUnique 133
 packPAIdKey                   = mkPreludeMiscIdUnique 134
 combinePAIdKey                = mkPreludeMiscIdUnique 135
 intEqPAIdKey                  = mkPreludeMiscIdUnique 136
+mkPRIdKey                     = mkPreludeMiscIdUnique 137
 
 ---------------- Template Haskell -------------------
 --     USES IdUniques 200-399
diff --git a/compiler/vectorise/VectBuiltIn.hs b/compiler/vectorise/VectBuiltIn.hs
index 0afef5b..0b8c047 100644 (file)
--- a/compiler/vectorise/VectBuiltIn.hs
+++ b/compiler/vectorise/VectBuiltIn.hs
@@ -41,10 +41,9 @@ data Builtins = Builtins {
                 , preprTyCon       :: TyCon
                 , prTyCon          :: TyCon
                 , prDataCon        :: DataCon
-                , embedTyCon       :: TyCon
-                , embedDataCon     :: DataCon
                 , sumTyCons        :: Array Int TyCon
                 , closureTyCon     :: TyCon
+                , mkPRVar          :: Var
                 , mkClosureVar     :: Var
                 , applyClosureVar  :: Var
                 , mkClosurePVar    :: Var
@@ -78,8 +77,6 @@ initBuiltins
       preprTyCon   <- dsLookupTyCon preprTyConName
       prTyCon      <- dsLookupTyCon prTyConName
       let [prDataCon] = tyConDataCons prTyCon
-      embedTyCon   <- dsLookupTyCon embedTyConName
-      let [embedDataCon] = tyConDataCons embedTyCon
       closureTyCon <- dsLookupTyCon closureTyConName
 
       sum_tcs <- mapM (lookupExternalTyCon nDP_REPR)
@@ -87,6 +84,7 @@ initBuiltins
 
       let sumTyCons = listArray (2, mAX_NDP_SUM) sum_tcs
 
+      mkPRVar          <- dsLookupGlobalId mkPRName
       mkClosureVar     <- dsLookupGlobalId mkClosureName
       applyClosureVar  <- dsLookupGlobalId applyClosureName
       mkClosurePVar    <- dsLookupGlobalId mkClosurePName
@@ -108,10 +106,9 @@ initBuiltins
                , preprTyCon       = preprTyCon
                , prTyCon          = prTyCon
                , prDataCon        = prDataCon
-               , embedTyCon       = embedTyCon
-               , embedDataCon     = embedDataCon
                , sumTyCons        = sumTyCons
                , closureTyCon     = closureTyCon
+               , mkPRVar          = mkPRVar
                , mkClosureVar     = mkClosureVar
                , applyClosureVar  = applyClosureVar
                , mkClosurePVar    = mkClosurePVar
@@ -168,7 +165,6 @@ builtinPRs :: Builtins -> [(Name, Module, FastString)]
 builtinPRs bi =
   [
     mk (tyConName unitTyCon) nDP_REPR      FSLIT("dPR_Unit")
-  , mk embedTyConName        nDP_REPR      FSLIT("dPR_Embed")
   , mk closureTyConName      nDP_CLOSURE   FSLIT("dPR_Clo")
 
     -- temporary
diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs
index 5d03521..9101178 100644 (file)
--- a/compiler/vectorise/VectUtils.hs
+++ b/compiler/vectorise/VectUtils.hs
@@ -94,9 +94,6 @@ splitFixedTyConApp tc ty
 
   | otherwise = pprPanic "splitFixedTyConApp" (ppr tc <+> ppr ty)
 
-splitEmbedTy :: Type -> Type
-splitEmbedTy = splitUnTy "splitEmbedTy" embedTyConName
-
 splitClosureTy :: Type -> (Type, Type)
 splitClosureTy = splitBinTy "splitClosureTy" closureTyConName
 
@@ -132,7 +129,6 @@ data TyConRepr = TyConRepr {
                    repr_tyvars      :: [TyVar]
                  , repr_tys         :: [[Type]]
 
-                 , repr_embed_tys   :: [[Type]]
                  , repr_prod_tycons :: [Maybe TyCon]
                  , repr_prod_tys    :: [Type]
                  , repr_sum_tycon   :: Maybe TyCon
@@ -142,17 +138,15 @@ data TyConRepr = TyConRepr {
 mkTyConRepr :: TyCon -> VM TyConRepr
 mkTyConRepr vect_tc
   = do
-      embed_tys <- mapM (mapM mkEmbedType) rep_tys
       prod_tycons <- mapM (mk_tycon prodTyCon) rep_tys
-      sum_tycon   <- mk_tycon sumTyCon rep_tys
+      let prod_tys = zipWith mk_tc_app_maybe prod_tycons rep_tys
+      sum_tycon   <- mk_tycon sumTyCon prod_tys
 
-      let prod_tys = zipWith mk_tc_app_maybe prod_tycons embed_tys
 
       return $ TyConRepr {
                  repr_tyvars      = tyvars
                , repr_tys         = rep_tys
 
-               , repr_embed_tys   = embed_tys
                , repr_prod_tycons = prod_tycons
                , repr_prod_tys    = prod_tys
                , repr_sum_tycon   = sum_tycon
@@ -198,8 +192,6 @@ mkPRepr tys
 mkToPRepr :: [[CoreExpr]] -> VM ([CoreExpr], Type)
 mkToPRepr ess
   = do
-      embed_tc <- builtin embedTyCon
-      embed_dc <- builtin embedDataCon
       sum_tcs  <- builtins sumTyCon
       prod_tcs <- builtins prodTyCon
 
@@ -212,28 +204,20 @@ mkToPRepr ess
               sum_tc         = sum_tcs (length es)
               mk_alt dc expr = mkConApp dc (map Type tys ++ [expr])
 
-          mk_prod [] = (Var unitDataConId, unitTy)
-          mk_prod [(expr, ty)] = (expr, ty)
-          mk_prod es = (mkConApp prod_dc (map Type tys ++ exprs),
-                        mkTyConApp prod_tc tys)
+          mk_prod []     = (Var unitDataConId, unitTy)
+          mk_prod [expr] = (expr, exprType expr)
+          mk_prod exprs  = (mkConApp prod_dc (map Type tys ++ exprs),
+                            mkTyConApp prod_tc tys)
             where
-              (exprs, tys) = unzip es
-              prod_tc      = prod_tcs (length es)
+              tys          = map exprType exprs
+              prod_tc      = prod_tcs (length exprs)
               [prod_dc]    = tyConDataCons prod_tc
 
-          mk_embed expr = (mkConApp embed_dc [Type ty, expr],
-                           mkTyConApp embed_tc [ty])
-            where ty = exprType expr
-
-      return . mk_sum $ map (mk_prod . map mk_embed) ess
+      return . mk_sum . map mk_prod $ ess
 
 mkToArrPRepr :: CoreExpr -> CoreExpr -> [[CoreExpr]] -> VM CoreExpr
 mkToArrPRepr len sel ess
   = do
-      embed_tc <- builtin embedTyCon
-      (embed_rtc, _) <- parrayReprTyCon (mkTyConApp embed_tc [unitTy])
-      let [embed_rdc] = tyConDataCons embed_rtc
-
       let mk_sum [(expr, ty)] = return (expr, ty)
           mk_sum es
             = do
@@ -246,28 +230,23 @@ mkToArrPRepr len sel ess
             where
               (exprs, tys) = unzip es
 
-          mk_prod [(expr, ty)] = return (expr, ty)
-          mk_prod es
+          mk_prod [expr] = return (expr, splitPArrayTy (exprType expr))
+          mk_prod exprs
             = do
-                prod_tc <- builtin . prodTyCon $ length es
+                prod_tc <- builtin . prodTyCon $ length exprs
                 (prod_rtc, _) <- parrayReprTyCon (mkTyConApp prod_tc tys)
                 let [prod_rdc] = tyConDataCons prod_rtc
 
                 return (mkConApp prod_rdc (map Type tys ++ (len : exprs)),
                         mkTyConApp prod_tc tys)
             where
-              (exprs, tys) = unzip es
-
-          mk_embed expr = (mkConApp embed_rdc [Type ty, expr],
-                           mkTyConApp embed_tc [ty])
-            where ty = splitPArrayTy (exprType expr)
+              tys = map (splitPArrayTy . exprType) exprs
 
-      liftM fst (mk_sum =<< mapM (mk_prod . map mk_embed) ess)
+      liftM fst (mk_sum =<< mapM mk_prod ess)
 
 mkFromPRepr :: CoreExpr -> Type -> [([Var], CoreExpr)] -> VM CoreExpr
 mkFromPRepr scrut res_ty alts
   = do
-      embed_dc <- builtin embedDataCon
       sum_tcs  <- builtins sumTyCon
       prod_tcs <- builtins prodTyCon
 
@@ -288,23 +267,14 @@ mkFromPRepr scrut res_ty alts
               mk_alt dc p body = (DataAlt dc, [p], body)
 
           un_prod expr ty []    r = return r
-          un_prod expr ty [var] r = return $ un_embed expr ty var r
+          un_prod expr ty [var] r = return $ Let (NonRec var expr) r
           un_prod expr ty vars  r
-            = do
-                xs <- mapM (newLocalVar FSLIT("x")) tys
-                let body = foldr (\(e,t,v) r -> un_embed e t v r) r
-                         $ zip3 (map Var xs) tys vars
-                return $ Case expr (mkWildId ty) res_ty
-                         [(DataAlt prod_dc, xs, body)]
+            = return $ Case expr (mkWildId ty) res_ty
+                       [(DataAlt prod_dc, vars, r)]
             where
-              tys       = splitFixedTyConApp prod_tc ty
               prod_tc   = prod_tcs $ length vars
               [prod_dc] = tyConDataCons prod_tc
 
-          un_embed expr ty var r
-            = Case expr (mkWildId ty) res_ty
-                [(DataAlt embed_dc, [var], r)]
-
       un_sum scrut (exprType scrut) alts
 
 mkFromArrPRepr :: CoreExpr -> Type -> Var -> Var -> [[Var]] -> CoreExpr
@@ -312,9 +282,6 @@ mkFromArrPRepr :: CoreExpr -> Type -> Var -> Var -> [[Var]] -> CoreExpr
 mkFromArrPRepr scrut res_ty len sel vars res
   = return (Var unitDataConId)
 
-mkEmbedType :: Type -> VM Type
-mkEmbedType ty = mkBuiltinTyConApp embedTyCon [ty]
-
 mkClosureType :: Type -> Type -> VM Type
 mkClosureType arg_ty res_ty = mkBuiltinTyConApp closureTyCon [arg_ty, res_ty]
 
@@ -460,6 +427,9 @@ paMethod method ty
       dict <- paDictOfType ty
       return $ mkApps (Var fn) [Type ty, dict]
 
+mkPR :: Type -> VM CoreExpr
+mkPR = paMethod mkPRVar
+
 lengthPA :: CoreExpr -> VM CoreExpr
 lengthPA x = liftM (`App` x) (paMethod lengthPAVar ty)
   where
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)