X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fvectorise%2FVectBuiltIn.hs;h=2f0b0d94a4baeaeecc0e4a97ab12ec4dae84f387;hp=971fa3e8c1441e2d8b2b1a3d0f5bf2d89010afbd;hb=c5dbdf06b92472ef64b66a01f107ba30b65c3708;hpb=fd399de26f49a14431a07ed4a1351f41781b80ec diff --git a/compiler/vectorise/VectBuiltIn.hs b/compiler/vectorise/VectBuiltIn.hs index 971fa3e..2f0b0d9 100644 --- a/compiler/vectorise/VectBuiltIn.hs +++ b/compiler/vectorise/VectBuiltIn.hs @@ -1,25 +1,23 @@ -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module VectBuiltIn ( - Builtins(..), sumTyCon, prodTyCon, - initBuiltins, initBuiltinTyCons, initBuiltinPAs, initBuiltinPRs, + Builtins(..), sumTyCon, prodTyCon, prodDataCon, + selTy, selReplicate, selPick, selElements, + combinePDVar, scalarZip, closureCtrFun, + initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinDataCons, + initBuiltinPAs, initBuiltinPRs, + initBuiltinBoxedTyCons, initBuiltinScalars, primMethod, primPArray ) where -#include "HsVersions.h" - import DsMonad import IfaceEnv ( lookupOrig ) +import InstEnv -import Module ( Module ) -import DataCon ( DataCon ) +import Module +import DataCon ( DataCon, dataConName, dataConWorkId ) import TyCon ( TyCon, tyConName, tyConDataCons ) +import Class ( Class, classTyCon ) +import CoreSyn ( CoreExpr, Expr(..) ) import Var ( Var ) import Id ( mkSysLocal ) import Name ( Name, getOccString ) @@ -27,10 +25,15 @@ import NameEnv import OccName import TypeRep ( funTyCon ) -import Type ( Type ) +import Type ( Type, mkTyConApp ) import TysPrim -import TysWiredIn ( unitTyCon, tupleTyCon, intTyConName ) -import Module +import TysWiredIn ( unitTyCon, unitDataCon, + tupleTyCon, tupleCon, + intTyCon, intTyConName, + doubleTyCon, doubleTyConName, + boolTyCon, boolTyConName, trueDataCon, falseDataCon, + parrTyConName ) +import PrelNames ( word8TyConName, gHC_PARR ) import BasicTypes ( Boxity(..) ) import FastString @@ -38,217 +41,584 @@ import Outputable import Data.Array import Control.Monad ( liftM, zipWithM ) +import Data.List ( unzip4 ) + +mAX_DPH_PROD :: Int +mAX_DPH_PROD = 5 + +mAX_DPH_SUM :: Int +mAX_DPH_SUM = 2 + +mAX_DPH_COMBINE :: Int +mAX_DPH_COMBINE = 2 + +mAX_DPH_SCALAR_ARGS :: Int +mAX_DPH_SCALAR_ARGS = 3 + +data Modules = Modules { + dph_PArray :: Module + , dph_Repr :: Module + , dph_Closure :: Module + , dph_Unboxed :: Module + , dph_Instances :: Module + , dph_Combinators :: Module + , dph_Scalar :: Module + , dph_Selector :: Module + , dph_Prelude_PArr :: Module + , dph_Prelude_Int :: Module + , dph_Prelude_Word8 :: Module + , dph_Prelude_Double :: Module + , dph_Prelude_Bool :: Module + , dph_Prelude_Tuple :: Module + } -mAX_NDP_PROD :: Int -mAX_NDP_PROD = 3 - -mAX_NDP_SUM :: Int -mAX_NDP_SUM = 3 - -mkNDPModule :: FastString -> Module -mkNDPModule m = mkModule ndpPackageId (mkModuleNameFS m) +dph_Modules :: PackageId -> Modules +dph_Modules pkg = Modules { + dph_PArray = mk (fsLit "Data.Array.Parallel.Lifted.PArray") + , dph_Repr = mk (fsLit "Data.Array.Parallel.Lifted.Repr") + , dph_Closure = mk (fsLit "Data.Array.Parallel.Lifted.Closure") + , dph_Unboxed = mk (fsLit "Data.Array.Parallel.Lifted.Unboxed") + , dph_Instances = mk (fsLit "Data.Array.Parallel.Lifted.Instances") + , dph_Combinators = mk (fsLit "Data.Array.Parallel.Lifted.Combinators") + , dph_Scalar = mk (fsLit "Data.Array.Parallel.Lifted.Scalar") + , dph_Selector = mk (fsLit "Data.Array.Parallel.Lifted.Selector") + + , dph_Prelude_PArr = mk (fsLit "Data.Array.Parallel.Prelude.Base.PArr") + , dph_Prelude_Int = mk (fsLit "Data.Array.Parallel.Prelude.Base.Int") + , dph_Prelude_Word8 = mk (fsLit "Data.Array.Parallel.Prelude.Base.Word8") + , dph_Prelude_Double = mk (fsLit "Data.Array.Parallel.Prelude.Base.Double") + , dph_Prelude_Bool = mk (fsLit "Data.Array.Parallel.Prelude.Base.Bool") + , dph_Prelude_Tuple = mk (fsLit "Data.Array.Parallel.Prelude.Base.Tuple") + } + where + mk = mkModule pkg . mkModuleNameFS -nDP_PARRAY = mkNDPModule FSLIT("Data.Array.Parallel.Lifted.PArray") -nDP_REPR = mkNDPModule FSLIT("Data.Array.Parallel.Lifted.Repr") -nDP_CLOSURE = mkNDPModule FSLIT("Data.Array.Parallel.Lifted.Closure") -nDP_PRIM = mkNDPModule FSLIT("Data.Array.Parallel.Lifted.Prim") -nDP_INSTANCES = mkNDPModule FSLIT("Data.Array.Parallel.Lifted.Instances") +dph_Orphans :: [Modules -> Module] +dph_Orphans = [dph_Repr, dph_Instances] data Builtins = Builtins { - parrayTyCon :: TyCon + dphModules :: Modules + , parrayTyCon :: TyCon + , parrayDataCon :: DataCon + , pdataTyCon :: TyCon , paTyCon :: TyCon , paDataCon :: DataCon , preprTyCon :: TyCon , prTyCon :: TyCon , prDataCon :: DataCon - , parrayIntPrimTyCon :: TyCon - , parrayBoolPrimTyCon :: TyCon , voidTyCon :: TyCon , wrapTyCon :: TyCon + , selTys :: Array Int Type + , selReplicates :: Array Int CoreExpr + , selPicks :: Array Int CoreExpr + , selEls :: Array (Int, Int) CoreExpr , sumTyCons :: Array Int TyCon , closureTyCon :: TyCon , voidVar :: Var - , mkPRVar :: Var - , mkClosureVar :: Var - , applyClosureVar :: Var - , mkClosurePVar :: Var - , applyClosurePVar :: Var - , replicatePAIntPrimVar :: Var - , upToPAIntPrimVar :: Var - , selectPAIntPrimVar :: Var - , truesPABoolPrimVar :: Var - , lengthPAVar :: Var - , replicatePAVar :: Var - , emptyPAVar :: Var - , packPAVar :: Var - -- , combinePAVar :: Var + , pvoidVar :: Var + , fromVoidVar :: Var + , punitVar :: Var + , closureVar :: Var + , applyVar :: Var + , liftedClosureVar :: Var + , liftedApplyVar :: Var + , replicatePDVar :: Var + , emptyPDVar :: Var + , packPDVar :: Var + , combinePDVars :: Array Int Var + , scalarClass :: Class + , scalarZips :: Array Int Var + , closureCtrFuns :: Array Int Var , liftingContext :: Var } +indexBuiltin :: (Ix i, Outputable i) => String -> (Builtins -> Array i a) + -> i -> Builtins -> a +indexBuiltin fn f i bi + | inRange (bounds xs) i = xs ! i + | otherwise = pprPanic fn (ppr i) + where + xs = f bi + +selTy :: Int -> Builtins -> Type +selTy = indexBuiltin "selTy" selTys + +selReplicate :: Int -> Builtins -> CoreExpr +selReplicate = indexBuiltin "selReplicate" selReplicates + +selPick :: Int -> Builtins -> CoreExpr +selPick = indexBuiltin "selPick" selPicks + +selElements :: Int -> Int -> Builtins -> CoreExpr +selElements i j = indexBuiltin "selElements" selEls (i,j) + sumTyCon :: Int -> Builtins -> TyCon -sumTyCon n bi - | n >= 2 && n <= mAX_NDP_SUM = sumTyCons bi ! n - | otherwise = pprPanic "sumTyCon" (ppr n) +sumTyCon = indexBuiltin "sumTyCon" sumTyCons prodTyCon :: Int -> Builtins -> TyCon prodTyCon n bi - | n == 1 = wrapTyCon bi - | n >= 0 && n <= mAX_NDP_PROD = tupleTyCon Boxed n + | n >= 2 && n <= mAX_DPH_PROD = tupleTyCon Boxed n | otherwise = pprPanic "prodTyCon" (ppr n) -initBuiltins :: DsM Builtins -initBuiltins +prodDataCon :: Int -> Builtins -> DataCon +prodDataCon n bi = case tyConDataCons (prodTyCon n bi) of + [con] -> con + _ -> pprPanic "prodDataCon" (ppr n) + +combinePDVar :: Int -> Builtins -> Var +combinePDVar = indexBuiltin "combinePDVar" combinePDVars + +scalarZip :: Int -> Builtins -> Var +scalarZip = indexBuiltin "scalarZip" scalarZips + +closureCtrFun :: Int -> Builtins -> Var +closureCtrFun = indexBuiltin "closureCtrFun" closureCtrFuns + +initBuiltins :: PackageId -> DsM Builtins +initBuiltins pkg = do - parrayTyCon <- externalTyCon nDP_PARRAY FSLIT("PArray") - paTyCon <- externalTyCon nDP_PARRAY FSLIT("PA") + mapM_ load dph_Orphans + parrayTyCon <- externalTyCon dph_PArray (fsLit "PArray") + let [parrayDataCon] = tyConDataCons parrayTyCon + pdataTyCon <- externalTyCon dph_PArray (fsLit "PData") + paTyCon <- externalClassTyCon dph_PArray (fsLit "PA") let [paDataCon] = tyConDataCons paTyCon - preprTyCon <- externalTyCon nDP_PARRAY FSLIT("PRepr") - prTyCon <- externalTyCon nDP_PARRAY FSLIT("PR") + preprTyCon <- externalTyCon dph_PArray (fsLit "PRepr") + prTyCon <- externalClassTyCon dph_PArray (fsLit "PR") let [prDataCon] = tyConDataCons prTyCon - parrayIntPrimTyCon <- externalTyCon nDP_PRIM FSLIT("PArray_Int#") - parrayBoolPrimTyCon <- externalTyCon nDP_PRIM FSLIT("PArray_Bool#") - closureTyCon <- externalTyCon nDP_CLOSURE FSLIT(":->") - - voidTyCon <- externalTyCon nDP_REPR FSLIT("Void") - wrapTyCon <- externalTyCon nDP_REPR FSLIT("Wrap") - sum_tcs <- mapM (externalTyCon nDP_REPR) - [mkFastString ("Sum" ++ show i) | i <- [2..mAX_NDP_SUM]] - - let sumTyCons = listArray (2, mAX_NDP_SUM) sum_tcs - - voidVar <- externalVar nDP_REPR FSLIT("void") - mkPRVar <- externalVar nDP_PARRAY FSLIT("mkPR") - mkClosureVar <- externalVar nDP_CLOSURE FSLIT("mkClosure") - applyClosureVar <- externalVar nDP_CLOSURE FSLIT("$:") - mkClosurePVar <- externalVar nDP_CLOSURE FSLIT("mkClosureP") - applyClosurePVar <- externalVar nDP_CLOSURE FSLIT("$:^") - replicatePAIntPrimVar <- externalVar nDP_PRIM FSLIT("replicatePA_Int#") - upToPAIntPrimVar <- externalVar nDP_PRIM FSLIT("upToPA_Int#") - selectPAIntPrimVar <- externalVar nDP_PRIM FSLIT("selectPA_Int#") - truesPABoolPrimVar <- externalVar nDP_PRIM FSLIT("truesPA_Bool#") - lengthPAVar <- externalVar nDP_PARRAY FSLIT("lengthPA") - replicatePAVar <- externalVar nDP_PARRAY FSLIT("replicatePA") - emptyPAVar <- externalVar nDP_PARRAY FSLIT("emptyPA") - packPAVar <- externalVar nDP_PARRAY FSLIT("packPA") - -- combinePAVar <- dsLookupGlobalId combinePAName - - liftingContext <- liftM (\u -> mkSysLocal FSLIT("lc") u intPrimTy) + closureTyCon <- externalTyCon dph_Closure (fsLit ":->") + + voidTyCon <- externalTyCon dph_Repr (fsLit "Void") + wrapTyCon <- externalTyCon dph_Repr (fsLit "Wrap") + sel_tys <- mapM (externalType dph_Selector) + (numbered "Sel" 2 mAX_DPH_SUM) + sel_replicates <- mapM (externalFun dph_Selector) + (numbered "replicate" 2 mAX_DPH_SUM) + sel_picks <- mapM (externalFun dph_Selector) + (numbered "pick" 2 mAX_DPH_SUM) + sel_els <- mapM mk_elements + [(i,j) | i <- [2..mAX_DPH_SUM], j <- [0..i-1]] + sum_tcs <- mapM (externalTyCon dph_Repr) + (numbered "Sum" 2 mAX_DPH_SUM) + + let selTys = listArray (2, mAX_DPH_SUM) sel_tys + selReplicates = listArray (2, mAX_DPH_SUM) sel_replicates + selPicks = listArray (2, mAX_DPH_SUM) sel_picks + selEls = array ((2,0), (mAX_DPH_SUM, mAX_DPH_SUM)) sel_els + sumTyCons = listArray (2, mAX_DPH_SUM) sum_tcs + + voidVar <- externalVar dph_Repr (fsLit "void") + pvoidVar <- externalVar dph_Repr (fsLit "pvoid") + fromVoidVar <- externalVar dph_Repr (fsLit "fromVoid") + punitVar <- externalVar dph_Repr (fsLit "punit") + closureVar <- externalVar dph_Closure (fsLit "closure") + applyVar <- externalVar dph_Closure (fsLit "$:") + liftedClosureVar <- externalVar dph_Closure (fsLit "liftedClosure") + liftedApplyVar <- externalVar dph_Closure (fsLit "liftedApply") + replicatePDVar <- externalVar dph_PArray (fsLit "replicatePD") + emptyPDVar <- externalVar dph_PArray (fsLit "emptyPD") + packPDVar <- externalVar dph_PArray (fsLit "packPD") + + combines <- mapM (externalVar dph_PArray) + [mkFastString ("combine" ++ show i ++ "PD") + | i <- [2..mAX_DPH_COMBINE]] + let combinePDVars = listArray (2, mAX_DPH_COMBINE) combines + + scalarClass <- externalClass dph_Scalar (fsLit "Scalar") + scalar_map <- externalVar dph_Scalar (fsLit "scalar_map") + scalar_zip2 <- externalVar dph_Scalar (fsLit "scalar_zipWith") + scalar_zips <- mapM (externalVar dph_Scalar) + (numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS) + let scalarZips = listArray (1, mAX_DPH_SCALAR_ARGS) + (scalar_map : scalar_zip2 : scalar_zips) + closures <- mapM (externalVar dph_Closure) + (numbered "closure" 1 mAX_DPH_SCALAR_ARGS) + let closureCtrFuns = listArray (1, mAX_DPH_COMBINE) closures + + liftingContext <- liftM (\u -> mkSysLocal (fsLit "lc") u intPrimTy) newUnique return $ Builtins { - parrayTyCon = parrayTyCon + dphModules = modules + , parrayTyCon = parrayTyCon + , parrayDataCon = parrayDataCon + , pdataTyCon = pdataTyCon , paTyCon = paTyCon , paDataCon = paDataCon , preprTyCon = preprTyCon , prTyCon = prTyCon , prDataCon = prDataCon - , parrayIntPrimTyCon = parrayIntPrimTyCon - , parrayBoolPrimTyCon = parrayBoolPrimTyCon , voidTyCon = voidTyCon , wrapTyCon = wrapTyCon + , selTys = selTys + , selReplicates = selReplicates + , selPicks = selPicks + , selEls = selEls , sumTyCons = sumTyCons , closureTyCon = closureTyCon , voidVar = voidVar - , mkPRVar = mkPRVar - , mkClosureVar = mkClosureVar - , applyClosureVar = applyClosureVar - , mkClosurePVar = mkClosurePVar - , applyClosurePVar = applyClosurePVar - , replicatePAIntPrimVar = replicatePAIntPrimVar - , upToPAIntPrimVar = upToPAIntPrimVar - , selectPAIntPrimVar = selectPAIntPrimVar - , truesPABoolPrimVar = truesPABoolPrimVar - , lengthPAVar = lengthPAVar - , replicatePAVar = replicatePAVar - , emptyPAVar = emptyPAVar - , packPAVar = packPAVar - -- , combinePAVar = combinePAVar + , pvoidVar = pvoidVar + , fromVoidVar = fromVoidVar + , punitVar = punitVar + , closureVar = closureVar + , applyVar = applyVar + , liftedClosureVar = liftedClosureVar + , liftedApplyVar = liftedApplyVar + , replicatePDVar = replicatePDVar + , emptyPDVar = emptyPDVar + , packPDVar = packPDVar + , combinePDVars = combinePDVars + , scalarClass = scalarClass + , scalarZips = scalarZips + , closureCtrFuns = closureCtrFuns , liftingContext = liftingContext } - -initBuiltinTyCons :: Builtins -> [(Name, TyCon)] -initBuiltinTyCons bi = [(tyConName funTyCon, closureTyCon bi)] - -initBuiltinDicts :: [(Name, Module, FastString)] -> DsM [(Name, Var)] -initBuiltinDicts ps + where + modules@(Modules { + dph_PArray = dph_PArray + , dph_Repr = dph_Repr + , dph_Closure = dph_Closure + , dph_Selector = dph_Selector + , dph_Scalar = dph_Scalar + }) + = dph_Modules pkg + + load get_mod = dsLoadModule doc mod + where + mod = get_mod modules + doc = ppr mod <+> ptext (sLit "is a DPH module") + + numbered :: String -> Int -> Int -> [FastString] + numbered 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 dph_Selector + $ mkFastString ("elementsSel" ++ show i ++ "_" ++ show j ++ "#") + return ((i,j), Var v) + + +initBuiltinVars :: Builtins -> DsM [(Var, Var)] +initBuiltinVars (Builtins { dphModules = mods }) = do - dicts <- zipWithM externalVar mods fss - return $ zip tcs dicts + uvars <- zipWithM externalVar umods ufs + vvars <- zipWithM externalVar vmods vfs + cvars <- zipWithM externalVar cmods cfs + return $ [(v,v) | v <- map dataConWorkId defaultDataConWorkers] + ++ zip (map dataConWorkId cons) cvars + ++ zip uvars vvars where - (tcs, mods, fss) = unzip3 ps + (umods, ufs, vmods, vfs) = unzip4 (preludeVars mods) -initBuiltinPAs = initBuiltinDicts . builtinPAs + (cons, cmods, cfs) = unzip3 (preludeDataCons mods) -builtinPAs :: Builtins -> [(Name, Module, FastString)] -builtinPAs bi +defaultDataConWorkers :: [DataCon] +defaultDataConWorkers = [trueDataCon, falseDataCon, unitDataCon] + +preludeDataCons :: Modules -> [(DataCon, Module, FastString)] +preludeDataCons (Modules { dph_Prelude_Tuple = dph_Prelude_Tuple }) + = [mk_tup n dph_Prelude_Tuple (mkFastString $ "tup" ++ show n) | n <- [2..3]] + where + mk_tup n mod name = (tupleCon Boxed n, mod, name) + +preludeVars :: Modules -> [(Module, FastString, Module, FastString)] +preludeVars (Modules { dph_Combinators = dph_Combinators + , dph_PArray = dph_PArray + , dph_Prelude_Int = dph_Prelude_Int + , dph_Prelude_Word8 = dph_Prelude_Word8 + , dph_Prelude_Double = dph_Prelude_Double + , dph_Prelude_Bool = dph_Prelude_Bool + , dph_Prelude_PArr = dph_Prelude_PArr + }) = [ - mk (tyConName $ closureTyCon bi) nDP_CLOSURE FSLIT("dPA_Clo") - , mk (tyConName $ voidTyCon bi) nDP_REPR FSLIT("dPA_Void") - , mk unitTyConName nDP_INSTANCES FSLIT("dPA_Unit") + mk gHC_PARR (fsLit "mapP") dph_Combinators (fsLit "mapPA") + , mk gHC_PARR (fsLit "zipWithP") dph_Combinators (fsLit "zipWithPA") + , mk gHC_PARR (fsLit "zipP") dph_Combinators (fsLit "zipPA") + , mk gHC_PARR (fsLit "unzipP") dph_Combinators (fsLit "unzipPA") + , mk gHC_PARR (fsLit "filterP") dph_Combinators (fsLit "filterPA") + , mk gHC_PARR (fsLit "lengthP") dph_Combinators (fsLit "lengthPA") + , mk gHC_PARR (fsLit "replicateP") dph_Combinators (fsLit "replicatePA") + , mk gHC_PARR (fsLit "!:") dph_Combinators (fsLit "indexPA") + , mk gHC_PARR (fsLit "crossMapP") dph_Combinators (fsLit "crossMapPA") + , mk gHC_PARR (fsLit "singletonP") dph_Combinators (fsLit "singletonPA") + , mk gHC_PARR (fsLit "concatP") dph_Combinators (fsLit "concatPA") + , mk gHC_PARR (fsLit "+:+") dph_Combinators (fsLit "appPA") + , mk gHC_PARR (fsLit "emptyP") dph_PArray (fsLit "emptyPA") + + , mk' dph_Prelude_Int "div" "divV" + , mk' dph_Prelude_Int "mod" "modV" + , mk' dph_Prelude_Int "sqrt" "sqrtV" + , mk' dph_Prelude_Int "enumFromToP" "enumFromToPA" + -- , mk' dph_Prelude_Int "upToP" "upToPA" + ] + ++ vars_Ord dph_Prelude_Int + ++ vars_Num dph_Prelude_Int + + ++ vars_Ord dph_Prelude_Word8 + ++ vars_Num dph_Prelude_Word8 + ++ + [ mk' dph_Prelude_Word8 "div" "divV" + , mk' dph_Prelude_Word8 "mod" "modV" + , mk' dph_Prelude_Word8 "fromInt" "fromIntV" + , mk' dph_Prelude_Word8 "toInt" "toIntV" + ] - , mk intTyConName nDP_INSTANCES FSLIT("dPA_Int") + ++ vars_Ord dph_Prelude_Double + ++ vars_Num dph_Prelude_Double + ++ vars_Fractional dph_Prelude_Double + ++ vars_Floating dph_Prelude_Double + ++ vars_RealFrac dph_Prelude_Double + ++ + [ mk dph_Prelude_Bool (fsLit "andP") dph_Prelude_Bool (fsLit "andPA") + , mk dph_Prelude_Bool (fsLit "orP") dph_Prelude_Bool (fsLit "orPA") + + -- FIXME: temporary + , mk dph_Prelude_PArr (fsLit "fromPArrayP") dph_Prelude_PArr (fsLit "fromPArrayPA") + , mk dph_Prelude_PArr (fsLit "toPArrayP") dph_Prelude_PArr (fsLit "toPArrayPA") + , mk dph_Prelude_PArr (fsLit "fromNestedPArrayP") dph_Prelude_PArr (fsLit "fromNestedPArrayPA") + , mk dph_Prelude_PArr (fsLit "combineP") dph_Combinators (fsLit "combine2PA") ] - ++ tups where - mk name mod fs = (name, mod, fs) + mk = (,,,) + mk' mod v v' = mk mod (fsLit v) mod (fsLit v') + + vars_Ord mod = [mk' mod "==" "eqV" + ,mk' mod "/=" "neqV" + ,mk' mod "<=" "leV" + ,mk' mod "<" "ltV" + ,mk' mod ">=" "geV" + ,mk' mod ">" "gtV" + ,mk' mod "min" "minV" + ,mk' mod "max" "maxV" + ,mk' mod "minimumP" "minimumPA" + ,mk' mod "maximumP" "maximumPA" + ,mk' mod "minIndexP" "minIndexPA" + ,mk' mod "maxIndexP" "maxIndexPA" + ] + + vars_Num mod = [mk' mod "+" "plusV" + ,mk' mod "-" "minusV" + ,mk' mod "*" "multV" + ,mk' mod "negate" "negateV" + ,mk' mod "abs" "absV" + ,mk' mod "sumP" "sumPA" + ,mk' mod "productP" "productPA" + ] + + vars_Fractional mod = [mk' mod "/" "divideV" + ,mk' mod "recip" "recipV" + ] + + vars_Floating mod = [mk' mod "pi" "pi" + ,mk' mod "exp" "expV" + ,mk' mod "sqrt" "sqrtV" + ,mk' mod "log" "logV" + ,mk' mod "sin" "sinV" + ,mk' mod "tan" "tanV" + ,mk' mod "cos" "cosV" + ,mk' mod "asin" "asinV" + ,mk' mod "atan" "atanV" + ,mk' mod "acos" "acosV" + ,mk' mod "sinh" "sinhV" + ,mk' mod "tanh" "tanhV" + ,mk' mod "cosh" "coshV" + ,mk' mod "asinh" "asinhV" + ,mk' mod "atanh" "atanhV" + ,mk' mod "acosh" "acoshV" + ,mk' mod "**" "powV" + ,mk' mod "logBase" "logBaseV" + ] + + vars_RealFrac mod = [mk' mod "fromInt" "fromIntV" + ,mk' mod "truncate" "truncateV" + ,mk' mod "round" "roundV" + ,mk' mod "ceiling" "ceilingV" + ,mk' mod "floor" "floorV" + ] + +initBuiltinTyCons :: Builtins -> DsM [(Name, TyCon)] +initBuiltinTyCons bi + = do + -- parr <- externalTyCon dph_Prelude_PArr (fsLit "PArr") + dft_tcs <- defaultTyCons + return $ (tyConName funTyCon, closureTyCon bi) + : (parrTyConName, parrayTyCon bi) + + -- FIXME: temporary + : (tyConName $ parrayTyCon bi, parrayTyCon bi) + + : [(tyConName tc, tc) | tc <- dft_tcs] + +defaultTyCons :: DsM [TyCon] +defaultTyCons + = do + word8 <- dsLookupTyCon word8TyConName + return [intTyCon, boolTyCon, doubleTyCon, word8] - tups = map mk_tup [2..3] - mk_tup n = mk (tyConName $ tupleTyCon Boxed n) - nDP_INSTANCES - (mkFastString $ "dPA_" ++ show n) +initBuiltinDataCons :: Builtins -> [(Name, DataCon)] +initBuiltinDataCons _ = [(dataConName dc, dc)| dc <- defaultDataCons] -initBuiltinPRs = initBuiltinDicts . builtinPRs +defaultDataCons :: [DataCon] +defaultDataCons = [trueDataCon, falseDataCon, unitDataCon] -builtinPRs :: Builtins -> [(Name, Module, FastString)] -builtinPRs bi = - [ - mk (tyConName unitTyCon) nDP_REPR FSLIT("dPR_Unit") - , mk (tyConName $ voidTyCon bi) nDP_REPR FSLIT("dPR_Void") - , mk (tyConName $ wrapTyCon bi) nDP_REPR FSLIT("dPR_Wrap") - , mk (tyConName $ closureTyCon bi) nDP_CLOSURE FSLIT("dPR_Clo") +initBuiltinPAs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)] +initBuiltinPAs (Builtins { dphModules = mods }) insts + = liftM (initBuiltinDicts insts) (externalClass (dph_PArray mods) (fsLit "PA")) - -- temporary - , mk intTyConName nDP_INSTANCES FSLIT("dPR_Int") - ] +initBuiltinPRs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)] +initBuiltinPRs (Builtins { dphModules = mods }) insts + = liftM (initBuiltinDicts insts) (externalClass (dph_PArray mods) (fsLit "PR")) - ++ map mk_sum [2..mAX_NDP_SUM] - ++ map mk_prod [2..mAX_NDP_PROD] +initBuiltinDicts :: (InstEnv, InstEnv) -> Class -> [(Name, Var)] +initBuiltinDicts insts cls = map find $ classInstances insts cls where - mk name mod fs = (name, mod, fs) + find i | [Just tc] <- instanceRoughTcs i = (tc, instanceDFunId i) + | otherwise = pprPanic "Invalid DPH instance" (ppr i) - mk_sum n = (tyConName $ sumTyCon n bi, nDP_REPR, - mkFastString ("dPR_Sum" ++ show n)) +initBuiltinBoxedTyCons :: Builtins -> DsM [(Name, TyCon)] +initBuiltinBoxedTyCons = return . builtinBoxedTyCons + +builtinBoxedTyCons :: Builtins -> [(Name, TyCon)] +builtinBoxedTyCons _ = + [(tyConName intPrimTyCon, intTyCon)] + + +initBuiltinScalars :: Builtins -> DsM [Var] +initBuiltinScalars bi + = mapM (uncurry externalVar) (preludeScalars $ dphModules bi) + + +preludeScalars :: Modules -> [(Module, FastString)] +preludeScalars (Modules { dph_Prelude_Int = dph_Prelude_Int + , dph_Prelude_Word8 = dph_Prelude_Word8 + , dph_Prelude_Double = dph_Prelude_Double + }) + = [ + mk dph_Prelude_Int "div" + , mk dph_Prelude_Int "mod" + , mk dph_Prelude_Int "sqrt" + ] + ++ scalars_Ord dph_Prelude_Int + ++ scalars_Num dph_Prelude_Int + + ++ scalars_Ord dph_Prelude_Word8 + ++ scalars_Num dph_Prelude_Word8 + ++ + [ mk dph_Prelude_Word8 "div" + , mk dph_Prelude_Word8 "mod" + , mk dph_Prelude_Word8 "fromInt" + , mk dph_Prelude_Word8 "toInt" + ] + + ++ scalars_Ord dph_Prelude_Double + ++ scalars_Num dph_Prelude_Double + ++ scalars_Fractional dph_Prelude_Double + ++ scalars_Floating dph_Prelude_Double + ++ scalars_RealFrac dph_Prelude_Double + where + mk mod s = (mod, fsLit s) + + scalars_Ord mod = [mk mod "==" + ,mk mod "/=" + ,mk mod "<=" + ,mk mod "<" + ,mk mod ">=" + ,mk mod ">" + ,mk mod "min" + ,mk mod "max" + ] + + scalars_Num mod = [mk mod "+" + ,mk mod "-" + ,mk mod "*" + ,mk mod "negate" + ,mk mod "abs" + ] + + scalars_Fractional mod = [mk mod "/" + ,mk mod "recip" + ] + + scalars_Floating mod = [mk mod "pi" + ,mk mod "exp" + ,mk mod "sqrt" + ,mk mod "log" + ,mk mod "sin" + ,mk mod "tan" + ,mk mod "cos" + ,mk mod "asin" + ,mk mod "atan" + ,mk mod "acos" + ,mk mod "sinh" + ,mk mod "tanh" + ,mk mod "cosh" + ,mk mod "asinh" + ,mk mod "atanh" + ,mk mod "acosh" + ,mk mod "**" + ,mk mod "logBase" + ] + + scalars_RealFrac mod = [mk mod "fromInt" + ,mk mod "truncate" + ,mk mod "round" + ,mk mod "ceiling" + ,mk mod "floor" + ] - mk_prod n = (tyConName $ prodTyCon n bi, nDP_REPR, - mkFastString ("dPR_" ++ show n)) externalVar :: Module -> FastString -> DsM Var externalVar mod fs = dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs) +externalFun :: Module -> FastString -> DsM CoreExpr +externalFun mod fs + = do + var <- externalVar mod fs + return $ Var var + externalTyCon :: Module -> FastString -> DsM TyCon externalTyCon mod fs - = dsLookupTyCon =<< lookupOrig mod (mkOccNameFS tcName fs) + = dsLookupTyCon =<< lookupOrig mod (mkTcOccFS fs) +externalClassTyCon :: Module -> FastString -> DsM TyCon +externalClassTyCon mod fs = liftM classTyCon (externalClass mod fs) + +externalType :: Module -> FastString -> DsM Type +externalType mod fs + = do + tycon <- externalTyCon mod fs + return $ mkTyConApp tycon [] + +externalClass :: Module -> FastString -> DsM Class +externalClass mod fs + = dsLookupClass =<< lookupOrig mod (mkClsOccFS fs) + +unitTyConName :: Name unitTyConName = tyConName unitTyCon -primMethod :: TyCon -> String -> DsM (Maybe Var) -primMethod tycon method +primMethod :: TyCon -> String -> Builtins -> DsM (Maybe Var) +primMethod tycon method (Builtins { dphModules = mods }) | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon) = liftM Just - $ dsLookupGlobalId =<< lookupOrig nDP_PRIM (mkVarOcc $ method ++ suffix) + $ dsLookupGlobalId =<< lookupOrig (dph_Unboxed mods) + (mkVarOcc $ method ++ suffix) | otherwise = return Nothing -primPArray :: TyCon -> DsM (Maybe TyCon) -primPArray tycon +primPArray :: TyCon -> Builtins -> DsM (Maybe TyCon) +primPArray tycon (Builtins { dphModules = mods }) | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon) = liftM Just - $ dsLookupTyCon =<< lookupOrig nDP_PRIM (mkOccName tcName $ "PArray" ++ suffix) + $ dsLookupTyCon =<< lookupOrig (dph_Unboxed mods) + (mkTcOcc $ "PArray" ++ suffix) | otherwise = return Nothing +prim_ty_cons :: NameEnv String prim_ty_cons = mkNameEnv [mk_prim intPrimTyCon] where mk_prim tycon = (tyConName tycon, '_' : getOccString tycon) +