MachCode.lhs 106 KB
Newer Older
1
%
2
% (c) The AQUA Project, Glasgow University, 1996-1998
3
4
5
6
7
8
9
10
11
%
\section[MachCode]{Generating machine code}

This is a big module, but, if you pay attention to
(a) the sectioning, (b) the type signatures, and
(c) the \tr{#if blah_TARGET_ARCH} things, the
structure should not be too overwhelming.

\begin{code}
12
module MachCode ( stmtsToInstrs, InstrBlock ) where
13

14
15
16
17
18
#include "HsVersions.h"
#include "nativeGen/NCG.h"

import MachMisc		-- may differ per-platform
import MachRegs
19
20
import OrdList		( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
			  snocOL, consOL, concatOL )
21
import AbsCUtils	( magicIdPrimRep )
sof's avatar
sof committed
22
import CallConv		( CallConv )
23
import CLabel		( isAsmTemp, CLabel, labelDynamic )
24
25
import Maybes		( maybeToBool, expectJust )
import PrimRep		( isFloatingRep, PrimRep(..) )
26
import PrimOp		( PrimOp(..) )
27
import CallConv		( cCallConv, stdCallConv )
28
import Stix		( getNatLabelNCG, StixTree(..),
29
30
			  StixReg(..), CodeSegment(..), 
                          DestInfo, hasDestInfo,
31
                          pprStixTree, 
32
33
                          NatM, thenNat, returnNat, mapNat, 
                          mapAndUnzipNat, mapAccumLNat,
34
                          getDeltaNat, setDeltaNat
35
			)
36
import Outputable
37
import CmdLineOpts	( opt_Static )
38

39
40
infixr 3 `bind`

41
42
43
44
45
46
47
48
49
50
51
52
53
\end{code}

@InstrBlock@s are the insn sequences generated by the insn selectors.
They are really trees of insns to facilitate fast appending, where a
left-to-right traversal (pre-order?) yields the insns in the correct
order.

\begin{code}

type InstrBlock = OrdList Instr

x `bind` f = f x

54
55
56
57
58
\end{code}

Code extractor for an entire stix tree---stix statement level.

\begin{code}
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
stmtsToInstrs :: [StixTree] -> NatM InstrBlock
stmtsToInstrs stmts
   = liftStrings stmts [] []		`thenNat` \ lifted ->
     mapNat stmtToInstrs lifted		`thenNat` \ instrss ->
     returnNat (concatOL instrss)


-- Lift StStrings out of top-level StDatas, putting them at the end of
-- the block, and replacing them with StCLbls which refer to the lifted-out strings. 
{- Motivation for this hackery provided by the following bug:
   Stix:
      (DataSegment)
      Bogon.ping_closure :
      (Data P_ Addr.A#_static_info)
      (Data StgAddr (Str `alalal'))
      (Data P_ (0))
   results in:
      .data
              .align 8
      .global Bogon_ping_closure
      Bogon_ping_closure:
              .long   Addr_Azh_static_info
              .long   .Ln1a8
      .Ln1a8:
              .byte   0x61
              .byte   0x6C
              .byte   0x61
              .byte   0x6C
              .byte   0x61
              .byte   0x6C
              .byte   0x00
              .long   0
   ie, the Str is planted in-line, when what we really meant was to place
   a _reference_ to the string there.  liftStrings will lift out all such
   strings in top-level data and place them at the end of the block.
94
95
96
97
98

   This is still a rather half-baked solution -- to do the job entirely right
   would mean a complete traversal of all the Stixes, but there's currently no
   real need for it, and it would be slow.  Also, potentially there could be
   literal types other than strings which need lifting out?
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
-}

liftStrings :: [StixTree]    -- originals
            -> [StixTree]    -- (reverse) originals with strings lifted out
            -> [(CLabel, FAST_STRING)]   -- lifted strs, and their new labels
            -> NatM [StixTree]

-- First, examine the original trees and lift out strings in top-level StDatas.
liftStrings (st:sts) acc_stix acc_strs
   = case st of
        StData sz datas
           -> lift datas acc_strs 	`thenNat` \ (datas_done, acc_strs1) ->
              liftStrings sts ((StData sz datas_done):acc_stix) acc_strs1
        other 
           -> liftStrings sts (other:acc_stix) acc_strs
     where
        -- Handle a top-level StData
        lift []     acc_strs = returnNat ([], acc_strs)
        lift (d:ds) acc_strs
           = lift ds acc_strs 		`thenNat` \ (ds_done, acc_strs1) ->
             case d of
                StString s 
                   -> getNatLabelNCG 	`thenNat` \ lbl ->
                      returnNat ((StCLbl lbl):ds_done, ((lbl,s):acc_strs1))
                other
                   -> returnNat (other:ds_done, acc_strs1)

-- When we've run out of original trees, emit the lifted strings.
liftStrings [] acc_stix acc_strs
   = returnNat (reverse acc_stix ++ concatMap f acc_strs)
     where
        f (lbl,str) = [StSegment RoDataSegment, 
                       StLabel lbl, 
                       StString str, 
                       StSegment TextSegment]

135

136
137
stmtToInstrs :: StixTree {- a stix statement -} -> NatM InstrBlock
stmtToInstrs stmt = case stmt of
138
139
    StComment s    -> returnNat (unitOL (COMMENT s))
    StSegment seg  -> returnNat (unitOL (SEGMENT seg))
140

141
142
143
144
    StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
                                                       LABEL lab)))
    StFunEnd lab   -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
                                    returnNat nilOL)
145

146
    StLabel lab	   -> returnNat (unitOL (LABEL lab))
147

148
    StJump dsts arg	   -> genJump dsts (derefDLL arg)
149
150
151
152
153
    StCondJump lab arg	   -> genCondJump lab (derefDLL arg)

    -- A call returning void, ie one done for its side-effects
    StCall fn cconv VoidRep args -> genCCall fn
                                             cconv VoidRep (map derefDLL args)
154
155

    StAssign pk dst src
156
157
      | isFloatingRep pk -> assignFltCode pk (derefDLL dst) (derefDLL src)
      | otherwise	 -> assignIntCode pk (derefDLL dst) (derefDLL src)
158
159
160
161
162

    StFallThrough lbl
	-- When falling through on the Alpha, we still have to load pv
	-- with the address of the next routine, so that it can load gp.
      -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
163
	,returnNat nilOL)
164
165

    StData kind args
166
167
168
      -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
	 returnNat (DATA (primRepToSize kind) imms  
                    `consOL`  concatOL codes)
169
      where
170
	getData :: StixTree -> NatM (InstrBlock, Imm)
171
172
	getData (StInt i)        = returnNat (nilOL, ImmInteger i)
	getData (StDouble d)     = returnNat (nilOL, ImmDouble d)
173
	getData (StFloat d)      = returnNat (nilOL, ImmFloat d)
174
	getData (StCLbl l)       = returnNat (nilOL, ImmCLbl l)
175
	getData (StString s)     = panic "MachCode.stmtToInstrs: unlifted StString"
176
177
	-- the linker can handle simple arithmetic...
	getData (StIndex rep (StCLbl lbl) (StInt off)) =
178
179
		returnNat (nilOL,
                           ImmIndex lbl (fromInteger off * sizeOf rep))
180

181
182
183
184
185
186
    -- Top-level lifted-out string.  The segment will already have been set
    -- (see liftStrings above).
    StString str
      -> returnNat (unitOL (ASCII True (_UNPK_ str)))


187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
-- Walk a Stix tree, and insert dereferences to CLabels which are marked
-- as labelDynamic.  stmt2Instrs calls derefDLL selectively, because
-- not all such CLabel occurrences need this dereferencing -- SRTs don't
-- for one.
derefDLL :: StixTree -> StixTree
derefDLL tree
   | opt_Static   -- short out the entire deal if not doing DLLs
   = tree
   | otherwise
   = qq tree
     where
        qq t
           = case t of
                StCLbl lbl -> if   labelDynamic lbl
                              then StInd PtrRep (StCLbl lbl)
                              else t
                -- all the rest are boring
                StIndex pk base offset -> StIndex pk (qq base) (qq offset)
                StPrim pk args         -> StPrim pk (map qq args)
                StInd pk addr          -> StInd pk (qq addr)
                StCall who cc pk args  -> StCall who cc pk (map qq args)
                StInt    _             -> t
209
                StFloat  _             -> t
210
211
212
213
214
215
                StDouble _             -> t
                StString _             -> t
                StReg    _             -> t
                StScratchWord _        -> t
                _                      -> pprPanic "derefDLL: unhandled case" 
                                                   (pprStixTree t)
216
217
218
219
220
221
222
223
224
225
226
227
228
229
\end{code}

%************************************************************************
%*									*
\subsection{General things for putting together code sequences}
%*									*
%************************************************************************

\begin{code}
mangleIndexTree :: StixTree -> StixTree

mangleIndexTree (StIndex pk base (StInt i))
  = StPrim IntAddOp [base, off]
  where
230
    off = StInt (i * toInteger (sizeOf pk))
231
232

mangleIndexTree (StIndex pk base off)
233
234
235
  = StPrim IntAddOp [
       base,
       let s = shift pk
236
       in  if s == 0 then off else StPrim SllOp [off, StInt (toInteger s)]
237
      ]
238
  where
239
    shift :: PrimRep -> Int
240
    shift rep = case sizeOf rep of
241
242
243
244
245
246
                   1 -> 0
                   2 -> 1
                   4 -> 2
                   8 -> 3
                   other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size" 
                                     (int other)
247
248
249
250
251
\end{code}

\begin{code}
maybeImm :: StixTree -> Maybe Imm

252
253
254
maybeImm (StCLbl l)       
   = Just (ImmCLbl l)
maybeImm (StIndex rep (StCLbl l) (StInt off)) 
255
   = Just (ImmIndex l (fromInteger off * sizeOf rep))
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
maybeImm (StInt i)
  | i >= toInteger minInt && i <= toInteger maxInt
  = Just (ImmInt (fromInteger i))
  | otherwise
  = Just (ImmInteger i)

maybeImm _ = Nothing
\end{code}

%************************************************************************
%*									*
\subsection{The @Register@ type}
%*									*
%************************************************************************

@Register@s passed up the tree.  If the stix code forces the register
to live in a pre-decided machine register, it comes out as @Fixed@;
otherwise, it comes out as @Any@, and the parent can decide which
register to put it in.

\begin{code}
data Register
  = Fixed   PrimRep Reg InstrBlock
  | Any	    PrimRep (Reg -> InstrBlock)

registerCode :: Register -> Reg -> InstrBlock
registerCode (Fixed _ _ code) reg = code
registerCode (Any _ code) reg = code reg

285
286
287
registerCodeF (Fixed _ _ code) = code
registerCodeF (Any _ _)        = pprPanic "registerCodeF" empty

288
289
290
registerCodeA (Any _ code)  = code
registerCodeA (Fixed _ _ _) = pprPanic "registerCodeA" empty

291
292
registerName :: Register -> Reg -> Reg
registerName (Fixed _ reg _) _ = reg
293
294
295
296
registerName (Any _ _)   reg   = reg

registerNameF (Fixed _ reg _) = reg
registerNameF (Any _ _)       = pprPanic "registerNameF" empty
297
298
299
300
301

registerRep :: Register -> PrimRep
registerRep (Fixed pk _ _) = pk
registerRep (Any   pk _) = pk

302
303
304
305
306
307
308
309
310
{-# INLINE registerCode  #-}
{-# INLINE registerCodeF #-}
{-# INLINE registerName  #-}
{-# INLINE registerNameF #-}
{-# INLINE registerRep   #-}
{-# INLINE isFixed       #-}
{-# INLINE isAny         #-}

isFixed, isAny :: Register -> Bool
311
312
isFixed (Fixed _ _ _) = True
isFixed (Any _ _)     = False
313

314
isAny = not . isFixed
315
316
317
318
\end{code}

Generate code to get a subtree into a @Register@:
\begin{code}
319
getRegister :: StixTree -> NatM Register
320
321
322

getRegister (StReg (StixMagicId stgreg))
  = case (magicIdRegMaybe stgreg) of
323
      Just reg -> returnNat (Fixed (magicIdPrimRep stgreg) reg nilOL)
324
                  -- cannae be Nothing
325
326

getRegister (StReg (StixTemp u pk))
327
  = returnNat (Fixed pk (mkVReg u pk) nilOL)
328
329
330

getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)

sof's avatar
sof committed
331
getRegister (StCall fn cconv kind args)
332
333
  = genCCall fn cconv kind args   	    `thenNat` \ call ->
    returnNat (Fixed kind reg call)
334
335
  where
    reg = if isFloatingRep kind
336
	  then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,)))
337
338
339
	  else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))

getRegister (StString s)
340
  = getNatLabelNCG 	    	    `thenNat` \ lbl ->
341
342
343
    let
	imm_lbl = ImmCLbl lbl

344
	code dst = toOL [
345
	    SEGMENT RoDataSegment,
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
	    LABEL lbl,
	    ASCII True (_UNPK_ s),
	    SEGMENT TextSegment,
#if alpha_TARGET_ARCH
	    LDA dst (AddrImm imm_lbl)
#endif
#if i386_TARGET_ARCH
	    MOV L (OpImm imm_lbl) (OpReg dst)
#endif
#if sparc_TARGET_ARCH
	    SETHI (HI imm_lbl) dst,
	    OR False dst (RIImm (LO imm_lbl)) dst
#endif
	    ]
    in
361
    returnNat (Any PtrRep code)
362
363
364
365
366
367
368
369



-- end of machine-"independent" bit; here we go on the rest...

#if alpha_TARGET_ARCH

getRegister (StDouble d)
370
371
  = getNatLabelNCG 	    	    `thenNat` \ lbl ->
    getNewRegNCG PtrRep    	    `thenNat` \ tmp ->
372
373
374
    let code dst = mkSeqInstrs [
    	    SEGMENT DataSegment,
	    LABEL lbl,
sof's avatar
sof committed
375
	    DATA TF [ImmLab (rational d)],
376
377
378
379
	    SEGMENT TextSegment,
	    LDA tmp (AddrImm (ImmCLbl lbl)),
	    LD TF dst (AddrReg tmp)]
    in
380
    	returnNat (Any DoubleRep code)
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401

getRegister (StPrim primop [x]) -- unary PrimOps
  = case primop of
      IntNegOp -> trivialUCode (NEG Q False) x

      NotOp    -> trivialUCode NOT x

      FloatNegOp  -> trivialUFCode FloatRep  (FNEG TF) x
      DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x

      OrdOp -> coerceIntCode IntRep x
      ChrOp -> chrCode x

      Float2IntOp  -> coerceFP2Int    x
      Int2FloatOp  -> coerceInt2FP pr x
      Double2IntOp -> coerceFP2Int    x
      Int2DoubleOp -> coerceInt2FP pr x

      Double2FloatOp -> coerceFltCode x
      Float2DoubleOp -> coerceFltCode x

sof's avatar
sof committed
402
      other_op -> getRegister (StCall fn cCallConv DoubleRep [x])
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
	where
	  fn = case other_op of
		 FloatExpOp    -> SLIT("exp")
		 FloatLogOp    -> SLIT("log")
		 FloatSqrtOp   -> SLIT("sqrt")
		 FloatSinOp    -> SLIT("sin")
		 FloatCosOp    -> SLIT("cos")
		 FloatTanOp    -> SLIT("tan")
		 FloatAsinOp   -> SLIT("asin")
		 FloatAcosOp   -> SLIT("acos")
		 FloatAtanOp   -> SLIT("atan")
		 FloatSinhOp   -> SLIT("sinh")
		 FloatCoshOp   -> SLIT("cosh")
		 FloatTanhOp   -> SLIT("tanh")
		 DoubleExpOp   -> SLIT("exp")
		 DoubleLogOp   -> SLIT("log")
		 DoubleSqrtOp  -> SLIT("sqrt")
		 DoubleSinOp   -> SLIT("sin")
		 DoubleCosOp   -> SLIT("cos")
		 DoubleTanOp   -> SLIT("tan")
		 DoubleAsinOp  -> SLIT("asin")
		 DoubleAcosOp  -> SLIT("acos")
		 DoubleAtanOp  -> SLIT("atan")
		 DoubleSinhOp  -> SLIT("sinh")
		 DoubleCoshOp  -> SLIT("cosh")
		 DoubleTanhOp  -> SLIT("tanh")
  where
    pr = panic "MachCode.getRegister: no primrep needed for Alpha"

getRegister (StPrim primop [x, y]) -- dyadic PrimOps
  = case primop of
434
      CharGtOp -> trivialCode (CMP LTT) y x
435
      CharGeOp -> trivialCode (CMP LE) y x
436
      CharEqOp -> trivialCode (CMP EQQ) x y
437
      CharNeOp -> int_NE_code x y
438
      CharLtOp -> trivialCode (CMP LTT) x y
439
440
      CharLeOp -> trivialCode (CMP LE) x y

441
      IntGtOp  -> trivialCode (CMP LTT) y x
442
      IntGeOp  -> trivialCode (CMP LE) y x
443
      IntEqOp  -> trivialCode (CMP EQQ) x y
444
      IntNeOp  -> int_NE_code x y
445
      IntLtOp  -> trivialCode (CMP LTT) x y
446
447
448
449
      IntLeOp  -> trivialCode (CMP LE) x y

      WordGtOp -> trivialCode (CMP ULT) y x
      WordGeOp -> trivialCode (CMP ULE) x y
450
      WordEqOp -> trivialCode (CMP EQQ)  x y
451
452
453
454
455
456
      WordNeOp -> int_NE_code x y
      WordLtOp -> trivialCode (CMP ULT) x y
      WordLeOp -> trivialCode (CMP ULE) x y

      AddrGtOp -> trivialCode (CMP ULT) y x
      AddrGeOp -> trivialCode (CMP ULE) y x
457
      AddrEqOp -> trivialCode (CMP EQQ)  x y
458
459
460
461
      AddrNeOp -> int_NE_code x y
      AddrLtOp -> trivialCode (CMP ULT) x y
      AddrLeOp -> trivialCode (CMP ULE) x y

462
463
464
465
466
      FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
      FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
      FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
      FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
      FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
467
468
      FloatLeOp -> cmpF_code (FCMP TF LE) NE x y

469
470
471
472
473
      DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
      DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
      DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
      DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
      DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
474
475
476
477
478
479
480
481
      DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y

      IntAddOp  -> trivialCode (ADD Q False) x y
      IntSubOp  -> trivialCode (SUB Q False) x y
      IntMulOp  -> trivialCode (MUL Q False) x y
      IntQuotOp -> trivialCode (DIV Q False) x y
      IntRemOp  -> trivialCode (REM Q False) x y

482
483
484
      WordAddOp  -> trivialCode (ADD Q False) x y
      WordSubOp  -> trivialCode (SUB Q False) x y
      WordMulOp  -> trivialCode (MUL Q False) x y
485
486
487
      WordQuotOp -> trivialCode (DIV Q True) x y
      WordRemOp  -> trivialCode (REM Q True) x y

488
489
490
491
492
493
494
495
496
497
498
499
      FloatAddOp -> trivialFCode  FloatRep (FADD TF) x y
      FloatSubOp -> trivialFCode  FloatRep (FSUB TF) x y
      FloatMulOp -> trivialFCode  FloatRep (FMUL TF) x y
      FloatDivOp -> trivialFCode  FloatRep (FDIV TF) x y

      DoubleAddOp -> trivialFCode  DoubleRep (FADD TF) x y
      DoubleSubOp -> trivialFCode  DoubleRep (FSUB TF) x y
      DoubleMulOp -> trivialFCode  DoubleRep (FMUL TF) x y
      DoubleDivOp -> trivialFCode  DoubleRep (FDIV TF) x y

      AndOp  -> trivialCode AND x y
      OrOp   -> trivialCode OR  x y
500
      XorOp  -> trivialCode XOR x y
501
502
503
      SllOp  -> trivialCode SLL x y
      SrlOp  -> trivialCode SRL x y

sof's avatar
sof committed
504
      ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
sof's avatar
sof committed
505
      ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
sof's avatar
sof committed
506
      ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
507

sof's avatar
sof committed
508
509
      FloatPowerOp  -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
      DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
510
511
512
513
514
515
516
517
518
  where
    {- ------------------------------------------------------------
	Some bizarre special code for getting condition codes into
	registers.  Integer non-equality is a test for equality
	followed by an XOR with 1.  (Integer comparisons always set
	the result register to 0 or 1.)  Floating point comparisons of
	any kind leave the result in a floating point register, so we
	need to wrangle an integer register out of things.
    -}
519
    int_NE_code :: StixTree -> StixTree -> NatM Register
520
521

    int_NE_code x y
522
523
      = trivialCode (CMP EQQ) x y	`thenNat` \ register ->
	getNewRegNCG IntRep		`thenNat` \ tmp ->
524
525
526
527
528
	let
	    code = registerCode register tmp
	    src  = registerName register tmp
	    code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
	in
529
	returnNat (Any IntRep code__2)
530
531
532
533
534
535
536
537

    {- ------------------------------------------------------------
	Comments for int_NE_code also apply to cmpF_code
    -}
    cmpF_code
	:: (Reg -> Reg -> Reg -> Instr)
	-> Cond
	-> StixTree -> StixTree
538
	-> NatM Register
539
540

    cmpF_code instr cond x y
541
542
543
      = trivialFCode pr instr x y	`thenNat` \ register ->
	getNewRegNCG DoubleRep		`thenNat` \ tmp ->
	getNatLabelNCG			`thenNat` \ lbl ->
544
545
546
547
548
	let
	    code = registerCode register tmp
	    result  = registerName register tmp

	    code__2 dst = code . mkSeqInstrs [
549
550
551
		OR zeroh (RIImm (ImmInt 1)) dst,
		BF cond  result (ImmCLbl lbl),
		OR zeroh (RIReg zeroh) dst,
552
553
		LABEL lbl]
	in
554
	returnNat (Any IntRep code__2)
555
556
557
558
559
      where
	pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
      ------------------------------------------------------------

getRegister (StInd pk mem)
560
  = getAmode mem    	    	    `thenNat` \ amode ->
561
562
563
564
565
566
    let
    	code = amodeCode amode
    	src   = amodeAddr amode
    	size = primRepToSize pk
    	code__2 dst = code . mkSeqInstr (LD size dst src)
    in
567
    returnNat (Any pk code__2)
568
569
570
571

getRegister (StInt i)
  | fits8Bits i
  = let
572
    	code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
573
    in
574
    returnNat (Any IntRep code)
575
576
577
578
  | otherwise
  = let
    	code dst = mkSeqInstr (LDI Q dst src)
    in
579
    returnNat (Any IntRep code)
580
581
582
583
584
585
586
587
  where
    src = ImmInt (fromInteger i)

getRegister leaf
  | maybeToBool imm
  = let
    	code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
    in
588
    returnNat (Any PtrRep code)
589
590
591
592
593
594
595
596
  where
    imm = maybeImm leaf
    imm__2 = case imm of Just x -> x

#endif {- alpha_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if i386_TARGET_ARCH

597
598
599
600
601
602
603
604
605
606
607
608
609
getRegister (StFloat f)
  = getNatLabelNCG 	    	    `thenNat` \ lbl ->
    let code dst = toOL [
    	    SEGMENT DataSegment,
	    LABEL lbl,
	    DATA F [ImmFloat f],
	    SEGMENT TextSegment,
	    GLD F (ImmAddr (ImmCLbl lbl) 0) dst
	    ]
    in
    returnNat (Any FloatRep code)


610
getRegister (StDouble d)
611
612
613

  | d == 0.0
  = let code dst = unitOL (GLDZ dst)
614
    in  returnNat (Any DoubleRep code)
615
616
617

  | d == 1.0
  = let code dst = unitOL (GLD1 dst)
618
    in  returnNat (Any DoubleRep code)
619
620
621
622

  | otherwise
  = getNatLabelNCG 	    	    `thenNat` \ lbl ->
    let code dst = toOL [
623
624
    	    SEGMENT DataSegment,
	    LABEL lbl,
625
	    DATA DF [ImmDouble d],
626
	    SEGMENT TextSegment,
627
	    GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
628
629
	    ]
    in
630
    returnNat (Any DoubleRep code)
631

632
633
-- Calculate the offset for (i+1) words above the _initial_
-- %esp value by first determining the current offset of it.
634
getRegister (StScratchWord i)
635
   | i >= 0 && i < 6
636
637
638
   = getDeltaNat `thenNat` \ current_stack_offset ->
     let j = i+1   - (current_stack_offset `div` 4)
         code dst
639
           = unitOL (LEA L (OpAddr (spRel j)) (OpReg dst))
640
641
     in 
     returnNat (Any PtrRep code)
642

643
644
645
646
647
getRegister (StPrim primop [x]) -- unary PrimOps
  = case primop of
      IntNegOp  -> trivialUCode (NEGI L) x
      NotOp	-> trivialUCode (NOT L) x

648
649
650
651
652
      FloatNegOp  -> trivialUFCode FloatRep  (GNEG F) x
      DoubleNegOp -> trivialUFCode DoubleRep (GNEG DF) x

      FloatSqrtOp  -> trivialUFCode FloatRep  (GSQRT F) x
      DoubleSqrtOp -> trivialUFCode DoubleRep (GSQRT DF) x
653

654
655
656
657
658
659
660
661
662
      FloatSinOp  -> trivialUFCode FloatRep  (GSIN F) x
      DoubleSinOp -> trivialUFCode DoubleRep (GSIN DF) x

      FloatCosOp  -> trivialUFCode FloatRep  (GCOS F) x
      DoubleCosOp -> trivialUFCode DoubleRep (GCOS DF) x

      FloatTanOp  -> trivialUFCode FloatRep  (GTAN F) x
      DoubleTanOp -> trivialUFCode DoubleRep (GTAN DF) x

663
664
      Double2FloatOp -> trivialUFCode FloatRep  GDTOF x
      Float2DoubleOp -> trivialUFCode DoubleRep GFTOD x
665
666
667
668
669
670
671
672
673
674

      OrdOp -> coerceIntCode IntRep x
      ChrOp -> chrCode x

      Float2IntOp  -> coerceFP2Int x
      Int2FloatOp  -> coerceInt2FP FloatRep x
      Double2IntOp -> coerceFP2Int x
      Int2DoubleOp -> coerceInt2FP DoubleRep x

      other_op ->
sof's avatar
sof committed
675
	getRegister (StCall fn cCallConv DoubleRep [x])
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
       where
	(is_float_op, fn)
	  = case primop of
	      FloatExpOp    -> (True,  SLIT("exp"))
	      FloatLogOp    -> (True,  SLIT("log"))

	      FloatAsinOp   -> (True,  SLIT("asin"))
	      FloatAcosOp   -> (True,  SLIT("acos"))
	      FloatAtanOp   -> (True,  SLIT("atan"))

	      FloatSinhOp   -> (True,  SLIT("sinh"))
	      FloatCoshOp   -> (True,  SLIT("cosh"))
	      FloatTanhOp   -> (True,  SLIT("tanh"))

	      DoubleExpOp   -> (False, SLIT("exp"))
	      DoubleLogOp   -> (False, SLIT("log"))

	      DoubleAsinOp  -> (False, SLIT("asin"))
	      DoubleAcosOp  -> (False, SLIT("acos"))
	      DoubleAtanOp  -> (False, SLIT("atan"))

	      DoubleSinhOp  -> (False, SLIT("sinh"))
	      DoubleCoshOp  -> (False, SLIT("cosh"))
	      DoubleTanhOp  -> (False, SLIT("tanh"))

701
702
              other
                 -> pprPanic "getRegister(x86,unary primop)" 
703
                             (pprStixTree (StPrim primop [x]))
704

705
706
getRegister (StPrim primop [x, y]) -- dyadic PrimOps
  = case primop of
707
      CharGtOp -> condIntReg GTT x y
708
      CharGeOp -> condIntReg GE x y
709
      CharEqOp -> condIntReg EQQ x y
710
      CharNeOp -> condIntReg NE x y
711
      CharLtOp -> condIntReg LTT x y
712
713
      CharLeOp -> condIntReg LE x y

714
      IntGtOp  -> condIntReg GTT x y
715
      IntGeOp  -> condIntReg GE x y
716
      IntEqOp  -> condIntReg EQQ x y
717
      IntNeOp  -> condIntReg NE x y
718
      IntLtOp  -> condIntReg LTT x y
719
720
721
722
      IntLeOp  -> condIntReg LE x y

      WordGtOp -> condIntReg GU  x y
      WordGeOp -> condIntReg GEU x y
723
      WordEqOp -> condIntReg EQQ  x y
724
725
726
727
728
729
      WordNeOp -> condIntReg NE  x y
      WordLtOp -> condIntReg LU  x y
      WordLeOp -> condIntReg LEU x y

      AddrGtOp -> condIntReg GU  x y
      AddrGeOp -> condIntReg GEU x y
730
      AddrEqOp -> condIntReg EQQ  x y
731
732
733
734
      AddrNeOp -> condIntReg NE  x y
      AddrLtOp -> condIntReg LU  x y
      AddrLeOp -> condIntReg LEU x y

735
      FloatGtOp -> condFltReg GTT x y
736
      FloatGeOp -> condFltReg GE x y
737
      FloatEqOp -> condFltReg EQQ x y
738
      FloatNeOp -> condFltReg NE x y
739
      FloatLtOp -> condFltReg LTT x y
740
741
      FloatLeOp -> condFltReg LE x y

742
      DoubleGtOp -> condFltReg GTT x y
743
      DoubleGeOp -> condFltReg GE x y
744
      DoubleEqOp -> condFltReg EQQ x y
745
      DoubleNeOp -> condFltReg NE x y
746
      DoubleLtOp -> condFltReg LTT x y
747
748
      DoubleLeOp -> condFltReg LE x y

749
750
      IntAddOp  -> add_code L x y
      IntSubOp  -> sub_code L x y
751
752
      IntQuotOp -> trivialCode (IQUOT L) Nothing x y
      IntRemOp  -> trivialCode (IREM L) Nothing x y
753
      IntMulOp  -> let op = IMUL L in trivialCode op (Just op) x y
754

755
756
757
758
      WordAddOp  -> add_code L x y
      WordSubOp  -> sub_code L x y
      WordMulOp  -> let op = IMUL L in trivialCode op (Just op) x y

759
760
761
762
      FloatAddOp -> trivialFCode  FloatRep  GADD x y
      FloatSubOp -> trivialFCode  FloatRep  GSUB x y
      FloatMulOp -> trivialFCode  FloatRep  GMUL x y
      FloatDivOp -> trivialFCode  FloatRep  GDIV x y
763

764
765
766
767
      DoubleAddOp -> trivialFCode DoubleRep GADD x y
      DoubleSubOp -> trivialFCode DoubleRep GSUB x y
      DoubleMulOp -> trivialFCode DoubleRep GMUL x y
      DoubleDivOp -> trivialFCode DoubleRep GDIV x y
768

769
770
771
      AndOp -> let op = AND L in trivialCode op (Just op) x y
      OrOp  -> let op = OR  L in trivialCode op (Just op) x y
      XorOp -> let op = XOR L in trivialCode op (Just op) x y
772

sof's avatar
sof committed
773
774
775
776
777
	{- Shift ops on x86s have constraints on their source, it
	   either has to be Imm, CL or 1
	    => trivialCode's is not restrictive enough (sigh.)
	-}
	   
778
779
      SllOp  -> shift_code (SHL L) x y {-False-}
      SrlOp  -> shift_code (SHR L) x y {-False-}
780
781
782
      ISllOp -> shift_code (SHL L) x y {-False-}
      ISraOp -> shift_code (SAR L) x y {-False-}
      ISrlOp -> shift_code (SHR L) x y {-False-}
783

784
785
      FloatPowerOp  -> getRegister (StCall SLIT("pow") cCallConv DoubleRep 
                                           [promote x, promote y])
786
		       where promote x = StPrim Float2DoubleOp [x]
787
788
      DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep 
                                           [x, y])
789
790
      other
         -> pprPanic "getRegister(x86,dyadic primop)" 
791
                     (pprStixTree (StPrim primop [x, y]))
792
  where
793
794

    --------------------
795
    shift_code :: (Imm -> Operand -> Instr)
sof's avatar
sof committed
796
797
	       -> StixTree
	       -> StixTree
798
	       -> NatM Register
799

sof's avatar
sof committed
800
801
802
803
      {- Case1: shift length as immediate -}
      -- Code is the same as the first eq. for trivialCode -- sigh.
    shift_code instr x y{-amount-}
      | maybeToBool imm
804
      = getRegister x	                   `thenNat` \ regx ->
805
        let mkcode dst
806
807
808
809
              = if   isAny regx
                then registerCodeA regx dst  `bind` \ code_x ->
                     code_x `snocOL`
                     instr imm__2 (OpReg dst)
810
811
                else registerCodeF regx      `bind` \ code_x ->
                     registerNameF regx      `bind` \ r_x ->
812
813
814
                     code_x `snocOL`
                     MOV L (OpReg r_x) (OpReg dst) `snocOL`
                     instr imm__2 (OpReg dst)
815
        in
816
        returnNat (Any IntRep mkcode)        
sof's avatar
sof committed
817
818
819
820
821
      where
       imm = maybeImm y
       imm__2 = case imm of Just x -> x

      {- Case2: shift length is complex (non-immediate) -}
822
823
824
825
      -- Since ECX is always used as a spill temporary, we can't
      -- use it here to do non-immediate shifts.  No big deal --
      -- they are only very rare, and we can use an equivalent
      -- test-and-jump sequence which doesn't use ECX.
826
      -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE, 
827
      -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
sof's avatar
sof committed
828
    shift_code instr x y{-amount-}
829
830
831
832
833
834
835
836
     = getRegister x   `thenNat` \ register1 ->
       getRegister y   `thenNat` \ register2 ->
       getNatLabelNCG  `thenNat` \ lbl_test3 ->
       getNatLabelNCG  `thenNat` \ lbl_test2 ->
       getNatLabelNCG  `thenNat` \ lbl_test1 ->
       getNatLabelNCG  `thenNat` \ lbl_test0 ->
       getNatLabelNCG  `thenNat` \ lbl_after ->
       getNewRegNCG IntRep   `thenNat` \ tmp ->
837
838
839
840
841
842
843
844
       let code__2 dst
              = let src_val  = registerName register1 dst
                    code_val = registerCode register1 dst
                    src_amt  = registerName register2 tmp
                    code_amt = registerCode register2 tmp
                    r_dst    = OpReg dst
                    r_tmp    = OpReg tmp
                in
845
846
847
848
849
                    code_amt `snocOL`
                    MOV L (OpReg src_amt) r_tmp `appOL`
                    code_val `snocOL`
                    MOV L (OpReg src_val) r_dst `appOL`
                    toOL [
850
851
852
853
854
855
                       COMMENT (_PK_ "begin shift sequence"),
                       MOV L (OpReg src_val) r_dst,
                       MOV L (OpReg src_amt) r_tmp,

                       BT L (ImmInt 4) r_tmp,
                       JXX GEU lbl_test3,
856
                       instr (ImmInt 16) r_dst,
857
858
859
860

                       LABEL lbl_test3,
                       BT L (ImmInt 3) r_tmp,
                       JXX GEU lbl_test2,
861
                       instr (ImmInt 8) r_dst,
862
863
864
865

                       LABEL lbl_test2,
                       BT L (ImmInt 2) r_tmp,
                       JXX GEU lbl_test1,
866
                       instr (ImmInt 4) r_dst,
867
868
869
870

                       LABEL lbl_test1,
                       BT L (ImmInt 1) r_tmp,
                       JXX GEU lbl_test0,
871
                       instr (ImmInt 2) r_dst,
872
873
874
875

                       LABEL lbl_test0,
                       BT L (ImmInt 0) r_tmp,
                       JXX GEU lbl_after,
876
                       instr (ImmInt 1) r_dst,
877
878
879
880
881
                       LABEL lbl_after,
                                           
                       COMMENT (_PK_ "end shift sequence")
                    ]
       in
882
       returnNat (Any IntRep code__2)
883

884
    --------------------
885
    add_code :: Size -> StixTree -> StixTree -> NatM Register
886
887

    add_code sz x (StInt y)
888
889
      = getRegister x		`thenNat` \ register ->
	getNewRegNCG IntRep	`thenNat` \ tmp ->
890
891
892
893
	let
	    code = registerCode register tmp
	    src1 = registerName register tmp
	    src2 = ImmInt (fromInteger y)
894
	    code__2 dst 
895
896
897
               = code `snocOL`
		 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
                        (OpReg dst)
898
	in
899
	returnNat (Any IntRep code__2)
900

901
    add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
902
903

    --------------------
904
    sub_code :: Size -> StixTree -> StixTree -> NatM Register
905
906

    sub_code sz x (StInt y)
907
908
      = getRegister x		`thenNat` \ register ->
	getNewRegNCG IntRep	`thenNat` \ tmp ->
909
910
911
912
	let
	    code = registerCode register tmp
	    src1 = registerName register tmp
	    src2 = ImmInt (-(fromInteger y))
913
	    code__2 dst 
914
915
916
               = code `snocOL`
		 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
                        (OpReg dst)
917
	in
918
	returnNat (Any IntRep code__2)
919

920
    sub_code sz x y = trivialCode (SUB sz) Nothing x y
921
922
923


getRegister (StInd pk mem)
924
  = getAmode mem    	    	    `thenNat` \ amode ->
925
926
    let
    	code = amodeCode amode
927
    	src  = amodeAddr amode
928
    	size = primRepToSize pk
929
930
931
    	code__2 dst = code `snocOL`
		      if   pk == DoubleRep || pk == FloatRep
		      then GLD size src dst
932
933
934
935
936
937
938
939
		      else (case size of
                               B  -> MOVSxL B
                               Bu -> MOVZxL Bu
                               W  -> MOVSxL W
                               Wu -> MOVZxL Wu
                               L  -> MOV L
                               Lu -> MOV L)
                               (OpAddr src) (OpReg dst)
940
    in
941
    	returnNat (Any pk code__2)
942
943
944
945

getRegister (StInt i)
  = let
    	src = ImmInt (fromInteger i)
946
947
948
949
950
    	code dst 
           | i == 0
           = unitOL (XOR L (OpReg dst) (OpReg dst))
           | otherwise
           = unitOL (MOV L (OpImm src) (OpReg dst))
951
    in
952
    	returnNat (Any IntRep code)
953
954
955

getRegister leaf
  | maybeToBool imm
956
  = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
957
    in
958
    	returnNat (Any PtrRep code)
959
  | otherwise
960
  = pprPanic "getRegister(x86)" (pprStixTree leaf)
961
962
963
964
965
966
967
968
  where
    imm = maybeImm leaf
    imm__2 = case imm of Just x -> x

#endif {- i386_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if sparc_TARGET_ARCH

969
970
971
972
973
974
975
976
977
978
979
980
981
getRegister (StFloat d)
  = getNatLabelNCG 	    	    `thenNat` \ lbl ->
    getNewRegNCG PtrRep    	    `thenNat` \ tmp ->
    let code dst = toOL [
    	    SEGMENT DataSegment,
	    LABEL lbl,
	    DATA F [ImmFloat d],
	    SEGMENT TextSegment,
	    SETHI (HI (ImmCLbl lbl)) tmp,
	    LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
    in
    	returnNat (Any FloatRep code)

982
getRegister (StDouble d)
983
984
  = getNatLabelNCG 	    	    `thenNat` \ lbl ->
    getNewRegNCG PtrRep    	    `thenNat` \ tmp ->
985
    let code dst = toOL [
986
987
    	    SEGMENT DataSegment,
	    LABEL lbl,
988
	    DATA DF [ImmDouble d],
989
990
	    SEGMENT TextSegment,
	    SETHI (HI (ImmCLbl lbl)) tmp,
sof's avatar
sof committed
991
	    LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
992
    in
993
    	returnNat (Any DoubleRep code)
994

995
996
997
998
-- The 6-word scratch area is immediately below the frame pointer.
-- Below that is the spill area.
getRegister (StScratchWord i)
   | i >= 0 && i < 6
999
1000
   = let
         code dst = unitOL (fpRelEA (i-6) dst)