X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fvectorise%2FVectorise.hs;h=024ae45a20bbb1ad7055ebba5001c1a5f203304e;hb=d40970b835f4fddb099e67a0d4ed684ed6802d23;hp=c5011633c628c058023c0d5c828a4502d112f190;hpb=d755f7e69b58791faf56345c2dbaa7793c3700ab;p=ghc-hetmet.git diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index c501163..024ae45 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -8,8 +8,6 @@ module Vectorise( vectorise ) where -#include "HsVersions.h" - import VectMonad import VectUtils import VectType @@ -70,10 +68,10 @@ vectModule :: ModGuts -> VM ModGuts vectModule guts = do (types', fam_insts, tc_binds) <- vectTypeEnv (mg_types guts) - + let fam_inst_env' = extendFamInstEnvList (mg_fam_inst_env guts) fam_insts updGEnv (setFamInstEnv fam_inst_env') - + -- dicts <- mapM buildPADict pa_insts -- workers <- mapM vectDataConWorkers pa_insts binds' <- mapM vectTopBind (mg_binds guts) @@ -113,7 +111,7 @@ vectTopBinder var var' <- cloneId mkVectOcc var vty defGlobalVar var var' return var' - + vectTopRhs :: Var -> CoreExpr -> VM CoreExpr vectTopRhs var expr = do @@ -131,8 +129,7 @@ tryConvert var vect_var rhs vectBndr :: Var -> VM VVar vectBndr v = do - vty <- vectType (idType v) - lty <- mkPArrayType vty + (vty, lty) <- vectAndLiftType (idType v) let vv = v `Id.setIdType` vty lv = v `Id.setIdType` lty updLEnv (mapTo vv lv) @@ -224,8 +221,8 @@ vectPolyExpr expr mono' <- vectExpr mono return $ mapVect abstract mono' where - (tvs, mono) = collectAnnTypeBinders expr - + (tvs, mono) = collectAnnTypeBinders expr + vectExpr :: CoreExprWithFVs -> VM VExpr vectExpr (_, AnnType ty) = liftM vType (vectType ty) @@ -252,7 +249,7 @@ vectExpr (_, AnnApp (_, AnnVar v) (_, AnnLit lit)) return (vexpr, lexpr) where is_special_con con = con `elem` [intDataCon, floatDataCon, doubleDataCon] - + vectExpr (_, AnnApp fn arg) = do @@ -320,7 +317,7 @@ vectLam fvs bs body (vbndrs, vbody) <- vectBndrsIn (vs ++ bs) (vectExpr body) return $ vLams lc vbndrs vbody - + vectTyAppExpr :: CoreExprWithFVs -> [Type] -> VM VExpr vectTyAppExpr (_, AnnVar v) tys = vectPolyVar v tys vectTyAppExpr e tys = pprPanic "vectTyAppExpr" (ppr $ deAnnotate e) @@ -339,31 +336,28 @@ type CoreAltWithFVs = AnnAlt Id VarSet -- When lifting, we have to do it this way because v must have the type -- [:V(T):] but the scrutinee must be cast to the representation type. We also -- have to handle the case where v is a wild var correctly. --- +-- -- FIXME: this is too lazy vectAlgCase tycon ty_args scrut bndr ty [(DEFAULT, [], body)] = do - vscrut <- vectExpr scrut - vty <- vectType ty - lty <- mkPArrayType vty + vscrut <- vectExpr scrut + (vty, lty) <- vectAndLiftType ty (vbndr, vbody) <- vectBndrIn bndr (vectExpr body) return $ vCaseDEFAULT vscrut vbndr vty lty vbody vectAlgCase tycon ty_args scrut bndr ty [(DataAlt dc, [], body)] = do - vscrut <- vectExpr scrut - vty <- vectType ty - lty <- mkPArrayType vty + vscrut <- vectExpr scrut + (vty, lty) <- vectAndLiftType ty (vbndr, vbody) <- vectBndrIn bndr (vectExpr body) return $ vCaseDEFAULT vscrut vbndr vty lty vbody vectAlgCase tycon ty_args scrut bndr ty [(DataAlt dc, bndrs, body)] = do - vect_tc <- maybeV (lookupTyCon tycon) - vty <- vectType ty - lty <- mkPArrayType vty - vexpr <- vectExpr scrut + vect_tc <- maybeV (lookupTyCon tycon) + (vty, lty) <- vectAndLiftType ty + vexpr <- vectExpr scrut (vbndr, (vbndrs, vbody)) <- vect_scrut_bndr . vectBndrsIn bndrs $ vectExpr body @@ -376,15 +370,13 @@ vectAlgCase tycon ty_args scrut bndr ty [(DataAlt dc, bndrs, body)] return . vLet (vNonRec vbndr vexpr) $ vCaseProd vscrut vty lty vect_dc arr_dc shape_bndrs vbndrs vbody where - vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr FSLIT("scrut") + vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr (fsLit "scrut") | otherwise = vectBndrIn bndr vectAlgCase tycon ty_args scrut bndr ty alts = do - vect_tc <- maybeV (lookupTyCon tycon) - vty <- vectType ty - lty <- mkPArrayType vty - + vect_tc <- maybeV (lookupTyCon tycon) + (vty, lty) <- vectAndLiftType ty repr <- mkRepr vect_tc shape_bndrs <- arrShapeVars repr (len, sel, indices) <- arrSelector repr (map Var shape_bndrs) @@ -410,7 +402,7 @@ vectAlgCase tycon ty_args scrut bndr ty alts return . vLet (vNonRec vbndr vexpr) $ (vect_case, lift_case) where - vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr FSLIT("scrut") + vect_scrut_bndr | isDeadBinder bndr = vectBndrNewIn bndr (fsLit "scrut") | otherwise = vectBndrIn bndr alts' = sortBy (\(alt1, _, _) (alt2, _, _) -> cmp alt1 alt2) alts @@ -437,7 +429,7 @@ vectAlgCase tycon ty_args scrut bndr ty alts void_tc <- builtin voidTyCon let void_ty = mkTyConApp void_tc [] arr_ty <- mkPArrayType void_ty - bndr <- newLocalVar FSLIT("voids") arr_ty + bndr <- newLocalVar (fsLit "voids") arr_ty len <- lengthPA void_ty (Var bndr) e <- p len return ([], [bndr], e) @@ -461,7 +453,7 @@ packLiftingContext len shape tag fvs vty lty p = do select <- builtin selectPAIntPrimVar let sel_expr = mkApps (Var select) [shape, tag] - sel_var <- newLocalVar FSLIT("sel#") (exprType sel_expr) + sel_var <- newLocalVar (fsLit "sel#") (exprType sel_expr) lc_var <- builtin liftingContext localV $ do @@ -471,9 +463,8 @@ packLiftingContext len shape tag fvs vty lty p (vexpr, lexpr) <- p empty <- emptyPA vty return (vexpr, Let (NonRec sel_var sel_expr) - . mkLets (concat bnds) $ Case len lc_var lty - [(DEFAULT, [], lexpr), + [(DEFAULT, [], mkLets (concat bnds) lexpr), (LitAlt (mkMachInt 0), [], empty)]) packFreeVar :: CoreExpr -> CoreExpr -> Var -> VM [CoreBind]