AsmCodeGen.lhs 36.2 KB
Newer Older
1
2
3
4
5
6
7
-- -----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 1993-2004
-- 
-- This is the top-level module in the native code generator.
--
-- -----------------------------------------------------------------------------
8
9

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
10
11
12
13
14
15
16
{-# 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

17
module AsmCodeGen ( nativeCodeGen ) where
18

19
#include "HsVersions.h"
20
#include "nativeGen/NCG.h"
21

22

23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
import qualified X86.CodeGen
import qualified X86.Regs
import qualified X86.Instr
import qualified X86.Ppr

import qualified SPARC.CodeGen
import qualified SPARC.Regs
import qualified SPARC.Instr
import qualified SPARC.Ppr
import qualified SPARC.ShortcutJump
import qualified SPARC.CodeGen.Expand

import qualified PPC.CodeGen
import qualified PPC.Cond
import qualified PPC.Regs
import qualified PPC.RegInfo
import qualified PPC.Instr
import qualified PPC.Ppr
41
42
43

import RegAlloc.Liveness
import qualified RegAlloc.Linear.Main		as Linear
44

45
46
47
import qualified GraphColor			as Color
import qualified RegAlloc.Graph.Main		as Color
import qualified RegAlloc.Graph.Stats		as Color
48
49
import qualified RegAlloc.Graph.TrivColorable	as Color

50
import TargetReg
51
import Platform
52
import Config
53
54
55
56
import Instruction
import PIC
import Reg
import NCGMonad
57

58
import BlockId
59
import CgUtils		( fixStgRegisters )
60
import OldCmm
61
import CmmOpt		( cmmEliminateDeadBlocks, cmmMiniInline, cmmMachOpFold )
62
import OldPprCmm
63
import CLabel
64

65
import UniqFM
66
67
import Unique		( Unique, getUnique )
import UniqSupply
68
import DynFlags
69
import StaticFlags
70
import Util
71

72
import BasicTypes       ( Alignment )
73
import Digraph
74
import Pretty (Doc)
75
import qualified Pretty
76
import BufWrite
77
import Outputable
78
import FastString
79
import UniqSet
80
import ErrUtils
81
import Module
82

83
84
-- DEBUGGING ONLY
--import OrdList
85

86
import Data.List
87
import Data.Maybe
88
import Control.Monad
89
import System.IO
90

91
92
93
{-
The native-code generator has machine-independent and
machine-dependent modules.
94

95
96
97
98
This module ("AsmCodeGen") is the top-level machine-independent
module.  Before entering machine-dependent land, we do some
machine-independent optimisations (defined below) on the
'CmmStmts's.
99

100
101
102
103
104
105
106
107
108
We convert to the machine-specific 'Instr' datatype with
'cmmCodeGen', assuming an infinite supply of registers.  We then use
a machine-independent register allocator ('regAlloc') to rejoin
reality.  Obviously, 'regAlloc' has machine-specific helper
functions (see about "RegAllocInfo" below).

Finally, we order the basic blocks of the function so as to minimise
the number of jumps between blocks, by utilising fallthrough wherever
possible.
109
110

The machine-dependent bits break down as follows:
111
112

  * ["MachRegs"]  Everything about the target platform's machine
113
114
115
    registers (and immediate operands, and addresses, which tend to
    intermingle/interact with registers).

116
  * ["MachInstrs"]  Includes the 'Instr' datatype (possibly should
117
    have a module of its own), plus a miscellany of other things
118
    (e.g., 'targetDoubleSize', 'smStablePtrTable', ...)
119

120
  * ["MachCodeGen"]  is where 'Cmm' stuff turns into
121
    machine instructions.
122

123
124
  * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really
    a 'Doc').
125

126
127
  * ["RegAllocInfo"] In the register allocator, we manipulate
    'MRegsState's, which are 'BitSet's, one bit per machine register.
128
129
    When we want to say something about a specific machine register
    (e.g., ``it gets clobbered by this instruction''), we set/unset
130
    its bit.  Obviously, we do this 'BitSet' thing for efficiency
131
132
    reasons.

133
    The 'RegAllocInfo' module collects together the machine-specific
134
135
    info needed to do register allocation.

136
137
   * ["RegisterAlloc"] The (machine-independent) register allocator.
-}
138

139
140
-- -----------------------------------------------------------------------------
-- Top-level of the native codegen
141

142
data NcgImpl statics instr jumpDest = NcgImpl {
Simon Peyton Jones's avatar
Simon Peyton Jones committed
143
144
    cmmTopCodeGen             :: RawCmmDecl -> NatM [NatCmmDecl statics instr],
    generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr),
145
146
    getJumpDestBlockId        :: jumpDest -> Maybe BlockId,
    canShortcut               :: instr -> Maybe jumpDest,
147
    shortcutStatics           :: (BlockId -> Maybe jumpDest) -> statics -> statics,
148
    shortcutJump              :: (BlockId -> Maybe jumpDest) -> instr -> instr,
Simon Peyton Jones's avatar
Simon Peyton Jones committed
149
    pprNatCmmDecl              :: Platform -> NatCmmDecl statics instr -> Doc,
150
151
    maxSpillSlots             :: Int,
    allocatableRegs           :: [RealReg],
Simon Peyton Jones's avatar
Simon Peyton Jones committed
152
153
    ncg_x86fp_kludge          :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
    ncgExpandTop              :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
154
155
156
    ncgMakeFarBranches        :: [NatBasicBlock instr] -> [NatBasicBlock instr]
    }

157
--------------------
Simon Peyton Jones's avatar
Simon Peyton Jones committed
158
nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmmGroup] -> IO ()
159
nativeCodeGen dflags h us cmms
160
161
 = let platform = targetPlatform dflags
       nCG' :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO ()
162
       nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms
163
164
165
166
167
       x86NcgImpl = NcgImpl {
                         cmmTopCodeGen             = X86.CodeGen.cmmTopCodeGen
                        ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr
                        ,getJumpDestBlockId        = X86.Instr.getJumpDestBlockId
                        ,canShortcut               = X86.Instr.canShortcut
168
                        ,shortcutStatics           = X86.Instr.shortcutStatics
169
                        ,shortcutJump              = X86.Instr.shortcutJump
Simon Peyton Jones's avatar
Simon Peyton Jones committed
170
                        ,pprNatCmmDecl              = X86.Ppr.pprNatCmmDecl
171
                        ,maxSpillSlots             = X86.Instr.maxSpillSlots (target32Bit platform)
172
173
174
175
176
                        ,allocatableRegs           = X86.Regs.allocatableRegs
                        ,ncg_x86fp_kludge          = id
                        ,ncgExpandTop              = id
                        ,ncgMakeFarBranches        = id
                    }
177
   in case platformArch platform of
178
179
180
181
182
183
184
185
                 ArchX86    -> nCG' (x86NcgImpl { ncg_x86fp_kludge = map x86fp_kludge })
                 ArchX86_64 -> nCG' x86NcgImpl
                 ArchPPC ->
                     nCG' $ NcgImpl {
                          cmmTopCodeGen             = PPC.CodeGen.cmmTopCodeGen
                         ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr
                         ,getJumpDestBlockId        = PPC.RegInfo.getJumpDestBlockId
                         ,canShortcut               = PPC.RegInfo.canShortcut
186
                         ,shortcutStatics           = PPC.RegInfo.shortcutStatics
187
                         ,shortcutJump              = PPC.RegInfo.shortcutJump
Simon Peyton Jones's avatar
Simon Peyton Jones committed
188
                         ,pprNatCmmDecl              = PPC.Ppr.pprNatCmmDecl
189
190
191
192
193
194
195
196
197
198
199
200
                         ,maxSpillSlots             = PPC.Instr.maxSpillSlots
                         ,allocatableRegs           = PPC.Regs.allocatableRegs
                         ,ncg_x86fp_kludge          = id
                         ,ncgExpandTop              = id
                         ,ncgMakeFarBranches        = makeFarBranches
                     }
                 ArchSPARC ->
                     nCG' $ NcgImpl {
                          cmmTopCodeGen             = SPARC.CodeGen.cmmTopCodeGen
                         ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr
                         ,getJumpDestBlockId        = SPARC.ShortcutJump.getJumpDestBlockId
                         ,canShortcut               = SPARC.ShortcutJump.canShortcut
201
                         ,shortcutStatics           = SPARC.ShortcutJump.shortcutStatics
202
                         ,shortcutJump              = SPARC.ShortcutJump.shortcutJump
Simon Peyton Jones's avatar
Simon Peyton Jones committed
203
                         ,pprNatCmmDecl              = SPARC.Ppr.pprNatCmmDecl
204
205
206
207
208
209
                         ,maxSpillSlots             = SPARC.Instr.maxSpillSlots
                         ,allocatableRegs           = SPARC.Regs.allocatableRegs
                         ,ncg_x86fp_kludge          = id
                         ,ncgExpandTop              = map SPARC.CodeGen.Expand.expandTop
                         ,ncgMakeFarBranches        = id
                     }
210
                 ArchARM _ _ ->
Simon Marlow's avatar
Simon Marlow committed
211
                     panic "nativeCodeGen: No NCG for ARM"
212
213
                 ArchPPC_64 ->
                     panic "nativeCodeGen: No NCG for PPC 64"
Ian Lynagh's avatar
Ian Lynagh committed
214
215
                 ArchUnknown ->
                     panic "nativeCodeGen: No NCG for unknown arch"
216

217
nativeCodeGen' :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr)
218
               => DynFlags
219
               -> NcgImpl statics instr jumpDest
Simon Peyton Jones's avatar
Simon Peyton Jones committed
220
               -> Handle -> UniqSupply -> [RawCmmGroup] -> IO ()
221
nativeCodeGen' dflags ncgImpl h us cmms
222
 = do
223
224
	let platform = targetPlatform dflags
	    split_cmms	= concat $ map add_split cmms
225
226
227
228
        -- BufHandle is a performance hack.  We could hide it inside
        -- Pretty if it weren't for the fact that we do lots of little
        -- printDocs here (in order to do codegen in constant space).
        bufh <- newBufHandle h
229
 	(imports, prof) <- cmmNativeGens dflags ncgImpl bufh us split_cmms [] [] 0
230
        bFlush bufh
231

232
233
234
235
236
237
	let (native, colorStats, linearStats)
		= unzip3 prof

	-- dump native code
	dumpIfSet_dyn dflags
		Opt_D_dump_asm "Asm code"
Simon Peyton Jones's avatar
Simon Peyton Jones committed
238
		(vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) $ concat native)
239

240
	-- dump global NCG stats for graph coloring allocator
241
	(case concat $ catMaybes colorStats of
242
243
244
245
246
247
248
249
250
251
	  []	-> return ()
	  stats	-> do	
	   	-- build the global register conflict graph
		let graphGlobal	
			= foldl Color.union Color.initGraph
			$ [ Color.raGraph stat
				| stat@Color.RegAllocStatsStart{} <- stats]
	   
	   	dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
			$ Color.pprStats stats graphGlobal
252

253
254
		dumpIfSet_dyn dflags
			Opt_D_dump_asm_conflicts "Register conflict graph"
255
			$ Color.dotGraph 
256
				(targetRegDotColor platform)
257
258
259
				(Color.trivColorable platform
					(targetVirtualRegSqueeze platform)
					(targetRealRegSqueeze platform))
260
			$ graphGlobal)
261

262

263
	-- dump global NCG stats for linear allocator
264
	(case concat $ catMaybes linearStats of
265
266
		[]	-> return ()
		stats	-> dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
267
268
269
270
				$ Linear.pprStats (concat native) stats)

	-- write out the imports
	Pretty.printDoc Pretty.LeftMode h
271
		$ makeImportsDoc dflags (concat imports)
272

273
	return	()
274

275
 where  add_split tops
276
277
		| dopt Opt_SplitObjs dflags = split_marker : tops
		| otherwise		    = tops
278

279
	split_marker = CmmProc Nothing mkSplitMarkerLabel (ListGraph [])
280
281
282
283


-- | Do native code generation on all these cmms.
--
284
cmmNativeGens :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr)
285
              => DynFlags
286
              -> NcgImpl statics instr jumpDest
dterei's avatar
dterei committed
287
288
              -> BufHandle
              -> UniqSupply
Simon Peyton Jones's avatar
Simon Peyton Jones committed
289
              -> [RawCmmDecl]
dterei's avatar
dterei committed
290
              -> [[CLabel]]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
291
              -> [ ([NatCmmDecl statics instr],
292
                   Maybe [Color.RegAllocStats statics instr],
dterei's avatar
dterei committed
293
294
295
                   Maybe [Linear.RegAllocStats]) ]
              -> Int
              -> IO ( [[CLabel]],
Simon Peyton Jones's avatar
Simon Peyton Jones committed
296
                      [([NatCmmDecl statics instr],
297
                      Maybe [Color.RegAllocStats statics instr],
dterei's avatar
dterei committed
298
299
                      Maybe [Linear.RegAllocStats])] )

300
cmmNativeGens _ _ _ _ [] impAcc profAcc _
301
302
	= return (reverse impAcc, reverse profAcc)

303
cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count
304
 = do
305
306
        let platform = targetPlatform dflags

307
 	(us', native, imports, colorStats, linearStats)
308
		<- cmmNativeGen dflags ncgImpl us cmm count
309

310
	Pretty.bufLeftRender h
311
		$ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map (pprNatCmmDecl ncgImpl platform) native
312

313
314
315
316
           -- carefully evaluate this strictly.  Binding it with 'let'
           -- and then using 'seq' doesn't work, because the let
           -- apparently gets inlined first.
	lsPprNative <- return $!
317
318
319
320
321
		if  dopt Opt_D_dump_asm       dflags
	         || dopt Opt_D_dump_asm_stats dflags
			then native
			else []

322
	count' <- return $! count + 1;
323

324
	-- force evaulation all this stuff to avoid space leaks
325
	seqString (showSDoc $ vcat $ map (pprPlatform platform) imports) `seq` return ()
326

327
328
	cmmNativeGens dflags ncgImpl
            h us' cmms
329
330
			(imports : impAcc)
			((lsPprNative, colorStats, linearStats) : profAcc)
331
			count'
332
333
334

 where	seqString []		= ()
	seqString (x:xs)	= x `seq` seqString xs `seq` ()
335
336


337
338
339
-- | Complete native code generation phase for a single top-level chunk of Cmm.
--	Dumping the output of each stage along the way.
--	Global conflict graph and NGC stats
340
cmmNativeGen
341
	:: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr)
342
    => DynFlags
343
    -> NcgImpl statics instr jumpDest
344
	-> UniqSupply
Simon Peyton Jones's avatar
Simon Peyton Jones committed
345
	-> RawCmmDecl					-- ^ the cmm to generate code for
346
	-> Int						-- ^ sequence number of this top thing
347
	-> IO	( UniqSupply
Simon Peyton Jones's avatar
Simon Peyton Jones committed
348
		, [NatCmmDecl statics instr]	            -- native code
349
350
351
		, [CLabel]			            -- things imported by this cmm
		, Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator
		, Maybe [Linear.RegAllocStats])		    -- stats for the linear register allocators
352

353
cmmNativeGen dflags ncgImpl us cmm count
354
 = do
355
        let platform = targetPlatform dflags
356

357
	-- rewrite assignments to global regs
358
359
360
 	let fixed_cmm =
		{-# SCC "fixStgRegisters" #-}
		fixStgRegisters cmm
361

362
363
	-- cmm to cmm optimisations
	let (opt_cmm, imports) =
364
		{-# SCC "cmmToCmm" #-}
365
		cmmToCmm dflags fixed_cmm
366

367
368
	dumpIfSet_dyn dflags
		Opt_D_dump_opt_cmm "Optimised Cmm"
Simon Peyton Jones's avatar
Simon Peyton Jones committed
369
                (pprCmmGroup platform [opt_cmm])
370

371
372
	-- generate native code from cmm
	let ((native, lastMinuteImports), usGen) =
373
		{-# SCC "genMachCode" #-}
Ian Lynagh's avatar
Ian Lynagh committed
374
		initUs us $ genMachCode dflags (cmmTopCodeGen ncgImpl) opt_cmm
375
376
377

	dumpIfSet_dyn dflags
		Opt_D_dump_asm_native "Native code"
Simon Peyton Jones's avatar
Simon Peyton Jones committed
378
		(vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) native)
379
380
381

	-- tag instructions with register liveness information
	let (withLiveness, usLive) =
382
		{-# SCC "regLiveness" #-}
383
		initUs usGen 
384
			$ mapUs (regLiveness platform)
385
			$ map natCmmTopToLive native
386
387
388

	dumpIfSet_dyn dflags
		Opt_D_dump_asm_liveness "Liveness annotations added"
389
		(vcat $ map (pprPlatform platform) withLiveness)
390
391
392
		
	-- allocate registers
	(alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <-
393
394
	 if ( dopt Opt_RegsGraph dflags
	   || dopt Opt_RegsIterative dflags)
395
396
	  then do
	  	-- the regs usable for allocation
397
		let (alloc_regs :: UniqFM (UniqSet RealReg))
398
			= foldr (\r -> plusUFM_C unionUniqSets
399
					$ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r))
400
				emptyUFM
401
			$ allocatableRegs ncgImpl
402

403
		-- do the graph coloring register allocation
404
		let ((alloced, regAllocStats), usAlloc)
405
			= {-# SCC "RegAlloc" #-}
406
			  initUs usLive
407
			  $ Color.regAlloc
408
				dflags
409
				alloc_regs
410
				(mkUniqSet [0 .. maxSpillSlots ncgImpl])
411
				withLiveness
412

413
		-- dump out what happened during register allocation
414
415
		dumpIfSet_dyn dflags
			Opt_D_dump_asm_regalloc "Registers allocated"
Simon Peyton Jones's avatar
Simon Peyton Jones committed
416
			(vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) alloced)
417
418
419
420

		dumpIfSet_dyn dflags
			Opt_D_dump_asm_regalloc_stages "Build/spill stages"
			(vcat 	$ map (\(stage, stats)
421
422
					-> text "# --------------------------"
					$$ text "#  cmm " <> int count <> text " Stage " <> int stage
423
					$$ pprPlatform platform stats)
424
425
				$ zip [0..] regAllocStats)

426
427
428
429
430
		let mPprStats =
			if dopt Opt_D_dump_asm_stats dflags
			 then Just regAllocStats else Nothing

		-- force evaluation of the Maybe to avoid space leak
431
432
433
434
435
		mPprStats `seq` return ()

		return	( alloced, usAlloc
			, mPprStats
			, Nothing)
436
437
438
439

	  else do
	  	-- do linear register allocation
		let ((alloced, regAllocStats), usAlloc) 
440
			= {-# SCC "RegAlloc" #-}
441
442
  			  initUs usLive
 			  $ liftM unzip
443
			  $ mapUs (Linear.regAlloc dflags) withLiveness
444
445
446

		dumpIfSet_dyn dflags
			Opt_D_dump_asm_regalloc "Registers allocated"
Simon Peyton Jones's avatar
Simon Peyton Jones committed
447
			(vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) alloced)
448

449
450
451
452
453
		let mPprStats =
			if dopt Opt_D_dump_asm_stats dflags
			 then Just (catMaybes regAllocStats) else Nothing

		-- force evaluation of the Maybe to avoid space leak
454
455
456
457
458
		mPprStats `seq` return ()

		return	( alloced, usAlloc
			, Nothing
			, mPprStats)
459

460
461
462
463
464
465
466
        ---- x86fp_kludge.  This pass inserts ffree instructions to clear
        ---- the FPU stack on x86.  The x86 ABI requires that the FPU stack
        ---- is clear, and library functions can return odd results if it
        ---- isn't.
        ----
        ---- NB. must happen before shortcutBranches, because that
        ---- generates JXX_GBLs which we can't fix up in x86fp_kludge.
467
        let kludged = {-# SCC "x86fp_kludge" #-} ncg_x86fp_kludge ncgImpl alloced
468
469

        ---- generate jump tables
470
471
	let tabled	=
		{-# SCC "generateJumpTables" #-}
472
                generateJumpTables ncgImpl kludged
473

474
475
476
	---- shortcut branches
	let shorted	=
	 	{-# SCC "shortcutBranches" #-}
477
	 	shortcutBranches dflags ncgImpl tabled
478
479
480
481

	---- sequence blocks
	let sequenced	=
	 	{-# SCC "sequenceBlocks" #-}
482
	 	map (sequenceTop ncgImpl) shorted
483

484
        ---- expansion of SPARC synthetic instrs
485
486
	let expanded = 
		{-# SCC "sparc_expand" #-}
487
                ncgExpandTop ncgImpl sequenced
488
489
490

	dumpIfSet_dyn dflags
		Opt_D_dump_asm_expanded "Synthetic instructions expanded"
Simon Peyton Jones's avatar
Simon Peyton Jones committed
491
		(vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) expanded)
492

493
	return 	( usAlloc
494
		, expanded
495
496
497
		, lastMinuteImports ++ imports
		, ppr_raStatsColor
		, ppr_raStatsLinear)
498

499

Simon Peyton Jones's avatar
Simon Peyton Jones committed
500
x86fp_kludge :: NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr
501
x86fp_kludge top@(CmmData _ _) = top
502
x86fp_kludge (CmmProc info lbl (ListGraph code)) = 
503
	CmmProc info lbl (ListGraph $ X86.Instr.i386_insert_ffrees code)
504

505

506
-- | Build a doc for all the imports.
507
--
508
509
makeImportsDoc :: DynFlags -> [CLabel] -> Pretty.Doc
makeImportsDoc dflags imports
510
 = dyld_stubs imports
511
512
513
514
515
516
517
            Pretty.$$
            -- On recent versions of Darwin, the linker supports
            -- dead-stripping of code and data on a per-symbol basis.
            -- There's a hack to make this work in PprMach.pprNatCmmDecl.
            (if platformHasSubsectionsViaSymbols (targetPlatform dflags)
             then Pretty.text ".subsections_via_symbols"
             else Pretty.empty)
518
            Pretty.$$ 
519
520
521
522
523
524
                -- On recent GNU ELF systems one can mark an object file
                -- as not requiring an executable stack. If all objects
                -- linked into a program have this note then the program
                -- will not use an executable stack, which is good for
                -- security. GHC generated code does not need an executable
                -- stack so add the note in:
525
526
527
            (if platformHasGnuNonexecStack (targetPlatform dflags)
             then Pretty.text ".section .note.GNU-stack,\"\",@progbits"
             else Pretty.empty)
528
            Pretty.$$
529
                -- And just because every other compiler does, lets stick in
530
                -- an identifier directive: .ident "GHC x.y.z"
531
532
533
534
535
536
            (if platformHasIdentDirective (targetPlatform dflags)
             then let compilerIdent = Pretty.text "GHC" Pretty.<+>
	                              Pretty.text cProjectVersion
                   in Pretty.text ".ident" Pretty.<+>
                      Pretty.doubleQuotes compilerIdent
             else Pretty.empty)
537

538
539
540
541
542
543
 where
	-- Generate "symbol stubs" for all external symbols that might
	-- come from a dynamic library.
	dyld_stubs :: [CLabel] -> Pretty.Doc
{-      dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $
				    map head $ group $ sort imps-}
544

545
546
547
	platform = targetPlatform dflags
	arch = platformArch platform
	os   = platformOS   platform
548
	
549
550
551
	-- (Hack) sometimes two Labels pretty-print the same, but have
	-- different uniques; so we compare their text versions...
	dyld_stubs imps
552
		| needImportedSymbols arch os
553
		= Pretty.vcat $
554
			(pprGotDeclaration arch os :) $
555
			map ( pprImportedSymbol platform . fst . head) $
556
557
558
559
560
561
562
			groupBy (\(_,a) (_,b) -> a == b) $
			sortBy (\(_,a) (_,b) -> compare a b) $
			map doPpr $
			imps
		| otherwise
		= Pretty.empty

563
	doPpr lbl = (lbl, renderWithStyle (pprCLabel platform lbl) astyle)
564
	astyle = mkCodeStyle AsmStyle
565
566


567
568
569
570
571
572
573
574
575
-- -----------------------------------------------------------------------------
-- Sequencing the basic blocks

-- Cmm BasicBlocks are self-contained entities: they always end in a
-- jump, either non-local or to another basic block in the same proc.
-- In this phase, we attempt to place the basic blocks in a sequence
-- such that as many of the local jumps as possible turn into
-- fallthroughs.

576
sequenceTop 
577
	:: Instruction instr
Simon Peyton Jones's avatar
Simon Peyton Jones committed
578
    => NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> NatCmmDecl statics instr
579

580
581
582
sequenceTop _       top@(CmmData _ _) = top
sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) = 
  CmmProc info lbl (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks blocks)
583
584
585
586
587
588
589
590

-- The algorithm is very simple (and stupid): we make a graph out of
-- the blocks where there is an edge from one block to another iff the
-- first block ends by jumping to the second.  Then we topologically
-- sort this graph.  Then traverse the list: for each block, we first
-- output the block, then if it has an out edge, we move the
-- destination of the out edge to the front of the list, and continue.

591
-- FYI, the classic layout for basic blocks uses postorder DFS; this
592
-- algorithm is implemented in Hoopl.
593

594
595
596
597
598
sequenceBlocks 
	:: Instruction instr
	=> [NatBasicBlock instr] 
	-> [NatBasicBlock instr]

599
600
601
602
603
sequenceBlocks [] = []
sequenceBlocks (entry:blocks) = 
  seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
  -- the first block is the entry point ==> it must remain at the start.

604
605
606
607
608
609
610
611

sccBlocks 
	:: Instruction instr
	=> [NatBasicBlock instr] 
	-> [SCC ( NatBasicBlock instr
		, Unique
		, [Unique])]

612
sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks)
613

614
615
616
617
618
619
620
621
622
623
-- we're only interested in the last instruction of
-- the block, and only if it has a single destination.
getOutEdges 
	:: Instruction instr
	=> [instr] -> [Unique]

getOutEdges instrs 
	= case jumpDestsOfInstr (last instrs) of
		[one] -> [getUnique one]
		_many -> []
624

dterei's avatar
dterei committed
625
626
627
mkNode :: (Instruction t)
       => GenBasicBlock t
       -> (GenBasicBlock t, Unique, [Unique])
628
629
mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs)

dterei's avatar
dterei committed
630
seqBlocks :: (Eq t) => [(GenBasicBlock t1, t, [t])] -> [GenBasicBlock t1]
631
632
633
634
635
636
637
638
639
640
641
642
seqBlocks [] = []
seqBlocks ((block,_,[]) : rest)
  = block : seqBlocks rest
seqBlocks ((block@(BasicBlock id instrs),_,[next]) : rest)
  | can_fallthrough = BasicBlock id (init instrs) : seqBlocks rest'
  | otherwise       = block : seqBlocks rest'
  where
	(can_fallthrough, rest') = reorder next [] rest
	  -- TODO: we should do a better job for cycles; try to maximise the
	  -- fallthroughs within a loop.
seqBlocks _ = panic "AsmCodegen:seqBlocks"

dterei's avatar
dterei committed
643
644
reorder :: (Eq a) => a -> [(t, a, t1)] -> [(t, a, t1)] -> (Bool, [(t, a, t1)])
reorder  _ accum [] = (False, reverse accum)
645
646
647
648
reorder id accum (b@(block,id',out) : rest)
  | id == id'  = (True, (block,id,out) : reverse accum ++ rest)
  | otherwise  = reorder id (b:accum) rest

649
650
651
652
653
654
655

-- -----------------------------------------------------------------------------
-- Making far branches

-- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too
-- big, we have to work around this limitation.

656
657
658
makeFarBranches
	:: [NatBasicBlock PPC.Instr.Instr] 
	-> [NatBasicBlock PPC.Instr.Instr]
659
660
661
662
663
664
665
666
667
668
makeFarBranches blocks
    | last blockAddresses < nearLimit = blocks
    | otherwise = zipWith handleBlock blockAddresses blocks
    where
        blockAddresses = scanl (+) 0 $ map blockLen blocks
        blockLen (BasicBlock _ instrs) = length instrs
        
        handleBlock addr (BasicBlock id instrs)
                = BasicBlock id (zipWith makeFar [addr..] instrs)
        
669
670
        makeFar _ (PPC.Instr.BCC PPC.Cond.ALWAYS tgt) = PPC.Instr.BCC PPC.Cond.ALWAYS tgt
        makeFar addr (PPC.Instr.BCC cond tgt)
671
            | abs (addr - targetAddr) >= nearLimit
672
            = PPC.Instr.BCCFAR cond tgt
673
            | otherwise
674
            = PPC.Instr.BCC cond tgt
675
            where Just targetAddr = lookupUFM blockAddressMap tgt
676
        makeFar _ other            = other
677
678
679
680
681
682
683
684
685
        
        nearLimit = 7000 -- 8192 instructions are allowed; let's keep some
                         -- distance, as we have a few pseudo-insns that are
                         -- pretty-printed as multiple instructions,
                         -- and it's just not worth the effort to calculate
                         -- things exactly
        
        blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses

686
687
688
689
690
691
-- -----------------------------------------------------------------------------
-- Generate jump tables

-- Analyzes all native code and generates data sections for all jump
-- table instructions.
generateJumpTables
692
	:: NcgImpl statics instr jumpDest
Simon Peyton Jones's avatar
Simon Peyton Jones committed
693
    -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
694
generateJumpTables ncgImpl xs = concatMap f xs
695
696
    where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs
          f p = [p]
697
          g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs)
698

699
700
701
-- -----------------------------------------------------------------------------
-- Shortcut branches

702
703
shortcutBranches
	:: DynFlags
704
    -> NcgImpl statics instr jumpDest
Simon Peyton Jones's avatar
Simon Peyton Jones committed
705
706
	-> [NatCmmDecl statics instr] 
	-> [NatCmmDecl statics instr]
707

708
shortcutBranches dflags ncgImpl tops
709
  | optLevel dflags < 1 = tops    -- only with -O or higher
710
  | otherwise           = map (apply_mapping ncgImpl mapping) tops'
711
  where
712
    (tops', mappings) = mapAndUnzip (build_mapping ncgImpl) tops
713
714
    mapping = foldr plusUFM emptyUFM mappings

715
build_mapping :: NcgImpl statics instr jumpDest
Simon Peyton Jones's avatar
Simon Peyton Jones committed
716
717
              -> GenCmmDecl d t (ListGraph instr)
              -> (GenCmmDecl d t (ListGraph instr), UniqFM jumpDest)
718
719
build_mapping _ top@(CmmData _ _) = (top, emptyUFM)
build_mapping _ (CmmProc info lbl (ListGraph []))
720
  = (CmmProc info lbl (ListGraph []), emptyUFM)
721
build_mapping ncgImpl (CmmProc info lbl (ListGraph (head:blocks)))
722
  = (CmmProc info lbl (ListGraph (head:others)), mapping)
723
724
725
726
727
        -- drop the shorted blocks, but don't ever drop the first one,
        -- because it is pointed to by a global label.
  where
    -- find all the blocks that just consist of a jump that can be
    -- shorted.
728
729
730
    -- Don't completely eliminate loops here -- that can leave a dangling jump!
    (_, shortcut_blocks, others) = foldl split (emptyBlockSet, [], []) blocks
    split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
731
732
        | Just jd <- canShortcut ncgImpl insn,
          Just dest <- getJumpDestBlockId ncgImpl jd,
733
          (setMember dest s) || dest == id -- loop checks
734
735
        = (s, shortcut_blocks, b : others)
    split (s, shortcut_blocks, others) (BasicBlock id [insn])
736
        | Just dest <- canShortcut ncgImpl insn
737
        = (setInsert id s, (id,dest) : shortcut_blocks, others)
738
739
    split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others)

740
741
742
743
744

    -- build a mapping from BlockId to JumpDest for shorting branches
    mapping = foldl add emptyUFM shortcut_blocks
    add ufm (id,dest) = addToUFM ufm id dest
    
745
apply_mapping :: NcgImpl statics instr jumpDest
746
              -> UniqFM jumpDest
Simon Peyton Jones's avatar
Simon Peyton Jones committed
747
748
              -> GenCmmDecl statics h (ListGraph instr)
              -> GenCmmDecl statics h (ListGraph instr)
749
apply_mapping ncgImpl ufm (CmmData sec statics)
750
  = CmmData sec (shortcutStatics ncgImpl (lookupUFM ufm) statics)
751
apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks))
752
  = CmmProc info lbl (ListGraph $ map short_bb blocks)
753
754
  where
    short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
755
    short_insn i = shortcutJump ncgImpl (lookupUFM ufm) i
756
757
758
                 -- shortcutJump should apply the mapping repeatedly,
                 -- just in case we can short multiple branches.

759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
-- -----------------------------------------------------------------------------
-- Instruction selection

-- Native code instruction selection for a chunk of stix code.  For
-- this part of the computation, we switch from the UniqSM monad to
-- the NatM monad.  The latter carries not only a Unique, but also an
-- Int denoting the current C stack pointer offset in the generated
-- code; this is needed for creating correct spill offsets on
-- architectures which don't offer, or for which it would be
-- prohibitively expensive to employ, a frame pointer register.  Viz,
-- x86.

-- The offset is measured in bytes, and indicates the difference
-- between the current (simulated) C stack-ptr and the value it was at
-- the beginning of the block.  For stacks which grow down, this value
-- should be either zero or negative.

-- Switching between the two monads whilst carrying along the same
-- Unique supply breaks abstraction.  Is that bad?

779
780
genMachCode 
	:: DynFlags 
Simon Peyton Jones's avatar
Simon Peyton Jones committed
781
782
        -> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
	-> RawCmmDecl 
783
	-> UniqSM 
Simon Peyton Jones's avatar
Simon Peyton Jones committed
784
		( [NatCmmDecl statics instr]
785
		, [CLabel])
786

787
genMachCode dflags cmmTopCodeGen cmm_top
788
  = do	{ initial_us <- getUs
789
	; let initial_st           = mkNatM_State initial_us 0 dflags
790
	      (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
791
792
793
794
795
796
	      final_delta          = natm_delta final_st
	      final_imports        = natm_imports final_st
	; if   final_delta == 0
          then return (new_tops, final_imports)
          else pprPanic "genMachCode: nonzero final delta" (int final_delta)
    }
797

798
799
800
801
802
803
804
805
806
-- -----------------------------------------------------------------------------
-- Generic Cmm optimiser

{-
Here we do:

  (a) Constant folding
  (b) Simple inlining: a temporary which is assigned to and then
      used, once, can be shorted.
807
  (c) Position independent code and dynamic linking
808
809
810
        (i)  introduce the appropriate indirections
             and position independent refs
        (ii) compile a list of imported symbols
811
  (d) Some arch-specific optimizations
812

813
814
815
816
817
(a) and (b) will be moving to the new Hoopl pipeline, however, (c) and
(d) are only needed by the native backend and will continue to live
here.

Ideas for other things we could do (put these in Hoopl please!):
818
819

  - shortcut jumps-to-jumps
820
821
822
  - simple CSE: if an expr is assigned to a temp, then replace later occs of
    that expr with the temp, until the expr is no longer valid (can push through
    temp assignments, and certain assigns to mem...)
823
824
-}

Simon Peyton Jones's avatar
Simon Peyton Jones committed
825
cmmToCmm :: DynFlags -> RawCmmDecl -> (RawCmmDecl, [CLabel])
826
cmmToCmm _ top@(CmmData _ _) = (top, [])
827
cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do
828
829
  let platform = targetPlatform dflags
  blocks' <- mapM cmmBlockConFold (cmmMiniInline platform (cmmEliminateDeadBlocks blocks))
830
  return $ CmmProc info lbl (ListGraph blocks')
831

832
newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
833
834

instance Monad CmmOptM where
835
  return x = CmmOptM $ \(imports, _) -> (# x,imports #)
836
  (CmmOptM f) >>= g =
837
838
    CmmOptM $ \(imports, dflags) ->
                case f (imports, dflags) of
839
840
                  (# x, imports' #) ->
                    case g x of
841
                      CmmOptM g' -> g' (imports', dflags)
842
843

addImportCmmOpt :: CLabel -> CmmOptM ()
dterei's avatar
dterei committed
844
addImportCmmOpt lbl = CmmOptM $ \(imports, _dflags) -> (# (), lbl:imports #)
845

846
847
848
849
850
getDynFlagsCmmOpt :: CmmOptM DynFlags
getDynFlagsCmmOpt = CmmOptM $ \(imports, dflags) -> (# dflags, imports #)

runCmmOpt :: DynFlags -> CmmOptM a -> (a, [CLabel])
runCmmOpt dflags (CmmOptM f) = case f ([], dflags) of
851
852
853
854
855
856
                        (# result, imports #) -> (result, imports)

cmmBlockConFold :: CmmBasicBlock -> CmmOptM CmmBasicBlock
cmmBlockConFold (BasicBlock id stmts) = do
  stmts' <- mapM cmmStmtConFold stmts
  return $ BasicBlock id stmts'
857

858
859
860
861
862
863
864
865
866
-- This does three optimizations, but they're very quick to check, so we don't
-- bother turning them off even when the Hoopl code is active.  Since
-- this is on the old Cmm representation, we can't reuse the code either:
--  * reg = reg      --> nop
--  * if 0 then jump --> nop
--  * if 1 then jump --> jump
-- We might be tempted to skip this step entirely of not opt_PIC, but
-- there is some PowerPC code for the non-PIC case, which would also
-- have to be separated.
dterei's avatar
dterei committed
867
cmmStmtConFold :: CmmStmt -> CmmOptM CmmStmt
868
869
870
cmmStmtConFold stmt
   = case stmt of
        CmmAssign reg src
871
           -> do src' <- cmmExprConFold DataReference src
872
873
874
                 return $ case src' of
		   CmmReg reg' | reg == reg' -> CmmNop
		   new_src -> CmmAssign reg new_src
875
876

        CmmStore addr src
877
878
           -> do addr' <- cmmExprConFold DataReference addr
                 src'  <- cmmExprConFold DataReference src
879
                 return $ CmmStore addr' src'
880
881

        CmmJump addr regs
882
           -> do addr' <- cmmExprConFold JumpReference addr
883
                 return $ CmmJump addr' regs
884

885
        CmmCall target regs args returns
886
	   -> do target' <- case target of
887
			      CmmCallee e conv -> do
888
			        e' <- cmmExprConFold CallReference e
889
			        return $ CmmCallee e' conv
890
			      other -> return other
891
                 args' <- mapM (\(CmmHinted arg hint) -> do
892
                                  arg' <- cmmExprConFold DataReference arg
893
                                  return (CmmHinted arg' hint)) args
894
                 return $ CmmCall target' regs args' returns
895
896

        CmmCondBranch test dest
897
           -> do test' <- cmmExprConFold DataReference test
898
899
                 dflags <- getDynFlagsCmmOpt
                 let platform = targetPlatform dflags
900
901
902
	         return $ case test' of
		   CmmLit (CmmInt 0 _) -> 
		     CmmComment (mkFastString ("deleted: " ++ 
903
					showSDoc (pprStmt platform stmt)))
904

dterei's avatar
dterei committed
905
906
		   CmmLit (CmmInt _ _) -> CmmBranch dest
		   _other -> CmmCondBranch test' dest
907

908
	CmmSwitch expr ids
909
	   -> do expr' <- cmmExprConFold DataReference expr
910
	         return $ CmmSwitch expr' ids
911
912

        other
913
           -> return other
914

dterei's avatar
dterei committed
915
cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
916
917
918
919
920
921
cmmExprConFold referenceKind expr = do
    dflags <- getDynFlagsCmmOpt
    -- Skip constant folding if new code generator is running
    -- (this optimization is done in Hoopl)
    let expr' = if dopt Opt_TryNewCodeGen dflags
                    then expr
Ian Lynagh's avatar
Ian Lynagh committed
922
                    else cmmExprCon (targetPlatform dflags) expr
923
    cmmExprNative referenceKind expr'
924

Ian Lynagh's avatar
Ian Lynagh committed
925
926
927
928
929
cmmExprCon :: Platform -> CmmExpr -> CmmExpr
cmmExprCon platform (CmmLoad addr rep) = CmmLoad (cmmExprCon platform addr) rep
cmmExprCon platform (CmmMachOp mop args)
    = cmmMachOpFold platform mop (map (cmmExprCon platform) args)
cmmExprCon _ other = other
930
931
932
933
934

-- handles both PIC and non-PIC cases... a very strange mixture
-- of things to do.
cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprNative referenceKind expr = do
935
     dflags <- getDynFlagsCmmOpt
Ian Lynagh's avatar
Ian Lynagh committed
936
937
     let platform = targetPlatform dflags
         arch = platformArch platform
938
     case expr of
939
        CmmLoad addr rep
940
           -> do addr' <- cmmExprNative DataReference addr
941
                 return $ CmmLoad addr' rep
942
943

        CmmMachOp mop args
944
945
           -> do args' <- mapM (cmmExprNative DataReference) args
                 return $ CmmMachOp mop args'
946
947

        CmmLit (CmmLabel lbl)
948
           -> do
949
                cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
950
        CmmLit (CmmLabelOff lbl off)
951
           -> do
952
953
                 dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
                 -- need to optimize here, since it's late
Ian Lynagh's avatar
Ian Lynagh committed
954
                 return $ cmmMachOpFold platform (MO_Add wordWidth) [
955
                     dynRef,
956
                     (CmmLit $ CmmInt (fromIntegral off) wordWidth)
957
                   ]
958

959
960
961
        -- On powerpc (non-PIC), it's easier to jump directly to a label than
        -- to use the register table, so we replace these registers
        -- with the corresponding labels:
962
        CmmReg (CmmGlobal EagerBlackholeInfo)
963
          | arch == ArchPPC && not opt_PIC
964
          -> cmmExprNative referenceKind $
965
             CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info")))
966
        CmmReg (CmmGlobal GCEnter1)
967
          | arch == ArchPPC && not opt_PIC
968
          -> cmmExprNative referenceKind $
969
             CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1"))) 
970
        CmmReg (CmmGlobal GCFun)
971
          | arch == ArchPPC && not opt_PIC
972
          -> cmmExprNative referenceKind $
973
             CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun")))
974

975
        other
976
           -> return other
977
978
979

\end{code}