PADict.hs

module Vectorise.Utils.PADict (
  paDictArgType,
  paDictOfType,
  paMethod,
  prDictOfReprType,
  prDictOfPReprInstTyCon
) where

import Vectorise.Monad
import Vectorise.Builtins
import Vectorise.Utils.Base

import CoreSyn
import CoreUtils
import FamInstEnv
import Coercion
import Type
import TyCoRep
import TyCon
import CoAxiom
import Var
import Outputable
import DynFlags
import FastString
import Control.Monad


-- |Construct the PA argument type for the tyvar. For the tyvar (v :: *) it's
-- just PA v. For (v :: (* -> *) -> *) it's
--
-- > forall (a :: * -> *). (forall (b :: *). PA b -> PA (a b)) -> PA (v a)
--
paDictArgType :: TyVar -> VM (Maybe Type)
paDictArgType tv = go (mkTyVarTy tv) (tyVarKind tv)
  where
    go ty (FunTy k1 k2)
      = do
          tv   <- if isCoercionType k1
                  then newCoVar (fsLit "c") k1
                  else newTyVar (fsLit "a") k1
          mty1 <- go (mkTyVarTy tv) k1
          case mty1 of
            Just ty1 -> do
                          mty2 <- go (mkAppTy ty (mkTyVarTy tv)) k2
                          return $ fmap (mkInvForAllTy tv . mkFunTy ty1) mty2
            Nothing  -> go ty k2

    go ty k
      | isLiftedTypeKind k
      = do
          pa_cls <- builtin paClass
          return $ Just $ mkClassPred pa_cls [ty]

    go _ _ = return Nothing


-- |Get the PA dictionary for some type
--
paDictOfType :: Type -> VM CoreExpr
paDictOfType ty
  = paDictOfTyApp ty_fn ty_args
  where
    (ty_fn, ty_args) = splitAppTys ty

    paDictOfTyApp :: Type -> [Type] -> VM CoreExpr
    paDictOfTyApp ty_fn ty_args
        | Just ty_fn' <- coreView ty_fn
        = paDictOfTyApp ty_fn' ty_args

    -- for type variables, look up the dfun and apply to the PA dictionaries
    -- of the type arguments
    paDictOfTyApp (TyVarTy tv) ty_args
      = do
        { dfun <- maybeCantVectoriseM "No PA dictionary for type variable"
                                      (ppr tv <+> text "in" <+> ppr ty)
                $ lookupTyVarPA tv
        ; dicts <- mapM paDictOfType ty_args
        ; return $ dfun `mkTyApps` ty_args `mkApps` dicts
        }

    -- for tycons, we also need to apply the dfun to the PR dictionary of
    -- the representation type if the tycon is polymorphic
    paDictOfTyApp (TyConApp tc []) ty_args
      = do
        { dfun <- maybeCantVectoriseM noPADictErr (ppr tc <+> text "in" <+> ppr ty)
                $ lookupTyConPA tc
        ; super <- super_dict tc ty_args
        ; dicts <- mapM paDictOfType ty_args
        ; return $ Var dfun `mkTyApps` ty_args `mkApps` super `mkApps` dicts
        }
      where
        noPADictErr = "No PA dictionary for type constructor (did you import 'Data.Array.Parallel'?)"

        super_dict _     []      = return []
        super_dict tycon ty_args
          = do
            { pr <- prDictOfPReprInst (TyConApp tycon ty_args)
            ; return [pr]
            }

    paDictOfTyApp _ _ = getDynFlags >>= failure

    failure dflags = cantVectorise dflags "Can't construct PA dictionary for type" (ppr ty)

-- |Produce code that refers to a method of the 'PA' class.
--
paMethod :: (Builtins -> Var) -> (TyCon -> Builtins -> Var) -> Type -> VM CoreExpr
paMethod _ query ty
  | Just tycon <- splitPrimTyCon ty             -- Is 'ty' from 'GHC.Prim' (e.g., 'Int#')?
  = liftM Var $ builtin (query tycon)
paMethod method _ ty
  = do
    { fn   <- builtin method
    ; dict <- paDictOfType ty
    ; return $ mkApps (Var fn) [Type ty, dict]
    }

-- |Given a type @ty@, return the PR dictionary for @PRepr ty@.
--
prDictOfPReprInst :: Type -> VM CoreExpr
prDictOfPReprInst ty
  = do
    { (FamInstMatch { fim_instance = prepr_fam, fim_tys = prepr_args })
          <- preprFamInst ty
    ; prDictOfPReprInstTyCon ty (famInstAxiom prepr_fam) prepr_args
    }

-- |Given a type @ty@, its PRepr synonym tycon and its type arguments,
-- return the PR @PRepr ty@. Suppose we have:
--
-- > type instance PRepr (T a1 ... an) = t
--
-- which is internally translated into
--
-- > type :R:PRepr a1 ... an = t
--
-- and the corresponding coercion. Then,
--
-- > prDictOfPReprInstTyCon (T a1 ... an) :R:PRepr u1 ... un = PR (T u1 ... un)
--
-- Note that @ty@ is only used for error messages
--
prDictOfPReprInstTyCon :: Type -> CoAxiom Unbranched -> [Type] -> VM CoreExpr
prDictOfPReprInstTyCon _ty prepr_ax prepr_args
  = do
      let rhs = mkUnbranchedAxInstRHS prepr_ax prepr_args []
      dict <- prDictOfReprType' rhs
      pr_co <- mkBuiltinCo prTyCon
      let co = mkAppCo pr_co
             $ mkSymCo
             $ mkUnbranchedAxInstCo Nominal prepr_ax prepr_args []
      return $ mkCast dict co

-- |Get the PR dictionary for a type. The argument must be a representation
-- type.
--
prDictOfReprType :: Type -> VM CoreExpr
prDictOfReprType ty
  | Just (tycon, tyargs) <- splitTyConApp_maybe ty
    = do
        prepr <- builtin preprTyCon
        if tycon == prepr
          then do
                 let [ty'] = tyargs
                 pa <- paDictOfType ty'
                 sel <- builtin paPRSel
                 return $ Var sel `App` Type ty' `App` pa
          else do
                 -- a representation tycon must have a PR instance
                 dfun <- maybeV (text "look up PR dictionary for" <+> ppr tycon) $
                           lookupTyConPR tycon
                 prDFunApply dfun tyargs

  | otherwise
    = do
        -- it is a tyvar or an application of a tyvar
        -- determine the PR dictionary from its PA dictionary
        --
        -- NOTE: This assumes that PRepr t ~ t is for all representation types
        -- t
        --
        -- FIXME: This doesn't work for kinds other than * at the moment. We'd
        -- have to simply abstract the term over the missing type arguments.
        pa    <- paDictOfType ty
        prsel <- builtin paPRSel
        return $ Var prsel `mkApps` [Type ty, pa]

prDictOfReprType' :: Type -> VM CoreExpr
prDictOfReprType' ty = prDictOfReprType ty `orElseV`
                       do dflags <- getDynFlags
                          cantVectorise dflags "No PR dictionary for representation type"
                                        (ppr ty)

-- | Apply a tycon's PR dfun to dictionary arguments (PR or PA) corresponding
-- to the argument types.
prDFunApply :: Var -> [Type] -> VM CoreExpr
prDFunApply dfun tys
  | Just [] <- ctxs    -- PR (a :-> b) doesn't have a context
  = return $ Var dfun `mkTyApps` tys

  | Just tycons <- ctxs
  , length tycons == length tys
  = do
      pa <- builtin paTyCon
      pr <- builtin prTyCon
      dflags <- getDynFlags
      args <- zipWithM (dictionary dflags pa pr) tys tycons
      return $ Var dfun `mkTyApps` tys `mkApps` args

  | otherwise = do dflags <- getDynFlags
                   invalid dflags
  where
    -- the dfun's contexts - if its type is (PA a, PR b) => PR (C a b) then
    -- ctxs is Just [PA, PR]
    ctxs = fmap (map fst)
         $ sequence
         $ map splitTyConApp_maybe
         $ fst
         $ splitFunTys
         $ snd
         $ splitForAllTys
         $ varType dfun

    dictionary dflags pa pr ty tycon
      | tycon == pa = paDictOfType ty
      | tycon == pr = prDictOfReprType ty
      | otherwise   = invalid dflags

    invalid dflags = cantVectorise dflags "Invalid PR dfun type" (ppr (varType dfun) <+> ppr tys)