--
-----------------------------------------------------------------------------
-{-# 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
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
}
---------------------------------------------------------------
--- Top-level bindings
+-- Top-level bindings
---------------------------------------------------------------
{- 'cgTopBinding' is only used for top-level bindings, since they need
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
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)
---------------------------------------------------------------
--- 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
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
---------------------------------------------------------------
--- Generating static stuff for algebraic data types
+-- Generating static stuff for algebraic data types
---------------------------------------------------------------
-- 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
= 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
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.