CodeGen.lhs 7.25 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
%
Simon Marlow's avatar
Simon Marlow committed
5 6

The Code Generator
7 8 9 10 11 12 13

This module says how things get going at the top level.

@codeGen@ is the interface to the outside world.  The \tr{cgTop*}
functions drive the mangling of top-level bindings.

\begin{code}
14
module CodeGen ( codeGen ) where
15

16
#include "HsVersions.h"
17

18 19 20 21
-- Kludge (??) so that CgExpr is reached via at least one non-SOURCE
-- import.  Before, that wasn't the case, and CM therefore didn't 
-- bother to compile it.
import CgExpr           ( {-NOTHING!-} )	-- DO NOT DELETE THIS IMPORT
22 23
import CgProf
import CgMonad
Simon Marlow's avatar
Simon Marlow committed
24 25 26 27
import CgBindery
import CgClosure
import CgCon
import CgUtils
andy@galois.com's avatar
andy@galois.com committed
28
import CgHpc
29

30
import CLabel
31 32
import OldCmm
import OldPprCmm
33

34
import StgSyn
Simon Marlow's avatar
Simon Marlow committed
35 36 37 38 39 40 41 42 43 44 45 46
import PrelNames
import DynFlags
import StaticFlags

import HscTypes
import CostCentre
import Id
import Name
import TyCon
import Module
import ErrUtils
import Panic
47 48 49
\end{code}

\begin{code}
50
codeGen :: DynFlags
51
	-> Module
52
	-> [TyCon]
53
        -> CollectedCCs         -- (Local/global) cost-centres needing declaring/registering.
54
	-> [(StgBinding,[(Id,[Id])])]	-- Bindings to convert, with SRTs
andy@galois.com's avatar
andy@galois.com committed
55
	-> HpcInfo
56
	-> IO [Cmm]		-- Output
57

58 59 60 61
                -- N.B. returning '[Cmm]' and not 'Cmm' here makes it
                -- possible for object splitting to split up the
                -- pieces later.

62
codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info
63
  = do	
64 65 66 67 68
  { showPass dflags "CodeGen"

-- Why?
--   ; mapM_ (\x -> seq x (return ())) data_tycons

Simon Marlow's avatar
Simon Marlow committed
69 70
  ; code_stuff <- initC dflags this_mod $ do 
		{ cmm_binds  <- mapM (getCmm . cgTopBinding dflags) stg_binds
71
		; cmm_tycons <- mapM cgTyCon data_tycons
72
		; cmm_init   <- getCmm (mkModuleInit dflags cost_centre_info 
73 74
                                             this_mod hpc_info)
                ; return (cmm_init : cmm_binds ++ concat cmm_tycons)
75
		}
76 77 78 79 80
		-- 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

81 82 83 84 85 86
                -- 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].

87
  ; dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms code_stuff)
88

89 90
  ; return code_stuff }

91
mkModuleInit
92
        :: DynFlags
sof's avatar
sof committed
93
	-> CollectedCCs         -- cost centre info
94
	-> Module
95
        -> HpcInfo
96
	-> Code
97

98 99
mkModuleInit dflags cost_centre_info this_mod hpc_info
  = do	{ -- Allocate the static boolean that records if this
andy@galois.com's avatar
andy@galois.com committed
100
        ; whenC (opt_Hpc) $
andy@galois.com's avatar
andy@galois.com committed
101 102 103 104 105
              hpcTable this_mod hpc_info

        ; whenC (opt_SccProfilingOn) $ do 
	    initCostCentres cost_centre_info

106 107 108
            -- For backwards compatibility: user code may refer to this
            -- label for calling hs_add_root().
        ; emitSimpleProc (mkPlainModuleInitLabel this_mod) $ return ()
109

110 111 112
        ; whenC (this_mod == mainModIs dflags) $
             emitSimpleProc (mkPlainModuleInitLabel rOOT_MAIN) $ return ()
    }
113 114
\end{code}

115 116


117 118 119 120 121
Cost-centre profiling: Besides the usual stuff, we must produce
declarations for the cost-centres defined in this module;

(The local cost-centres involved in this are passed into the
code-generator.)
122

123
\begin{code}
124 125 126 127 128 129 130
initCostCentres :: CollectedCCs -> Code
-- Emit the declarations, and return code to register them
initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
  | not opt_SccProfilingOn = nopC
  | otherwise
  = do	{ mapM_ emitCostCentreDecl  	 local_CCs
	; mapM_ emitCostCentreStackDecl  singleton_CCSs
131
        }
132 133 134 135 136 137 138 139
\end{code}

%************************************************************************
%*									*
\subsection[codegen-top-bindings]{Converting top-level STG bindings}
%*									*
%************************************************************************

140
@cgTopBinding@ is only used for top-level bindings, since they need
141 142 143 144 145 146 147 148 149 150
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.

\begin{code}
Simon Marlow's avatar
Simon Marlow committed
151 152
cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> Code
cgTopBinding dflags (StgNonRec id rhs, srts)
153
  = do	{ id' <- maybeExternaliseId dflags id
154
	; mapM_ (mkSRT [id']) srts
155 156 157 158
	; (id,info) <- cgTopRhs id' rhs
	; addBindC id info 	-- Add the *un-externalised* Id to the envt,
				-- so we find it when we look up occurrences
	}
159

Simon Marlow's avatar
Simon Marlow committed
160
cgTopBinding dflags (StgRec pairs, srts)
161
  = do	{ let (bndrs, rhss) = unzip pairs
162
	; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs
163
	; let pairs' = zip bndrs' rhss
164
	; mapM_ (mkSRT bndrs')  srts
165
	; _new_binds <- fixC (\ new_binds -> do 
166 167 168
		{ addBindsC new_binds
		; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' })
	; nopC }
169

170
mkSRT :: [Id] -> (Id,[Id]) -> Code
Ian Lynagh's avatar
Ian Lynagh committed
171
mkSRT _ (_,[])  = nopC
172
mkSRT these (id,ids)
173 174
  = do	{ ids <- mapFCs remap ids
	; id  <- remap id
175 176
	; emitRODataLits "CodeGen.mkSRT" (mkSRTLabel (idName id) (idCafInfo id)) 
	       (map (\id -> CmmLabel $ mkClosureLabel (idName id) (idCafInfo id)) ids)
177
	}
178
  where
179 180
	-- Sigh, better map all the ids against the environment in 
	-- case they've been externalised (see maybeExternaliseId below).
181 182
    remap id = case filter (==id) these of
		(id':_) -> returnFC id'
183
		[] -> do { info <- getCgIdInfo id; return (cgIdInfoId info) }
184

185 186 187 188
-- Urgh!  I tried moving the forkStatics call from the rhss of cgTopRhs
-- to enclose the listFCs in cgTopBinding, but that tickled the
-- statics "error" call in initC.  I DON'T UNDERSTAND WHY!

189
cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
190
	-- The Id is passed along for setting up a binding...
191
	-- It's already been externalised if necessary
192

Ian Lynagh's avatar
Ian Lynagh committed
193
cgTopRhs bndr (StgRhsCon _cc con args)
194
  = forkStatics (cgTopRhsCon bndr con args)
195

196
cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag srt args body)
197
  = ASSERT(null fvs)    -- There should be no free variables
198
    setSRTLabel (mkSRTLabel (idName bndr) (idCafInfo bndr)) $
199 200
    setSRT srt $
    forkStatics (cgTopRhsClosure bndr cc bi upd_flag args body)
201
\end{code}
202 203 204 205 206 207 208 209


%************************************************************************
%*									*
\subsection{Stuff to support splitting}
%*									*
%************************************************************************

210 211
If we're splitting the object, we need to externalise all the top-level names
(and then make sure we only use the externalised one in any C label we use
212 213 214
which refers to this name).

\begin{code}
215 216 217
maybeExternaliseId :: DynFlags -> Id -> FCode Id
maybeExternaliseId dflags id
  | dopt Opt_SplitObjs dflags, 	-- Externalise the name for -split-objs
Simon Marlow's avatar
Simon Marlow committed
218
    isInternalName name = do { mod <- getModuleName
219 220
			     ; returnFC (setIdName id (externalise mod)) }
  | otherwise		= returnFC id
221
  where
222
    externalise mod = mkExternalName uniq mod new_occ loc
223 224 225
    name    = idName id
    uniq    = nameUnique name
    new_occ = mkLocalOcc uniq (nameOccName name)
226
    loc     = nameSrcSpan name
227 228 229 230
	-- 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.
sof's avatar
sof committed
231
\end{code}