+import FastString
+import Control.Monad
+
+
+collectAnnTypeArgs :: AnnExpr b ann -> (AnnExpr b ann, [Type])
+collectAnnTypeArgs expr = go expr []
+ where
+ go (_, AnnApp f (_, AnnType ty)) tys = go f (ty : tys)
+ go e tys = (e, tys)
+
+collectAnnTypeBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann)
+collectAnnTypeBinders expr = go [] expr
+ where
+ go bs (_, AnnLam b e) | isTyVar b = go (b:bs) e
+ go bs e = (reverse bs, e)
+
+collectAnnValBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann)
+collectAnnValBinders expr = go [] expr
+ where
+ go bs (_, AnnLam b e) | isId b = go (b:bs) e
+ go bs e = (reverse bs, e)
+
+isAnnTypeArg :: AnnExpr b ann -> Bool
+isAnnTypeArg (_, AnnType _) = True
+isAnnTypeArg _ = False
+
+dataConTagZ :: DataCon -> Int
+dataConTagZ con = dataConTag con - fIRST_TAG
+
+mkDataConTagLit :: DataCon -> Literal
+mkDataConTagLit = mkMachInt . toInteger . dataConTagZ
+
+mkDataConTag :: DataCon -> CoreExpr
+mkDataConTag = mkIntLitInt . dataConTagZ
+
+splitPrimTyCon :: Type -> Maybe TyCon
+splitPrimTyCon ty
+ | Just (tycon, []) <- splitTyConApp_maybe ty
+ , isPrimTyCon tycon
+ = Just tycon
+
+ | otherwise = Nothing
+
+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]
+
+voidType :: VM Type
+voidType = mkBuiltinTyConApp voidTyCon []
+
+mkWrapType :: Type -> VM Type
+mkWrapType ty = mkBuiltinTyConApp wrapTyCon [ty]
+
+
+mkClosureTypes :: [Type] -> Type -> VM Type
+mkClosureTypes = mkBuiltinTyConApps closureTyCon
+
+mkPReprType :: Type -> VM Type
+mkPReprType ty = mkBuiltinTyConApp preprTyCon [ty]
+
+mkPADictType :: Type -> VM Type
+mkPADictType ty = mkBuiltinTyConApp paTyCon [ty]
+
+mkPArrayType :: Type -> VM Type
+mkPArrayType ty
+ | Just tycon <- splitPrimTyCon ty
+ = do
+ r <- lookupPrimPArray tycon
+ case r of
+ Just arr -> return $ mkTyConApp arr []
+ Nothing -> cantVectorise "Primitive tycon not vectorised" (ppr tycon)
+mkPArrayType ty = mkBuiltinTyConApp parrayTyCon [ty]
+
+mkPDataType :: Type -> VM Type
+mkPDataType ty = mkBuiltinTyConApp pdataTyCon [ty]
+
+mkPArray :: Type -> CoreExpr -> CoreExpr -> VM CoreExpr
+mkPArray ty len dat = do
+ tc <- builtin parrayTyCon
+ let [dc] = tyConDataCons tc
+ return $ mkConApp dc [Type ty, len, dat]
+
+mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion
+mkBuiltinCo get_tc
+ = do
+ tc <- builtin get_tc
+ return $ mkTyConApp tc []
+
+pdataReprTyCon :: Type -> VM (TyCon, [Type])
+pdataReprTyCon ty = builtin pdataTyCon >>= (`lookupFamInst` [ty])
+
+pdataReprDataCon :: Type -> VM (DataCon, [Type])
+pdataReprDataCon ty
+ = do
+ (tc, arg_tys) <- pdataReprTyCon ty
+ let [dc] = tyConDataCons tc
+ return (dc, arg_tys)
+
+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
+
+prDFunOfTyCon :: TyCon -> VM CoreExpr
+prDFunOfTyCon tycon
+ = liftM Var
+ . maybeCantVectoriseM "No PR dictionary for tycon" (ppr tycon)
+ $ lookupTyConPR tycon
+