Utils.hs

{-# 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 fs tys = mapM (mkUnarisedId fs) tys

mkUnarisedId :: MonadUnique m => FastString -> NvUnaryType -> m Id
mkUnarisedId s t = mkSysLocalM s ManyTy 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 (GenStgAlt{ alt_con    = DEFAULT
                         , alt_bndrs  = args
                         , alt_rhs    = rhs} : alts) = assert( null args ) (alts, Just rhs)
findDefaultStg alts                                  = (alts, Nothing)

mkStgAltTypeFromStgAlts :: forall p. Id -> [GenStgAlt p] -> AltType
mkStgAltTypeFromStgAlts bndr alts
  | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty
  = MultiValAlt (length prim_reps)  -- always use MultiValAlt for unboxed tuples

  | otherwise
  = case prim_reps of
      [rep] | isGcPtrRep rep ->
        case tyConAppTyCon_maybe (unwrapType bndr_ty) of
          Just tc
            | isAbstractTyCon tc -> look_for_better_tycon
            | isAlgTyCon tc      -> AlgAlt tc
            | otherwise          -> assertPpr ( _is_poly_alt_tycon tc) (ppr tc)
                                    PolyAlt
          Nothing                -> PolyAlt
      [non_gcd] -> PrimAlt non_gcd
      not_unary -> MultiValAlt (length not_unary)
  where
   bndr_ty   = idType bndr
   prim_reps = typePrimRep bndr_ty

   _is_poly_alt_tycon tc
        =  isPrimTyCon tc   -- "Any" is lifted but primitive
        || isFamilyTyCon 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
        | (DataAlt con : _) <- alt_con <$> data_alts =
                AlgAlt (dataConTyCon con)
        | otherwise =
                assert(null data_alts)
                PolyAlt
        where
                (data_alts, _deflt) = findDefaultStg alts

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

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

bindersOfTop :: BinderP a ~ Id => GenStgTopBinding a -> [Id]
bindersOfTop (StgTopLifted bind) = bindersOf bind
bindersOfTop (StgTopStringLit binder _) = [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 binds = foldr ((++) . bindersOfTop) [] binds

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

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

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

-- | Do we allow the given top-level (static) ConApp?
allowTopLevelConApp
  :: Platform
  -> Bool          -- is Opt_ExternalDynamicRefs enabled?
  -> Module
  -> DataCon
  -> [StgArg]
  -> Bool
allowTopLevelConApp platform ext_dyn_refs this_mod con args
  -- we're not using dynamic linking
  | not ext_dyn_refs = 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)
  | platformOS platform == OSMinGW32 = not is_external_con_app
  -- otherwise, allowed
  -- Sylvain: shouldn't this be False when (ext_dyn_refs && is_external_con_app)?
  | otherwise = True
  where
    is_external_con_app = isDynLinkName platform this_mod (dataConName con) || any is_dll_arg 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 (StgVarArg v) =  isAddrRep (typePrimRep1 (idType v))
                             && isDynLinkName platform this_mod (idName v)
    is_dll_arg _             = 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 (NVRep AddrRep)      = True
isAddrRep (NVRep (BoxedRep _)) = True -- FIXME: not true for JavaScript
isAddrRep _                    = False