{-# LANGUAGE CPP, ScopedTypeVariables, TypeFamilies #-}
{-# LANGUAGE DataKinds #-}

module GHC.Stg.Utils
    ( mkStgAltTypeFromStgAlts
    , bindersOf, bindersOfX, bindersOfTop, bindersOfTopBinds

    , stripStgTicksTop, stripStgTicksTopE
    , idArgs

    , mkUnarisedId, mkUnarisedIds

    , allowTopLevelConApp
    ) where

import GHC.Prelude
import GHC.Platform

import GHC.Types.Id
import GHC.Core.Type
import GHC.Core.TyCon
import GHC.Core.DataCon
import GHC.Core ( AltCon(..) )
import GHC.Types.Tickish
import GHC.Types.Unique.Supply

import GHC.Types.RepType
import GHC.Types.Name        ( isDynLinkName )
import GHC.Unit.Module       ( Module )
import GHC.Stg.Syntax

import GHC.Utils.Outputable

import GHC.Utils.Panic

import GHC.Data.FastString

mkUnarisedIds :: MonadUnique m => FastString -> [NvUnaryType] -> m [Id]
mkUnarisedIds :: forall (m :: * -> *).
MonadUnique m =>
FastString -> [NvUnaryType] -> m [Id]
mkUnarisedIds FastString
fs [NvUnaryType]
tys = (NvUnaryType -> m Id) -> [NvUnaryType] -> m [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (FastString -> NvUnaryType -> m Id
forall (m :: * -> *).
MonadUnique m =>
FastString -> NvUnaryType -> m Id
mkUnarisedId FastString
fs) [NvUnaryType]
tys

mkUnarisedId :: MonadUnique m => FastString -> NvUnaryType -> m Id
mkUnarisedId :: forall (m :: * -> *).
MonadUnique m =>
FastString -> NvUnaryType -> m Id
mkUnarisedId FastString
s NvUnaryType
t = FastString -> NvUnaryType -> NvUnaryType -> m Id
forall (m :: * -> *).
MonadUnique m =>
FastString -> NvUnaryType -> NvUnaryType -> m Id
mkSysLocalM FastString
s NvUnaryType
ManyTy NvUnaryType
t

-- Checks if id is a top level error application.
-- isErrorAp_maybe :: Id ->

-- | Extract the default case alternative
-- findDefaultStg :: [Alt b] -> ([Alt b], Maybe (Expr b))
findDefaultStg
  :: [GenStgAlt p]
  -> ([GenStgAlt p], Maybe (GenStgExpr p))
findDefaultStg :: forall (p :: StgPass).
[GenStgAlt p] -> ([GenStgAlt p], Maybe (GenStgExpr p))
findDefaultStg (GenStgAlt{ alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con    = AltCon
DEFAULT
                         , alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs  = [BinderP p]
args
                         , alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs    = GenStgExpr p
rhs} : [GenStgAlt p]
alts) = Bool
-> ([GenStgAlt p], Maybe (GenStgExpr p))
-> ([GenStgAlt p], Maybe (GenStgExpr p))
forall a. HasCallStack => Bool -> a -> a
assert( [BinderP p] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BinderP p]
args ) ([GenStgAlt p]
alts, GenStgExpr p -> Maybe (GenStgExpr p)
forall a. a -> Maybe a
Just GenStgExpr p
rhs)
findDefaultStg [GenStgAlt p]
alts                                  = ([GenStgAlt p]
alts, Maybe (GenStgExpr p)
forall a. Maybe a
Nothing)

mkStgAltTypeFromStgAlts :: forall p. Id -> [GenStgAlt p] -> AltType
mkStgAltTypeFromStgAlts :: forall (p :: StgPass). Id -> [GenStgAlt p] -> AltType
mkStgAltTypeFromStgAlts Id
bndr [GenStgAlt p]
alts
  | NvUnaryType -> Bool
isUnboxedTupleType NvUnaryType
bndr_ty Bool -> Bool -> Bool
|| NvUnaryType -> Bool
isUnboxedSumType NvUnaryType
bndr_ty
  = Int -> AltType
MultiValAlt ([PrimRep] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PrimRep]
prim_reps)  -- always use MultiValAlt for unboxed tuples

  | Bool
otherwise
  = case [PrimRep]
prim_reps of
      [PrimRep
rep] | PrimRep -> Bool
isGcPtrRep PrimRep
rep ->
        case NvUnaryType -> Maybe TyCon
tyConAppTyCon_maybe (NvUnaryType -> NvUnaryType
unwrapType NvUnaryType
bndr_ty) of
          Just TyCon
tc
            | TyCon -> Bool
isAbstractTyCon TyCon
tc -> AltType
look_for_better_tycon
            | TyCon -> Bool
isAlgTyCon TyCon
tc      -> TyCon -> AltType
AlgAlt TyCon
tc
            | Bool
otherwise          -> Bool -> SDoc -> AltType -> AltType
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ( TyCon -> Bool
_is_poly_alt_tycon TyCon
tc) (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
                                    AltType
PolyAlt
          Maybe TyCon
Nothing                -> AltType
PolyAlt
      [PrimRep
non_gcd] -> PrimRep -> AltType
PrimAlt PrimRep
non_gcd
      [PrimRep]
not_unary -> Int -> AltType
MultiValAlt ([PrimRep] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PrimRep]
not_unary)
  where
   bndr_ty :: NvUnaryType
bndr_ty   = Id -> NvUnaryType
idType Id
bndr
   prim_reps :: [PrimRep]
prim_reps = HasDebugCallStack => NvUnaryType -> [PrimRep]
NvUnaryType -> [PrimRep]
typePrimRep NvUnaryType
bndr_ty

   _is_poly_alt_tycon :: TyCon -> Bool
_is_poly_alt_tycon TyCon
tc
        =  TyCon -> Bool
isPrimTyCon TyCon
tc   -- "Any" is lifted but primitive
        Bool -> Bool -> Bool
|| TyCon -> Bool
isFamilyTyCon TyCon
tc -- Type family; e.g. Any, or arising from strict
                            -- function application where argument has a
                            -- type-family type

   -- Sometimes, the TyCon is a AbstractTyCon which may not have any
   -- constructors inside it.  Then we may get a better TyCon by
   -- grabbing the one from a constructor alternative
   -- if one exists.
   look_for_better_tycon :: AltType
look_for_better_tycon
        | (DataAlt DataCon
con : [AltCon]
_) <- GenStgAlt p -> AltCon
forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con (GenStgAlt p -> AltCon) -> [GenStgAlt p] -> [AltCon]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GenStgAlt p]
data_alts =
                TyCon -> AltType
AlgAlt (DataCon -> TyCon
dataConTyCon DataCon
con)
        | Bool
otherwise =
                Bool -> AltType -> AltType
forall a. HasCallStack => Bool -> a -> a
assert([GenStgAlt p] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenStgAlt p]
data_alts)
                AltType
PolyAlt
        where
                ([GenStgAlt p]
data_alts, Maybe (GenStgExpr p)
_deflt) = [GenStgAlt p] -> ([GenStgAlt p], Maybe (GenStgExpr p))
forall (p :: StgPass).
[GenStgAlt p] -> ([GenStgAlt p], Maybe (GenStgExpr p))
findDefaultStg [GenStgAlt p]
alts

bindersOf :: BinderP a ~ Id => GenStgBinding a -> [Id]
bindersOf :: forall (a :: StgPass). (BinderP a ~ Id) => GenStgBinding a -> [Id]
bindersOf (StgNonRec BinderP a
binder GenStgRhs a
_) = [Id
BinderP a
binder]
bindersOf (StgRec [(BinderP a, GenStgRhs a)]
pairs)       = [Id
binder | (Id
binder, GenStgRhs a
_) <- [(Id, GenStgRhs a)]
[(BinderP a, GenStgRhs a)]
pairs]

bindersOfX :: GenStgBinding a -> [BinderP a]
bindersOfX :: forall (a :: StgPass). GenStgBinding a -> [BinderP a]
bindersOfX (StgNonRec BinderP a
binder GenStgRhs a
_) = [BinderP a
binder]
bindersOfX (StgRec [(BinderP a, GenStgRhs a)]
pairs)       = [BinderP a
binder | (BinderP a
binder, GenStgRhs a
_) <- [(BinderP a, GenStgRhs a)]
pairs]

bindersOfTop :: BinderP a ~ Id => GenStgTopBinding a -> [Id]
bindersOfTop :: forall (a :: StgPass).
(BinderP a ~ Id) =>
GenStgTopBinding a -> [Id]
bindersOfTop (StgTopLifted GenStgBinding a
bind) = GenStgBinding a -> [Id]
forall (a :: StgPass). (BinderP a ~ Id) => GenStgBinding a -> [Id]
bindersOf GenStgBinding a
bind
bindersOfTop (StgTopStringLit Id
binder ByteString
_) = [Id
binder]

-- All ids we bind something to on the top level.
bindersOfTopBinds :: BinderP a ~ Id => [GenStgTopBinding a] -> [Id]
-- bindersOfTopBinds binds = mapUnionVarSet (mkVarSet . bindersOfTop) binds
bindersOfTopBinds :: forall (a :: StgPass).
(BinderP a ~ Id) =>
[GenStgTopBinding a] -> [Id]
bindersOfTopBinds [GenStgTopBinding a]
binds = (GenStgTopBinding a -> [Id] -> [Id])
-> [Id] -> [GenStgTopBinding a] -> [Id]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
(++) ([Id] -> [Id] -> [Id])
-> (GenStgTopBinding a -> [Id])
-> GenStgTopBinding a
-> [Id]
-> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenStgTopBinding a -> [Id]
forall (a :: StgPass).
(BinderP a ~ Id) =>
GenStgTopBinding a -> [Id]
bindersOfTop) [] [GenStgTopBinding a]
binds

idArgs :: [StgArg] -> [Id]
idArgs :: [StgArg] -> [Id]
idArgs [StgArg]
args = [Id
v | StgVarArg Id
v <- [StgArg]
args]

-- | Strip ticks of a given type from an STG expression.
stripStgTicksTop :: (StgTickish -> Bool) -> GenStgExpr p -> ([StgTickish], GenStgExpr p)
stripStgTicksTop :: forall (p :: StgPass).
(StgTickish -> Bool)
-> GenStgExpr p -> ([StgTickish], GenStgExpr p)
stripStgTicksTop StgTickish -> Bool
p = [StgTickish] -> GenStgExpr p -> ([StgTickish], GenStgExpr p)
go []
   where go :: [StgTickish] -> GenStgExpr p -> ([StgTickish], GenStgExpr p)
go [StgTickish]
ts (StgTick StgTickish
t GenStgExpr p
e) | StgTickish -> Bool
p StgTickish
t = [StgTickish] -> GenStgExpr p -> ([StgTickish], GenStgExpr p)
go (StgTickish
tStgTickish -> [StgTickish] -> [StgTickish]
forall a. a -> [a] -> [a]
:[StgTickish]
ts) GenStgExpr p
e
         -- This special case avoid building a thunk for "reverse ts" when there are no ticks
         go [] GenStgExpr p
other               = ([], GenStgExpr p
other)
         go [StgTickish]
ts GenStgExpr p
other               = ([StgTickish] -> [StgTickish]
forall a. [a] -> [a]
reverse [StgTickish]
ts, GenStgExpr p
other)

-- | Strip ticks of a given type from an STG expression returning only the expression.
stripStgTicksTopE :: (StgTickish -> Bool) -> GenStgExpr p -> GenStgExpr p
stripStgTicksTopE :: forall (p :: StgPass).
(StgTickish -> Bool) -> GenStgExpr p -> GenStgExpr p
stripStgTicksTopE StgTickish -> Bool
p = GenStgExpr p -> GenStgExpr p
go
   where go :: GenStgExpr p -> GenStgExpr p
go (StgTick StgTickish
t GenStgExpr p
e) | StgTickish -> Bool
p StgTickish
t = GenStgExpr p -> GenStgExpr p
go GenStgExpr p
e
         go GenStgExpr p
other               = GenStgExpr p
other

-- | Do we allow the given top-level (static) ConApp?
allowTopLevelConApp
  :: Platform
  -> Bool          -- is Opt_ExternalDynamicRefs enabled?
  -> Module
  -> DataCon
  -> [StgArg]
  -> Bool
allowTopLevelConApp :: Platform -> Bool -> Module -> DataCon -> [StgArg] -> Bool
allowTopLevelConApp Platform
platform Bool
ext_dyn_refs Module
this_mod DataCon
con [StgArg]
args
  -- we're not using dynamic linking
  | Bool -> Bool
not Bool
ext_dyn_refs = Bool
True
  -- if the target OS is Windows, we only allow top-level ConApps if they don't
  -- reference external names (Windows DLLs have a problem with static cross-DLL
  -- refs)
  | Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32 = Bool -> Bool
not Bool
is_external_con_app
  -- otherwise, allowed
  -- Sylvain: shouldn't this be False when (ext_dyn_refs && is_external_con_app)?
  | Bool
otherwise = Bool
True
  where
    is_external_con_app :: Bool
is_external_con_app = Platform -> Module -> Name -> Bool
isDynLinkName Platform
platform Module
this_mod (DataCon -> Name
dataConName DataCon
con) Bool -> Bool -> Bool
|| (StgArg -> Bool) -> [StgArg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any StgArg -> Bool
is_dll_arg [StgArg]
args

    -- NB: typePrimRep1 is legit because any free variables won't have
    -- unlifted type (there are no unlifted things at top level)
    is_dll_arg :: StgArg -> Bool
    is_dll_arg :: StgArg -> Bool
is_dll_arg (StgVarArg Id
v) =  PrimOrVoidRep -> Bool
isAddrRep (HasDebugCallStack => NvUnaryType -> PrimOrVoidRep
NvUnaryType -> PrimOrVoidRep
typePrimRep1 (Id -> NvUnaryType
idType Id
v))
                             Bool -> Bool -> Bool
&& Platform -> Module -> Name -> Bool
isDynLinkName Platform
platform Module
this_mod (Id -> Name
idName Id
v)
    is_dll_arg StgArg
_             = Bool
False

-- True of machine addresses; these are the things that don't work across DLLs.
-- The key point here is that VoidRep comes out False, so that a top level
-- nullary GADT constructor is True for allowTopLevelConApp
--
--    data T a where
--      T1 :: T Int
--
-- gives
--
--    T1 :: forall a. (a~Int) -> T a
--
-- and hence the top-level binding
--
--    $WT1 :: T Int
--    $WT1 = T1 Int (Coercion (Refl Int))
--
-- The coercion argument here gets VoidRep
isAddrRep :: PrimOrVoidRep -> Bool
isAddrRep :: PrimOrVoidRep -> Bool
isAddrRep (NVRep PrimRep
AddrRep)      = Bool
True
isAddrRep (NVRep (BoxedRep Maybe Levity
_)) = Bool
True -- FIXME: not true for JavaScript
isAddrRep PrimOrVoidRep
_                    = Bool
False