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 OrdList
import MkGraph
import qualified Data.ByteString as BS
import Data.IORef
import Control.Monad (when,void)
import Util
codeGen :: DynFlags
-> Module
-> [TyCon]
-> CollectedCCs
-> [StgTopBinding]
-> HpcInfo
-> Stream IO CmmGroup ()
codeGen dflags this_mod data_tycons
cost_centre_info stg_binds hpc_info
= do {
; cgref <- liftIO $ newIORef =<< initC
; let cg :: FCode () -> Stream IO CmmGroup ()
cg fcode = do
cmm <- liftIO $ do
st <- readIORef cgref
let (a,st') = runC dflags this_mod st (getCmm fcode)
writeIORef cgref $! st'{ cgs_tops = nilOL,
cgs_stmts = mkNop }
return a
yield cmm
; cg (mkModuleInit cost_centre_info this_mod hpc_info)
; mapM_ (cg . cgTopBinding dflags) stg_binds
; let do_tycon tycon = do
when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon)
mapM_ (cg . cgDataCon) (tyConDataCons tycon)
; mapM_ do_tycon data_tycons
}
cgTopBinding :: DynFlags -> StgTopBinding -> FCode ()
cgTopBinding dflags (StgTopLifted (StgNonRec id rhs))
= do { id' <- maybeExternaliseId dflags id
; let (info, fcode) = cgTopRhs dflags NonRecursive id' rhs
; fcode
; addBindC info
}
cgTopBinding dflags (StgTopLifted (StgRec pairs))
= do { let (bndrs, rhss) = unzip pairs
; bndrs' <- Prelude.mapM (maybeExternaliseId dflags) bndrs
; let pairs' = zip bndrs' rhss
r = unzipWith (cgTopRhs dflags Recursive) pairs'
(infos, fcodes) = unzip r
; addBindsC infos
; sequence_ fcodes
}
cgTopBinding dflags (StgTopStringLit id str)
= do { id' <- maybeExternaliseId dflags id
; let label = mkBytesLabel (idName id')
; let (lit, decl) = mkByteStringCLit label (BS.unpack str)
; emitDecl decl
; addBindC (litIdInfo dflags id' mkLFStringLit lit)
}
cgTopRhs :: DynFlags -> RecFlag -> Id -> StgRhs -> (CgIdInfo, FCode ())
cgTopRhs dflags _rec bndr (StgRhsCon _cc con args)
= cgTopRhsCon dflags bndr con (assertNonVoidStgArgs args)
cgTopRhs dflags rec bndr (StgRhsClosure cc bi fvs upd_flag args body)
= ASSERT(null fvs)
cgTopRhsClosure dflags rec bndr cc bi upd_flag args body
mkModuleInit
:: CollectedCCs
-> Module
-> HpcInfo
-> FCode ()
mkModuleInit cost_centre_info this_mod hpc_info
= do { initHpc this_mod hpc_info
; initCostCentres cost_centre_info
}
cgEnumerationTyCon :: TyCon -> FCode ()
cgEnumerationTyCon tycon
= do dflags <- getDynFlags
emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)
[ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)
(tagForCon dflags con)
| con <- tyConDataCons tycon]
cgDataCon :: DataCon -> FCode ()
cgDataCon data_con
= do { dflags <- getDynFlags
; let
(tot_wds,
ptr_wds)
= mkVirtConstrSizes dflags arg_reps
nonptr_wds = tot_wds ptr_wds
dyn_info_tbl =
mkDataConInfoTable dflags data_con False ptr_wds nonptr_wds
arg_reps :: [NonVoid PrimRep]
arg_reps = [ NonVoid rep_ty
| ty <- dataConRepArgTys data_con
, rep_ty <- typePrimRep ty
, not (isVoidRep rep_ty) ]
; emitClosureAndInfoTable dyn_info_tbl NativeDirectCall [] $
do { tickyEnterDynCon
; ldvEnter (CmmReg nodeReg)
; tickyReturnOldCon (length arg_reps)
; void $ emitReturn [cmmOffsetB dflags (CmmReg nodeReg) (tagForCon dflags data_con)]
}
}
maybeExternaliseId :: DynFlags -> Id -> FCode Id
maybeExternaliseId dflags id
| gopt Opt_SplitObjs dflags,
isInternalName name = do { mod <- getModuleName
; return (setIdName id (externalise mod)) }
| otherwise = return id
where
externalise mod = mkExternalName uniq mod new_occ loc
name = idName id
uniq = nameUnique name
new_occ = mkLocalOcc uniq (nameOccName name)
loc = nameSrcSpan name