diff options
Diffstat (limited to 'compiler/GHC/StgToCmm.hs')
| -rw-r--r-- | compiler/GHC/StgToCmm.hs | 223 |
1 files changed, 223 insertions, 0 deletions
diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs new file mode 100644 index 0000000000..c7ee604692 --- /dev/null +++ b/compiler/GHC/StgToCmm.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} + +----------------------------------------------------------------------------- +-- +-- Stg to C-- code generation +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module GHC.StgToCmm ( codeGen ) where + +#include "HsVersions.h" + +import GhcPrelude as Prelude + +import GHC.StgToCmm.Prof (initCostCentres, ldvEnter) +import GHC.StgToCmm.Monad +import GHC.StgToCmm.Env +import GHC.StgToCmm.Bind +import GHC.StgToCmm.Con +import GHC.StgToCmm.Layout +import GHC.StgToCmm.Utils +import GHC.StgToCmm.Closure +import GHC.StgToCmm.Hpc +import GHC.StgToCmm.Ticky + +import Cmm +import CmmUtils +import CLabel + +import StgSyn +import DynFlags +import ErrUtils + +import HscTypes +import CostCentre +import Id +import IdInfo +import RepType +import DataCon +import TyCon +import Module +import Outputable +import Stream +import BasicTypes +import VarSet ( isEmptyDVarSet ) + +import OrdList +import MkGraph + +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 dflags this_mod data_tycons + cost_centre_info stg_binds 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. + ; cgref <- liftIO $ newIORef =<< initC + ; let cg :: FCode () -> Stream IO CmmGroup () + cg fcode = do + cmm <- liftIO . withTiming (return dflags) (text "STG -> Cmm") (`seq` ()) $ do + st <- readIORef cgref + let (a,st') = runC dflags this_mod st (getCmm fcode) + + -- NB. stub-out cgs_tops and cgs_stmts. This fixes + -- a big space leak. DO NOT REMOVE! + writeIORef cgref $! st'{ cgs_tops = nilOL, + cgs_stmts = mkNop } + return a + yield 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]. + ; cg (mkModuleInit cost_centre_info this_mod hpc_info) + + ; mapM_ (cg . cgTopBinding dflags) 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 = do + -- Generate a table of static closures for an + -- enumeration type Note that the closure pointers are + -- tagged. + when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon) + mapM_ (cg . cgDataCon) (tyConDataCons tycon) + + ; mapM_ do_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 dflags (StgTopLifted (StgNonRec id rhs)) + = do { let (info, fcode) = cgTopRhs dflags NonRecursive id rhs + ; fcode + ; addBindC info + } + +cgTopBinding dflags (StgTopLifted (StgRec pairs)) + = do { let (bndrs, rhss) = unzip pairs + ; 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 { let label = mkBytesLabel (idName id) + ; let (lit, decl) = mkByteStringCLit label str + ; emitDecl decl + ; addBindC (litIdInfo dflags id mkLFStringLit lit) + } + +cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ()) + -- The Id is passed along for setting up a binding... + +cgTopRhs dflags _rec bndr (StgRhsCon _cc con args) + = cgTopRhsCon dflags bndr con (assertNonVoidStgArgs args) + -- con args are always non-void, + -- see Note [Post-unarisation invariants] in UnariseStg + +cgTopRhs dflags rec bndr (StgRhsClosure fvs cc upd_flag args body) + = ASSERT(isEmptyDVarSet fvs) -- There should be no free variables + cgTopRhsClosure dflags rec bndr cc upd_flag args body + + +--------------------------------------------------------------- +-- Module initialisation code +--------------------------------------------------------------- + +mkModuleInit + :: CollectedCCs -- cost centre info + -> Module + -> HpcInfo + -> FCode () + +mkModuleInit cost_centre_info this_mod hpc_info + = do { initHpc this_mod hpc_info + ; initCostCentres cost_centre_info + } + + +--------------------------------------------------------------- +-- Generating static stuff for algebraic data types +--------------------------------------------------------------- + + +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 () +-- Generate the entry code, info tables, and (for niladic constructor) +-- the static closure, for a constructor. +cgDataCon data_con + = do { dflags <- getDynFlags + ; let + (tot_wds, -- #ptr_wds + #nonptr_wds + ptr_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 + + -- 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 rep_ty + | ty <- dataConRepArgTys data_con + , rep_ty <- typePrimRep ty + , not (isVoidRep rep_ty) ] + + ; emitClosureAndInfoTable dyn_info_tbl NativeDirectCall [] $ + -- 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 { tickyEnterDynCon + ; ldvEnter (CmmReg nodeReg) + ; tickyReturnOldCon (length arg_reps) + ; void $ emitReturn [cmmOffsetB dflags (CmmReg nodeReg) (tagForCon dflags data_con)] + } + -- The case continuation code expects a tagged pointer + } |