diff options
Diffstat (limited to 'compiler/codeGen')
| -rw-r--r-- | compiler/codeGen/StgCmm.hs | 97 |
1 files changed, 45 insertions, 52 deletions
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 305c731ddf..b8ed1aa939 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -6,13 +6,6 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module StgCmm ( codeGen ) where #define FAST_STRING_NOT_NEEDED @@ -56,11 +49,11 @@ import Control.Monad (when,void) import Util codeGen :: DynFlags - -> Module - -> [TyCon] + -> Module + -> [TyCon] -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. - -> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs - -> HpcInfo + -> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs + -> HpcInfo -> Stream IO CmmGroup () -- Output as a stream, so codegen can -- be interleaved with output @@ -108,7 +101,7 @@ codeGen dflags this_mod data_tycons } --------------------------------------------------------------- --- Top-level bindings +-- Top-level bindings --------------------------------------------------------------- {- 'cgTopBinding' is only used for top-level bindings, since they need @@ -123,17 +116,17 @@ variable. -} cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> FCode () cgTopBinding dflags (StgNonRec id rhs, _srts) - = do { id' <- maybeExternaliseId dflags id + = do { id' <- maybeExternaliseId dflags id ; (info, fcode) <- cgTopRhs id' rhs ; fcode ; addBindC (cg_id info) info -- Add the *un-externalised* Id to the envt, - -- so we find it when we look up occurrences + -- so we find it when we look up occurrences } cgTopBinding dflags (StgRec pairs, _srts) - = do { let (bndrs, rhss) = unzip pairs + = do { let (bndrs, rhss) = unzip pairs ; bndrs' <- Prelude.mapM (maybeExternaliseId dflags) bndrs - ; let pairs' = zip bndrs' rhss + ; let pairs' = zip bndrs' rhss ; r <- sequence $ unzipWith cgTopRhs pairs' ; let (infos, fcodes) = unzip r ; addBindsC infos @@ -142,8 +135,8 @@ cgTopBinding dflags (StgRec pairs, _srts) cgTopRhs :: Id -> StgRhs -> FCode (CgIdInfo, FCode ()) - -- The Id is passed along for setting up a binding... - -- It's already been externalised if necessary + -- The Id is passed along for setting up a binding... + -- It's already been externalised if necessary cgTopRhs bndr (StgRhsCon _cc con args) = forkStatics (cgTopRhsCon bndr con args) @@ -155,18 +148,18 @@ cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag _srt args body) --------------------------------------------------------------- --- Module initialisation code +-- Module initialisation code --------------------------------------------------------------- {- The module initialisation code looks like this, roughly: - FN(__stginit_Foo) { - JMP_(__stginit_Foo_1_p) - } + FN(__stginit_Foo) { + JMP_(__stginit_Foo_1_p) + } - FN(__stginit_Foo_1_p) { - ... - } + FN(__stginit_Foo_1_p) { + ... + } We have one version of the init code with a module version and the 'way' attached to it. The version number helps to catch cases @@ -186,16 +179,16 @@ cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag _srt args body) has the version and way info appended to it. We initialise the module tree by keeping a work-stack, - * pointed to by Sp - * that grows downward - * Sp points to the last occupied slot + * pointed to by Sp + * that grows downward + * Sp points to the last occupied slot -} mkModuleInit :: CollectedCCs -- cost centre info - -> Module + -> Module -> HpcInfo - -> FCode () + -> FCode () mkModuleInit cost_centre_info this_mod hpc_info = do { initHpc this_mod hpc_info @@ -207,7 +200,7 @@ mkModuleInit cost_centre_info this_mod hpc_info --------------------------------------------------------------- --- Generating static stuff for algebraic data types +-- Generating static stuff for algebraic data types --------------------------------------------------------------- @@ -223,11 +216,11 @@ 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 + = do { dflags <- getDynFlags ; let (tot_wds, -- #ptr_wds + #nonptr_wds - ptr_wds, -- #ptr_wds - arg_things) = mkVirtConstrOffsets dflags arg_reps + ptr_wds, -- #ptr_wds + arg_things) = mkVirtConstrOffsets dflags arg_reps nonptr_wds = tot_wds - ptr_wds @@ -238,29 +231,29 @@ cgDataCon data_con = emitClosureAndInfoTable info_tbl NativeDirectCall [] $ mk_code ticky_code - mk_code ticky_code - = -- NB: We don't set CC when entering data (WDP 94/06) - do { _ <- ticky_code - ; ldvEnter (CmmReg nodeReg) - ; tickyReturnOldCon (length arg_things) + mk_code ticky_code + = -- NB: We don't set CC when entering data (WDP 94/06) + do { _ <- ticky_code + ; ldvEnter (CmmReg nodeReg) + ; tickyReturnOldCon (length arg_things) ; void $ emitReturn [cmmOffsetB (CmmReg nodeReg) (tagForCon data_con)] } -- The case continuation code expects a tagged pointer - arg_reps :: [(PrimRep, UnaryType)] - arg_reps = [(typePrimRep rep_ty, rep_ty) | ty <- dataConRepArgTys data_con, rep_ty <- flattenRepType (repType ty)] + arg_reps :: [(PrimRep, UnaryType)] + arg_reps = [(typePrimRep rep_ty, rep_ty) | ty <- dataConRepArgTys data_con, rep_ty <- flattenRepType (repType ty)] - -- Dynamic closure code for non-nullary constructors only - ; whenC (not (isNullaryRepDataCon data_con)) + -- Dynamic closure code for non-nullary constructors only + ; whenC (not (isNullaryRepDataCon data_con)) (emit_info dyn_info_tbl tickyEnterDynCon) - -- Dynamic-Closure first, to reduce forward references + -- Dynamic-Closure first, to reduce forward references ; emit_info sta_info_tbl tickyEnterStaticCon } --------------------------------------------------------------- --- Stuff to support splitting +-- Stuff to support splitting --------------------------------------------------------------- -- If we're splitting the object, we need to externalise all the @@ -269,17 +262,17 @@ cgDataCon data_con maybeExternaliseId :: DynFlags -> Id -> FCode Id maybeExternaliseId dflags id - | dopt Opt_SplitObjs dflags, -- Externalise the name for -split-objs + | dopt Opt_SplitObjs dflags, -- Externalise the name for -split-objs isInternalName name = do { mod <- getModuleName - ; returnFC (setIdName id (externalise mod)) } - | otherwise = returnFC id + ; returnFC (setIdName id (externalise mod)) } + | otherwise = returnFC 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 - -- 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. + -- 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. |