-- Set up the data structures provided by 'Vectorise.Builtins'.

module Vectorise.Builtins.Initialise (
  -- * Initialisation
  initBuiltins, initBuiltinVars
) where

import GhcPrelude

import Vectorise.Builtins.Base

import BasicTypes
import TysPrim
import DsMonad
import TysWiredIn
import DataCon
import TyCon
import Class
import CoreSyn
import Type
import NameEnv
import Name
import Id
import FastString
import Outputable

import Control.Monad
import Data.Array


-- |Create the initial map of builtin types and functions.
--
initBuiltins :: DsM Builtins
initBuiltins
 = do {   -- 'PArray: representation type for parallel arrays
      ; parrayTyCon <- externalTyCon (fsLit "PArray")

          -- 'PData': type family mapping array element types to array representation types
          -- Not all backends use `PDatas`.
      ; pdataTyCon  <- externalTyCon (fsLit "PData")
      ; pdatasTyCon <- externalTyCon (fsLit "PDatas")

          -- 'PR': class of basic array operators operating on 'PData' types
      ; prClass     <- externalClass (fsLit "PR")
      ; let prTyCon     = classTyCon prClass

          -- 'PRepr': type family mapping element types to representation types
      ; preprTyCon  <- externalTyCon (fsLit "PRepr")

          -- 'PA': class of basic operations on arrays (parametrised by the element type)
      ; paClass     <- externalClass (fsLit "PA")
      ; let paTyCon     = classTyCon paClass
            [paDataCon] = tyConDataCons paTyCon
            paPRSel     = classSCSelId paClass 0

          -- Functions on array representations
      ; replicatePDVar <- externalVar (fsLit "replicatePD")
      ; replicate_vars <- mapM externalVar (suffixed "replicatePA" aLL_DPH_PRIM_TYCONS)
      ; emptyPDVar     <- externalVar (fsLit "emptyPD")
      ; empty_vars     <- mapM externalVar (suffixed "emptyPA" aLL_DPH_PRIM_TYCONS)
      ; packByTagPDVar <- externalVar (fsLit "packByTagPD")
      ; packByTag_vars <- mapM externalVar (suffixed "packByTagPA" aLL_DPH_PRIM_TYCONS)
      ; let combineNamesD = [("combine" ++ show i ++ "PD") | i <- [2..mAX_DPH_COMBINE]]
      ; let combineNamesA = [("combine" ++ show i ++ "PA") | i <- [2..mAX_DPH_COMBINE]]
      ; combines       <- mapM externalVar (map mkFastString combineNamesD)
      ; combines_vars  <- mapM (mapM externalVar) $
                            map (\name -> suffixed name aLL_DPH_PRIM_TYCONS) combineNamesA
      ; let replicatePD_PrimVars = mkNameEnv (zip aLL_DPH_PRIM_TYCONS replicate_vars)
            emptyPD_PrimVars     = mkNameEnv (zip aLL_DPH_PRIM_TYCONS empty_vars)
            packByTagPD_PrimVars = mkNameEnv (zip aLL_DPH_PRIM_TYCONS packByTag_vars)
            combinePDVars        = listArray (2, mAX_DPH_COMBINE) combines
            combinePD_PrimVarss  = listArray (2, mAX_DPH_COMBINE)
                                     [ mkNameEnv (zip aLL_DPH_PRIM_TYCONS vars)
                                     | vars <- combines_vars]

          -- 'Scalar': class moving between plain unboxed arrays and 'PData' representations
      ; scalarClass <- externalClass (fsLit "Scalar")

          -- N-ary maps ('zipWith' family)
      ; scalar_map       <- externalVar (fsLit "scalar_map")
      ; scalar_zip2      <- externalVar (fsLit "scalar_zipWith")
      ; scalar_zips      <- mapM externalVar (numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS)
      ; let scalarZips   = listArray (1, mAX_DPH_SCALAR_ARGS)
                                     (scalar_map : scalar_zip2 : scalar_zips)

          -- Types and functions for generic type representations
      ; voidTyCon        <- externalTyCon (fsLit "Void")
      ; voidVar          <- externalVar   (fsLit "void")
      ; fromVoidVar      <- externalVar   (fsLit "fromVoid")
      ; sum_tcs          <- mapM externalTyCon (numbered "Sum" 2 mAX_DPH_SUM)
      ; let sumTyCons    = listArray (2, mAX_DPH_SUM) sum_tcs
      ; wrapTyCon        <- externalTyCon (fsLit "Wrap")
      ; pvoidVar         <- externalVar   (fsLit "pvoid")
      ; pvoidsVar        <- externalVar   (fsLit "pvoids#")

          -- Types and functions for closure conversion
      ; closureTyCon     <- externalTyCon (fsLit ":->")
      ; closureVar       <- externalVar   (fsLit "closure")
      ; liftedClosureVar <- externalVar   (fsLit "liftedClosure")
      ; applyVar         <- externalVar   (fsLit "$:")
      ; liftedApplyVar   <- externalVar   (fsLit "liftedApply")
      ; closures         <- mapM externalVar (numbered "closure" 1 mAX_DPH_SCALAR_ARGS)
      ; let closureCtrFuns = listArray (1, mAX_DPH_SCALAR_ARGS) closures

          -- Types and functions for selectors
      ; sel_tys          <- mapM externalType (numbered "Sel"  2 mAX_DPH_SUM)
      ; sels_tys         <- mapM externalType (numbered "Sels" 2 mAX_DPH_SUM)
      ; sels_length      <- mapM externalFun  (numbered_hash "lengthSels"   2 mAX_DPH_SUM)
      ; sel_replicates   <- mapM externalFun  (numbered_hash "replicateSel" 2 mAX_DPH_SUM)
      ; sel_tags         <- mapM externalFun  (numbered "tagsSel" 2 mAX_DPH_SUM)
      ; sel_elements     <- mapM mk_elements [(i,j) | i <- [2..mAX_DPH_SUM], j <- [0..i-1]]
      ; let selTys        = listArray (2, mAX_DPH_SUM) sel_tys
            selsTys       = listArray (2, mAX_DPH_SUM) sels_tys
            selsLengths   = listArray (2, mAX_DPH_SUM) sels_length
            selReplicates = listArray (2, mAX_DPH_SUM) sel_replicates
            selTagss      = listArray (2, mAX_DPH_SUM) sel_tags
            selElementss  = array     ((2, 0), (mAX_DPH_SUM, mAX_DPH_SUM)) sel_elements

          -- Distinct local variable
      ; liftingContext  <- liftM (\u -> mkSysLocalOrCoVar (fsLit "lc") u intPrimTy) newUnique

      ; return $ Builtins
               { parrayTyCon          = parrayTyCon
               , pdataTyCon           = pdataTyCon
               , pdatasTyCon          = pdatasTyCon
               , preprTyCon           = preprTyCon
               , prClass              = prClass
               , prTyCon              = prTyCon
               , paClass              = paClass
               , paTyCon              = paTyCon
               , paDataCon            = paDataCon
               , paPRSel              = paPRSel
               , replicatePDVar       = replicatePDVar
               , replicatePD_PrimVars = replicatePD_PrimVars
               , emptyPDVar           = emptyPDVar
               , emptyPD_PrimVars     = emptyPD_PrimVars
               , packByTagPDVar       = packByTagPDVar
               , packByTagPD_PrimVars = packByTagPD_PrimVars
               , combinePDVars        = combinePDVars
               , combinePD_PrimVarss  = combinePD_PrimVarss
               , scalarClass          = scalarClass
               , scalarZips           = scalarZips
               , voidTyCon            = voidTyCon
               , voidVar              = voidVar
               , fromVoidVar          = fromVoidVar
               , sumTyCons            = sumTyCons
               , wrapTyCon            = wrapTyCon
               , pvoidVar             = pvoidVar
               , pvoidsVar            = pvoidsVar
               , closureTyCon         = closureTyCon
               , closureVar           = closureVar
               , liftedClosureVar     = liftedClosureVar
               , applyVar             = applyVar
               , liftedApplyVar       = liftedApplyVar
               , closureCtrFuns       = closureCtrFuns
               , selTys               = selTys
               , selsTys              = selsTys
               , selsLengths          = selsLengths
               , selReplicates        = selReplicates
               , selTagss             = selTagss
               , selElementss         = selElementss
               , liftingContext       = liftingContext
               }
      }
  where
    suffixed :: String -> [Name] -> [FastString]
    suffixed pfx ns = [mkFastString (pfx ++ "_" ++ (occNameString . nameOccName) n) | n <- ns]

    -- Make a list of numbered strings in some range, eg foo3, foo4, foo5
    numbered :: String -> Int -> Int -> [FastString]
    numbered pfx m n = [mkFastString (pfx ++ show i) | i <- [m..n]]

    numbered_hash :: String -> Int -> Int -> [FastString]
    numbered_hash pfx m n = [mkFastString (pfx ++ show i ++ "#") | i <- [m..n]]

    mk_elements :: (Int, Int) -> DsM ((Int, Int), CoreExpr)
    mk_elements (i,j)
      = do { v <- externalVar $ mkFastString ("elementsSel" ++ show i ++ "_" ++ show j ++ "#")
           ; return ((i, j), Var v)
           }

-- |Get the mapping of names in the Prelude to names in the DPH library.
--
initBuiltinVars :: Builtins -> DsM [(Var, Var)]
-- FIXME: must be replaced by VECTORISE pragmas!!!
initBuiltinVars (Builtins { })
  = do
      cvars <- mapM externalVar cfs
      return $ zip (map dataConWorkId cons) cvars
  where
    (cons, cfs) = unzip preludeDataCons

    preludeDataCons :: [(DataCon, FastString)]
    preludeDataCons
      = [mk_tup n (mkFastString $ "tup" ++ show n) | n <- [2..5]]
      where
        mk_tup n name = (tupleDataCon Boxed n, name)


-- Auxiliary look up functions -----------------------------------------------

-- |Lookup a variable given its name and the module that contains it.
externalVar :: FastString -> DsM Var
externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId


-- |Like `externalVar` but wrap the `Var` in a `CoreExpr`.
externalFun :: FastString -> DsM CoreExpr
externalFun fs = Var <$> externalVar fs


-- |Lookup a 'TyCon' in 'Data.Array.Parallel.Prim', given its name.
--  Panic if there isn't one.
externalTyCon :: FastString -> DsM TyCon
externalTyCon fs = dsLookupDPHRdrEnv (mkTcOccFS fs) >>= dsLookupTyCon


-- |Lookup some `Type` in 'Data.Array.Parallel.Prim', given its name.
externalType :: FastString -> DsM Type
externalType fs
 = do  tycon <- externalTyCon fs
       return $ mkTyConApp tycon []


-- |Lookup a 'Class' in 'Data.Array.Parallel.Prim', given its name.
externalClass :: FastString -> DsM Class
externalClass fs
  = do { tycon <- dsLookupDPHRdrEnv (mkClsOccFS fs) >>= dsLookupTyCon
       ; case tyConClass_maybe tycon of
           Nothing  -> pprPanic "Vectorise.Builtins.Initialise" $
                         text "Data.Array.Parallel.Prim." <>
                         ftext fs <+> text "is not a type class"
           Just cls -> return cls
       }