{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}

-----------------------------------------------------------------------------
--
-- Stg to C-- code generation
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------

module StgCmm ( codeGen ) where

#include "HsVersions.h"

import GhcPrelude as Prelude

import StgCmmProf (initCostCentres, ldvEnter)
import StgCmmMonad
import StgCmmEnv
import StgCmmBind
import StgCmmCon
import StgCmmLayout
import StgCmmUtils
import StgCmmClosure
import StgCmmHpc
import StgCmmTicky

import Cmm
import CmmUtils
import CLabel

import StgSyn
import DynFlags

import HscTypes
import CostCentre
import Id
import IdInfo
import RepType
import DataCon
import Name
import TyCon
import Module
import Outputable
import Stream
import BasicTypes
import VarSet ( isEmptyDVarSet )

import OrdList
import MkGraph

import qualified Data.ByteString as BS
import Data.IORef
import Control.Monad (when,void)
import Util

codeGen :: DynFlags
        -> Module
        -> [TyCon]
        -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.
        -> [CgStgTopBinding]           -- Bindings to convert
        -> HpcInfo
        -> Stream IO CmmGroup ()       -- Output as a stream, so codegen can
                                       -- be interleaved with output

codeGen :: DynFlags
-> Module
-> [TyCon]
-> CollectedCCs
-> [CgStgTopBinding]
-> HpcInfo
-> Stream IO CmmGroup ()
codeGen dflags :: DynFlags
dflags this_mod :: Module
this_mod data_tycons :: [TyCon]
data_tycons
        cost_centre_info :: CollectedCCs
cost_centre_info stg_binds :: [CgStgTopBinding]
stg_binds hpc_info :: HpcInfo
hpc_info
  = do  {     -- cg: run the code generator, and yield the resulting CmmGroup
              -- Using an IORef to store the state is a bit crude, but otherwise
              -- we would need to add a state monad layer.
        ; IORef CgState
cgref <- IO (IORef CgState) -> Stream IO CmmGroup (IORef CgState)
forall a b. IO a -> Stream IO b a
liftIO (IO (IORef CgState) -> Stream IO CmmGroup (IORef CgState))
-> IO (IORef CgState) -> Stream IO CmmGroup (IORef CgState)
forall a b. (a -> b) -> a -> b
$ CgState -> IO (IORef CgState)
forall a. a -> IO (IORef a)
newIORef (CgState -> IO (IORef CgState)) -> IO CgState -> IO (IORef CgState)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO CgState
initC
        ; let cg :: FCode () -> Stream IO CmmGroup ()
              cg :: FCode () -> Stream IO CmmGroup ()
cg fcode :: FCode ()
fcode = do
                CmmGroup
cmm <- IO CmmGroup -> Stream IO CmmGroup CmmGroup
forall a b. IO a -> Stream IO b a
liftIO (IO CmmGroup -> Stream IO CmmGroup CmmGroup)
-> IO CmmGroup -> Stream IO CmmGroup CmmGroup
forall a b. (a -> b) -> a -> b
$ do
                         CgState
st <- IORef CgState -> IO CgState
forall a. IORef a -> IO a
readIORef IORef CgState
cgref
                         let (a :: CmmGroup
a,st' :: CgState
st') = DynFlags
-> Module -> CgState -> FCode CmmGroup -> (CmmGroup, CgState)
forall a. DynFlags -> Module -> CgState -> FCode a -> (a, CgState)
runC DynFlags
dflags Module
this_mod CgState
st (FCode () -> FCode CmmGroup
getCmm FCode ()
fcode)

                         -- NB. stub-out cgs_tops and cgs_stmts.  This fixes
                         -- a big space leak.  DO NOT REMOVE!
                         IORef CgState -> CgState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef CgState
cgref (CgState -> IO ()) -> CgState -> IO ()
forall a b. (a -> b) -> a -> b
$! CgState
st'{ cgs_tops :: OrdList CmmDecl
cgs_tops = OrdList CmmDecl
forall a. OrdList a
nilOL,
                                                  cgs_stmts :: CmmAGraph
cgs_stmts = CmmAGraph
mkNop }
                         CmmGroup -> IO CmmGroup
forall (m :: * -> *) a. Monad m => a -> m a
return CmmGroup
a
                CmmGroup -> Stream IO CmmGroup ()
forall (m :: * -> *) a. Monad m => a -> Stream m a ()
yield CmmGroup
cmm

               -- Note [codegen-split-init] the cmm_init block must come
               -- FIRST.  This is because when -split-objs is on we need to
               -- combine this block with its initialisation routines; see
               -- Note [pipeline-split-init].
        ; FCode () -> Stream IO CmmGroup ()
cg (CollectedCCs -> Module -> HpcInfo -> FCode ()
mkModuleInit CollectedCCs
cost_centre_info Module
this_mod HpcInfo
hpc_info)

        ; (CgStgTopBinding -> Stream IO CmmGroup ())
-> [CgStgTopBinding] -> Stream IO CmmGroup ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FCode () -> Stream IO CmmGroup ()
cg (FCode () -> Stream IO CmmGroup ())
-> (CgStgTopBinding -> FCode ())
-> CgStgTopBinding
-> Stream IO CmmGroup ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> CgStgTopBinding -> FCode ()
cgTopBinding DynFlags
dflags) [CgStgTopBinding]
stg_binds

                -- Put datatype_stuff after code_stuff, because the
                -- datatype closure table (for enumeration types) to
                -- (say) PrelBase_True_closure, which is defined in
                -- code_stuff
        ; let do_tycon :: TyCon -> Stream IO CmmGroup ()
do_tycon tycon :: TyCon
tycon = do
                -- Generate a table of static closures for an
                -- enumeration type Note that the closure pointers are
                -- tagged.
                 Bool -> Stream IO CmmGroup () -> Stream IO CmmGroup ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TyCon -> Bool
isEnumerationTyCon TyCon
tycon) (Stream IO CmmGroup () -> Stream IO CmmGroup ())
-> Stream IO CmmGroup () -> Stream IO CmmGroup ()
forall a b. (a -> b) -> a -> b
$ FCode () -> Stream IO CmmGroup ()
cg (TyCon -> FCode ()
cgEnumerationTyCon TyCon
tycon)
                 (DataCon -> Stream IO CmmGroup ())
-> [DataCon] -> Stream IO CmmGroup ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FCode () -> Stream IO CmmGroup ()
cg (FCode () -> Stream IO CmmGroup ())
-> (DataCon -> FCode ()) -> DataCon -> Stream IO CmmGroup ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> FCode ()
cgDataCon) (TyCon -> [DataCon]
tyConDataCons TyCon
tycon)

        ; (TyCon -> Stream IO CmmGroup ())
-> [TyCon] -> Stream IO CmmGroup ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TyCon -> Stream IO CmmGroup ()
do_tycon [TyCon]
data_tycons
        }

---------------------------------------------------------------
--      Top-level bindings
---------------------------------------------------------------

{- 'cgTopBinding' is only used for top-level bindings, since they need
to be allocated statically (not in the heap) and need to be labelled.
No unboxed bindings can happen at top level.

In the code below, the static bindings are accumulated in the
@MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.
This is so that we can write the top level processing in a compositional
style, with the increasing static environment being plumbed as a state
variable. -}

cgTopBinding :: DynFlags -> CgStgTopBinding -> FCode ()
cgTopBinding :: DynFlags -> CgStgTopBinding -> FCode ()
cgTopBinding dflags :: DynFlags
dflags (StgTopLifted (StgNonRec id :: BinderP 'CodeGen
id rhs :: GenStgRhs 'CodeGen
rhs))
  = do  { Id
id' <- DynFlags -> Id -> FCode Id
maybeExternaliseId DynFlags
dflags Id
BinderP 'CodeGen
id
        ; let (info :: CgIdInfo
info, fcode :: FCode ()
fcode) = DynFlags
-> RecFlag -> Id -> GenStgRhs 'CodeGen -> (CgIdInfo, FCode ())
cgTopRhs DynFlags
dflags RecFlag
NonRecursive Id
id' GenStgRhs 'CodeGen
rhs
        ; FCode ()
fcode
        ; CgIdInfo -> FCode ()
addBindC CgIdInfo
info -- Add the *un-externalised* Id to the envt,
                        -- so we find it when we look up occurrences
        }

cgTopBinding dflags :: DynFlags
dflags (StgTopLifted (StgRec pairs :: [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
pairs))
  = do  { let (bndrs :: [Id]
bndrs, rhss :: [GenStgRhs 'CodeGen]
rhss) = [(Id, GenStgRhs 'CodeGen)] -> ([Id], [GenStgRhs 'CodeGen])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
pairs
        ; [Id]
bndrs' <- (Id -> FCode Id) -> [Id] -> FCode [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
Prelude.mapM (DynFlags -> Id -> FCode Id
maybeExternaliseId DynFlags
dflags) [Id]
bndrs
        ; let pairs' :: [(Id, GenStgRhs 'CodeGen)]
pairs' = [Id] -> [GenStgRhs 'CodeGen] -> [(Id, GenStgRhs 'CodeGen)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
bndrs' [GenStgRhs 'CodeGen]
rhss
              r :: [(CgIdInfo, FCode ())]
r = (Id -> GenStgRhs 'CodeGen -> (CgIdInfo, FCode ()))
-> [(Id, GenStgRhs 'CodeGen)] -> [(CgIdInfo, FCode ())]
forall a b c. (a -> b -> c) -> [(a, b)] -> [c]
unzipWith (DynFlags
-> RecFlag -> Id -> GenStgRhs 'CodeGen -> (CgIdInfo, FCode ())
cgTopRhs DynFlags
dflags RecFlag
Recursive) [(Id, GenStgRhs 'CodeGen)]
pairs'
              (infos :: [CgIdInfo]
infos, fcodes :: [FCode ()]
fcodes) = [(CgIdInfo, FCode ())] -> ([CgIdInfo], [FCode ()])
forall a b. [(a, b)] -> ([a], [b])
unzip [(CgIdInfo, FCode ())]
r
        ; [CgIdInfo] -> FCode ()
addBindsC [CgIdInfo]
infos
        ; [FCode ()] -> FCode ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [FCode ()]
fcodes
        }

cgTopBinding dflags :: DynFlags
dflags (StgTopStringLit id :: Id
id str :: ByteString
str)
  = do  { Id
id' <- DynFlags -> Id -> FCode Id
maybeExternaliseId DynFlags
dflags Id
id
        ; let label :: CLabel
label = Name -> CLabel
mkBytesLabel (Id -> Name
idName Id
id')
        ; let (lit :: CmmLit
lit, decl :: GenCmmDecl CmmStatics info stmt
decl) = CLabel -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stmt)
forall info stmt.
CLabel -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stmt)
mkByteStringCLit CLabel
label (ByteString -> [Word8]
BS.unpack ByteString
str)
        ; CmmDecl -> FCode ()
emitDecl CmmDecl
forall info stmt. GenCmmDecl CmmStatics info stmt
decl
        ; CgIdInfo -> FCode ()
addBindC (DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
litIdInfo DynFlags
dflags Id
id' LambdaFormInfo
mkLFStringLit CmmLit
lit)
        }

cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())
        -- The Id is passed along for setting up a binding...
        -- It's already been externalised if necessary

cgTopRhs :: DynFlags
-> RecFlag -> Id -> GenStgRhs 'CodeGen -> (CgIdInfo, FCode ())
cgTopRhs dflags :: DynFlags
dflags _rec :: RecFlag
_rec bndr :: Id
bndr (StgRhsCon _cc :: CostCentreStack
_cc con :: DataCon
con args :: [StgArg]
args)
  = DynFlags
-> Id -> DataCon -> [NonVoid StgArg] -> (CgIdInfo, FCode ())
cgTopRhsCon DynFlags
dflags Id
bndr DataCon
con ([StgArg] -> [NonVoid StgArg]
assertNonVoidStgArgs [StgArg]
args)
      -- con args are always non-void,
      -- see Note [Post-unarisation invariants] in UnariseStg

cgTopRhs dflags :: DynFlags
dflags rec :: RecFlag
rec bndr :: Id
bndr (StgRhsClosure fvs :: XRhsClosure 'CodeGen
fvs cc :: CostCentreStack
cc upd_flag :: UpdateFlag
upd_flag args :: [BinderP 'CodeGen]
args body :: GenStgExpr 'CodeGen
body)
  = ASSERT(isEmptyDVarSet fvs)    -- There should be no free variables
    DynFlags
-> RecFlag
-> Id
-> CostCentreStack
-> UpdateFlag
-> [Id]
-> GenStgExpr 'CodeGen
-> (CgIdInfo, FCode ())
cgTopRhsClosure DynFlags
dflags RecFlag
rec Id
bndr CostCentreStack
cc UpdateFlag
upd_flag [Id]
[BinderP 'CodeGen]
args GenStgExpr 'CodeGen
body


---------------------------------------------------------------
--      Module initialisation code
---------------------------------------------------------------

mkModuleInit
        :: CollectedCCs         -- cost centre info
        -> Module
        -> HpcInfo
        -> FCode ()

mkModuleInit :: CollectedCCs -> Module -> HpcInfo -> FCode ()
mkModuleInit cost_centre_info :: CollectedCCs
cost_centre_info this_mod :: Module
this_mod hpc_info :: HpcInfo
hpc_info
  = do  { Module -> HpcInfo -> FCode ()
initHpc Module
this_mod HpcInfo
hpc_info
        ; CollectedCCs -> FCode ()
initCostCentres CollectedCCs
cost_centre_info
        }


---------------------------------------------------------------
--      Generating static stuff for algebraic data types
---------------------------------------------------------------


cgEnumerationTyCon :: TyCon -> FCode ()
cgEnumerationTyCon :: TyCon -> FCode ()
cgEnumerationTyCon tycon :: TyCon
tycon
  = do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       CLabel -> [CmmLit] -> FCode ()
emitRODataLits (Name -> CafInfo -> CLabel
mkLocalClosureTableLabel (TyCon -> Name
tyConName TyCon
tycon) CafInfo
NoCafRefs)
             [ CLabel -> Int -> CmmLit
CmmLabelOff (Name -> CafInfo -> CLabel
mkLocalClosureLabel (DataCon -> Name
dataConName DataCon
con) CafInfo
NoCafRefs)
                           (DynFlags -> DataCon -> Int
tagForCon DynFlags
dflags DataCon
con)
             | DataCon
con <- TyCon -> [DataCon]
tyConDataCons TyCon
tycon]


cgDataCon :: DataCon -> FCode ()
-- Generate the entry code, info tables, and (for niladic constructor)
-- the static closure, for a constructor.
cgDataCon :: DataCon -> FCode ()
cgDataCon data_con :: DataCon
data_con
  = do  { DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        ; let
            (tot_wds :: Int
tot_wds, --  #ptr_wds + #nonptr_wds
             ptr_wds :: Int
ptr_wds) --  #ptr_wds
              = DynFlags -> [NonVoid PrimRep] -> (Int, Int)
mkVirtConstrSizes DynFlags
dflags [NonVoid PrimRep]
arg_reps

            nonptr_wds :: Int
nonptr_wds   = Int
tot_wds Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ptr_wds

            dyn_info_tbl :: CmmInfoTable
dyn_info_tbl =
              DynFlags -> DataCon -> Bool -> Int -> Int -> CmmInfoTable
mkDataConInfoTable DynFlags
dflags DataCon
data_con Bool
False Int
ptr_wds Int
nonptr_wds

            -- We're generating info tables, so we don't know and care about
            -- what the actual arguments are. Using () here as the place holder.
            arg_reps :: [NonVoid PrimRep]
            arg_reps :: [NonVoid PrimRep]
arg_reps = [ PrimRep -> NonVoid PrimRep
forall a. a -> NonVoid a
NonVoid PrimRep
rep_ty
                       | Type
ty <- DataCon -> [Type]
dataConRepArgTys DataCon
data_con
                       , PrimRep
rep_ty <- HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
ty
                       , Bool -> Bool
not (PrimRep -> Bool
isVoidRep PrimRep
rep_ty) ]

        ; CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()
emitClosureAndInfoTable CmmInfoTable
dyn_info_tbl Convention
NativeDirectCall [] (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$
            -- NB: the closure pointer is assumed *untagged* on
            -- entry to a constructor.  If the pointer is tagged,
            -- then we should not be entering it.  This assumption
            -- is used in ldvEnter and when tagging the pointer to
            -- return it.
            -- NB 2: We don't set CC when entering data (WDP 94/06)
            do { FCode ()
tickyEnterDynCon
               ; CmmExpr -> FCode ()
ldvEnter (CmmReg -> CmmExpr
CmmReg CmmReg
nodeReg)
               ; Int -> FCode ()
tickyReturnOldCon ([NonVoid PrimRep] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [NonVoid PrimRep]
arg_reps)
               ; FCode ReturnKind -> FCode ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (FCode ReturnKind -> FCode ()) -> FCode ReturnKind -> FCode ()
forall a b. (a -> b) -> a -> b
$ [CmmExpr] -> FCode ReturnKind
emitReturn [DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffsetB DynFlags
dflags (CmmReg -> CmmExpr
CmmReg CmmReg
nodeReg) (DynFlags -> DataCon -> Int
tagForCon DynFlags
dflags DataCon
data_con)]
               }
                    -- The case continuation code expects a tagged pointer
        }

---------------------------------------------------------------
--      Stuff to support splitting
---------------------------------------------------------------

maybeExternaliseId :: DynFlags -> Id -> FCode Id
maybeExternaliseId :: DynFlags -> Id -> FCode Id
maybeExternaliseId dflags :: DynFlags
dflags id :: Id
id
  | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SplitObjs DynFlags
dflags,  -- See Note [Externalise when splitting]
                                -- in StgCmmMonad
    Name -> Bool
isInternalName Name
name = do { Module
mod <- FCode Module
getModuleName
                             ; Id -> FCode Id
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Name -> Id
setIdName Id
id (Module -> Name
externalise Module
mod)) }
  | Bool
otherwise           = Id -> FCode Id
forall (m :: * -> *) a. Monad m => a -> m a
return Id
id
  where
    externalise :: Module -> Name
externalise mod :: Module
mod = Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName Unique
uniq Module
mod OccName
new_occ SrcSpan
loc
    name :: Name
name    = Id -> Name
idName Id
id
    uniq :: Unique
uniq    = Name -> Unique
nameUnique Name
name
    new_occ :: OccName
new_occ = Unique -> OccName -> OccName
mkLocalOcc Unique
uniq (Name -> OccName
nameOccName Name
name)
    loc :: SrcSpan
loc     = Name -> SrcSpan
nameSrcSpan Name
name
        -- We want to conjure up a name that can't clash with any
        -- existing name.  So we generate
        --      Mod_$L243foo
        -- where 243 is the unique.