MachCode.lhs 107 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 )
22
import ForeignCall	( CCallConv(..) )
23
import CLabel		( CLabel, labelDynamic )
24
25
26
#if sparc_TARGET_ARCH || alpha_TARGET_ARCH
import CLabel 		( isAsmTemp )
#endif
27
import Maybes		( maybeToBool )
28
import PrimRep		( isFloatingRep, PrimRep(..) )
29
import PrimOp		( PrimOp(..) )
30
import Stix		( getNatLabelNCG, StixTree(..),
31
32
			  StixReg(..), CodeSegment(..), 
                          DestInfo, hasDestInfo,
33
                          pprStixTree, 
34
35
                          NatM, thenNat, returnNat, mapNat, 
                          mapAndUnzipNat, mapAccumLNat,
36
                          getDeltaNat, setDeltaNat
37
			)
38
import Outputable
39
import CmdLineOpts	( opt_Static )
40

41
42
infixr 3 `bind`

43
44
45
46
47
48
49
50
51
52
53
54
55
\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

56
57
58
59
60
\end{code}

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

\begin{code}
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
94
95
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.
96
97
98
99
100

   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?
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
135
136
-}

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]

137

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

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

148
    StLabel lab	   -> returnNat (unitOL (LABEL lab))
149

150
    StJump dsts arg	   -> genJump dsts (derefDLL arg)
151
152
153
154
155
    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)
156
157

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

    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)))
165
	,returnNat nilOL)
166
167

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

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


189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
-- 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
211
                StFloat  _             -> t
212
213
214
215
216
217
                StDouble _             -> t
                StString _             -> t
                StReg    _             -> t
                StScratchWord _        -> t
                _                      -> pprPanic "derefDLL: unhandled case" 
                                                   (pprStixTree t)
218
219
220
221
222
223
224
225
226
227
228
229
230
231
\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
232
    off = StInt (i * toInteger (sizeOf pk))
233
234

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

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

254
255
256
maybeImm (StCLbl l)       
   = Just (ImmCLbl l)
maybeImm (StIndex rep (StCLbl l) (StInt off)) 
257
   = Just (ImmIndex l (fromInteger off * sizeOf rep))
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
285
286
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

287
288
289
registerCodeF (Fixed _ _ code) = code
registerCodeF (Any _ _)        = pprPanic "registerCodeF" empty

290
291
292
registerCodeA (Any _ code)  = code
registerCodeA (Fixed _ _ _) = pprPanic "registerCodeA" empty

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

registerNameF (Fixed _ reg _) = reg
registerNameF (Any _ _)       = pprPanic "registerNameF" empty
299
300
301
302
303

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

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

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

316
isAny = not . isFixed
317
318
319
320
\end{code}

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

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

getRegister (StReg (StixTemp u pk))
329
  = returnNat (Fixed pk (mkVReg u pk) nilOL)
330
331
332

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

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

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

346
	code dst = toOL [
347
	    SEGMENT RoDataSegment,
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
	    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
363
    returnNat (Any PtrRep code)
364
365
366
367
368
369
370
371



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

#if alpha_TARGET_ARCH

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

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

404
      other_op -> getRegister (StCall fn CCallConv DoubleRep [x])
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
434
435
	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
436
      CharGtOp -> trivialCode (CMP LTT) y x
437
      CharGeOp -> trivialCode (CMP LE) y x
438
      CharEqOp -> trivialCode (CMP EQQ) x y
439
      CharNeOp -> int_NE_code x y
440
      CharLtOp -> trivialCode (CMP LTT) x y
441
442
      CharLeOp -> trivialCode (CMP LE) x y

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

      WordGtOp -> trivialCode (CMP ULT) y x
      WordGeOp -> trivialCode (CMP ULE) x y
452
      WordEqOp -> trivialCode (CMP EQQ)  x y
453
454
455
456
457
458
      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
459
      AddrEqOp -> trivialCode (CMP EQQ)  x y
460
461
462
      AddrNeOp -> int_NE_code x y
      AddrLtOp -> trivialCode (CMP ULT) x y
      AddrLeOp -> trivialCode (CMP ULE) x y
apt's avatar
apt committed
463
	
464
465
466
467
468
      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
469
470
      FloatLeOp -> cmpF_code (FCMP TF LE) NE x y

471
472
473
474
475
      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
476
477
478
479
480
481
482
483
      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

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

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

apt's avatar
apt committed
500
501
502
503
      AddrAddOp  -> trivialCode (ADD Q False) x y
      AddrSubOp  -> trivialCode (SUB Q False) x y
      AddrRemOp  -> trivialCode (REM Q True) x y

504
505
      AndOp  -> trivialCode AND x y
      OrOp   -> trivialCode OR  x y
506
      XorOp  -> trivialCode XOR x y
507
508
509
      SllOp  -> trivialCode SLL x y
      SrlOp  -> trivialCode SRL x y

sof's avatar
sof committed
510
      ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
sof's avatar
sof committed
511
      ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
sof's avatar
sof committed
512
      ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
513

514
515
      FloatPowerOp  -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
      DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
516
517
518
519
520
521
522
523
524
  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.
    -}
525
    int_NE_code :: StixTree -> StixTree -> NatM Register
526
527

    int_NE_code x y
528
529
      = trivialCode (CMP EQQ) x y	`thenNat` \ register ->
	getNewRegNCG IntRep		`thenNat` \ tmp ->
530
531
532
533
534
	let
	    code = registerCode register tmp
	    src  = registerName register tmp
	    code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
	in
535
	returnNat (Any IntRep code__2)
536
537
538
539
540
541
542
543

    {- ------------------------------------------------------------
	Comments for int_NE_code also apply to cmpF_code
    -}
    cmpF_code
	:: (Reg -> Reg -> Reg -> Instr)
	-> Cond
	-> StixTree -> StixTree
544
	-> NatM Register
545
546

    cmpF_code instr cond x y
547
548
549
      = trivialFCode pr instr x y	`thenNat` \ register ->
	getNewRegNCG DoubleRep		`thenNat` \ tmp ->
	getNatLabelNCG			`thenNat` \ lbl ->
550
551
552
553
554
	let
	    code = registerCode register tmp
	    result  = registerName register tmp

	    code__2 dst = code . mkSeqInstrs [
555
556
557
		OR zeroh (RIImm (ImmInt 1)) dst,
		BF cond  result (ImmCLbl lbl),
		OR zeroh (RIReg zeroh) dst,
558
559
		LABEL lbl]
	in
560
	returnNat (Any IntRep code__2)
561
562
563
564
565
      where
	pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
      ------------------------------------------------------------

getRegister (StInd pk mem)
566
  = getAmode mem    	    	    `thenNat` \ amode ->
567
568
569
570
571
572
    let
    	code = amodeCode amode
    	src   = amodeAddr amode
    	size = primRepToSize pk
    	code__2 dst = code . mkSeqInstr (LD size dst src)
    in
573
    returnNat (Any pk code__2)
574
575
576
577

getRegister (StInt i)
  | fits8Bits i
  = let
578
    	code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
579
    in
580
    returnNat (Any IntRep code)
581
582
583
584
  | otherwise
  = let
    	code dst = mkSeqInstr (LDI Q dst src)
    in
585
    returnNat (Any IntRep code)
586
587
588
589
590
591
592
593
  where
    src = ImmInt (fromInteger i)

getRegister leaf
  | maybeToBool imm
  = let
    	code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
    in
594
    returnNat (Any PtrRep code)
595
596
597
598
599
600
601
602
  where
    imm = maybeImm leaf
    imm__2 = case imm of Just x -> x

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

603
604
605
606
607
608
609
610
611
612
613
614
615
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)


616
getRegister (StDouble d)
617
618
619

  | d == 0.0
  = let code dst = unitOL (GLDZ dst)
620
    in  returnNat (Any DoubleRep code)
621
622
623

  | d == 1.0
  = let code dst = unitOL (GLD1 dst)
624
    in  returnNat (Any DoubleRep code)
625
626
627
628

  | otherwise
  = getNatLabelNCG 	    	    `thenNat` \ lbl ->
    let code dst = toOL [
629
630
    	    SEGMENT DataSegment,
	    LABEL lbl,
631
	    DATA DF [ImmDouble d],
632
	    SEGMENT TextSegment,
633
	    GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
634
635
	    ]
    in
636
    returnNat (Any DoubleRep code)
637

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

649
650
651
652
653
getRegister (StPrim primop [x]) -- unary PrimOps
  = case primop of
      IntNegOp  -> trivialUCode (NEGI L) x
      NotOp	-> trivialUCode (NOT L) x

654
655
656
657
658
      FloatNegOp  -> trivialUFCode FloatRep  (GNEG F) x
      DoubleNegOp -> trivialUFCode DoubleRep (GNEG DF) x

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

660
661
662
663
664
665
666
667
668
      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

669
670
      Double2FloatOp -> trivialUFCode FloatRep  GDTOF x
      Float2DoubleOp -> trivialUFCode DoubleRep GFTOD x
671
672
673
674
675
676
677
678
679
680

      OrdOp -> coerceIntCode IntRep x
      ChrOp -> chrCode x

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

      other_op ->
681
	getRegister (StCall fn CCallConv DoubleRep [x])
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
       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"))

707
708
              other
                 -> pprPanic "getRegister(x86,unary primop)" 
709
                             (pprStixTree (StPrim primop [x]))
710

711
712
getRegister (StPrim primop [x, y]) -- dyadic PrimOps
  = case primop of
713
      CharGtOp -> condIntReg GTT x y
714
      CharGeOp -> condIntReg GE x y
715
      CharEqOp -> condIntReg EQQ x y
716
      CharNeOp -> condIntReg NE x y
717
      CharLtOp -> condIntReg LTT x y
718
719
      CharLeOp -> condIntReg LE x y

720
      IntGtOp  -> condIntReg GTT x y
721
      IntGeOp  -> condIntReg GE x y
722
      IntEqOp  -> condIntReg EQQ x y
723
      IntNeOp  -> condIntReg NE x y
724
      IntLtOp  -> condIntReg LTT x y
725
726
727
728
      IntLeOp  -> condIntReg LE x y

      WordGtOp -> condIntReg GU  x y
      WordGeOp -> condIntReg GEU x y
729
      WordEqOp -> condIntReg EQQ  x y
730
731
732
733
734
735
      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
736
      AddrEqOp -> condIntReg EQQ  x y
737
738
739
740
      AddrNeOp -> condIntReg NE  x y
      AddrLtOp -> condIntReg LU  x y
      AddrLeOp -> condIntReg LEU x y

741
      FloatGtOp -> condFltReg GTT x y
742
      FloatGeOp -> condFltReg GE x y
743
      FloatEqOp -> condFltReg EQQ x y
744
      FloatNeOp -> condFltReg NE x y
745
      FloatLtOp -> condFltReg LTT x y
746
747
      FloatLeOp -> condFltReg LE x y

748
      DoubleGtOp -> condFltReg GTT x y
749
      DoubleGeOp -> condFltReg GE x y
750
      DoubleEqOp -> condFltReg EQQ x y
751
      DoubleNeOp -> condFltReg NE x y
752
      DoubleLtOp -> condFltReg LTT x y
753
754
      DoubleLeOp -> condFltReg LE x y

755
756
      IntAddOp  -> add_code L x y
      IntSubOp  -> sub_code L x y
757
758
      IntQuotOp -> trivialCode (IQUOT L) Nothing x y
      IntRemOp  -> trivialCode (IREM L) Nothing x y
759
      IntMulOp  -> let op = IMUL L in trivialCode op (Just op) x y
760

761
762
763
764
      WordAddOp  -> add_code L x y
      WordSubOp  -> sub_code L x y
      WordMulOp  -> let op = IMUL L in trivialCode op (Just op) x y

765
766
767
768
      FloatAddOp -> trivialFCode  FloatRep  GADD x y
      FloatSubOp -> trivialFCode  FloatRep  GSUB x y
      FloatMulOp -> trivialFCode  FloatRep  GMUL x y
      FloatDivOp -> trivialFCode  FloatRep  GDIV x y
769

770
771
772
773
      DoubleAddOp -> trivialFCode DoubleRep GADD x y
      DoubleSubOp -> trivialFCode DoubleRep GSUB x y
      DoubleMulOp -> trivialFCode DoubleRep GMUL x y
      DoubleDivOp -> trivialFCode DoubleRep GDIV x y
774

apt's avatar
apt committed
775
776
777
778
      AddrAddOp -> add_code L x y
      AddrSubOp -> sub_code L x y
      AddrRemOp -> trivialCode (IREM L) Nothing x y

779
780
781
      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
782

sof's avatar
sof committed
783
784
785
786
787
	{- 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.)
	-}
	   
788
789
      SllOp  -> shift_code (SHL L) x y {-False-}
      SrlOp  -> shift_code (SHR L) x y {-False-}
790
791
792
      ISllOp -> shift_code (SHL L) x y {-False-}
      ISraOp -> shift_code (SAR L) x y {-False-}
      ISrlOp -> shift_code (SHR L) x y {-False-}
793

794
      FloatPowerOp  -> getRegister (StCall SLIT("pow") CCallConv DoubleRep 
795
                                           [promote x, promote y])
796
		       where promote x = StPrim Float2DoubleOp [x]
797
      DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep 
798
                                           [x, y])
799
800
      other
         -> pprPanic "getRegister(x86,dyadic primop)" 
801
                     (pprStixTree (StPrim primop [x, y]))
802
  where
803
804

    --------------------
805
    shift_code :: (Imm -> Operand -> Instr)
sof's avatar
sof committed
806
807
	       -> StixTree
	       -> StixTree
808
	       -> NatM Register
809

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

      {- Case2: shift length is complex (non-immediate) -}
832
833
834
835
      -- 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.
836
      -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE, 
837
      -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
sof's avatar
sof committed
838
    shift_code instr x y{-amount-}
839
840
841
842
843
844
845
846
     = 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 ->
847
848
849
850
851
852
853
854
       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
855
856
857
858
859
                    code_amt `snocOL`
                    MOV L (OpReg src_amt) r_tmp `appOL`
                    code_val `snocOL`
                    MOV L (OpReg src_val) r_dst `appOL`
                    toOL [
860
861
862
863
864
865
                       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,
866
                       instr (ImmInt 16) r_dst,
867
868
869
870

                       LABEL lbl_test3,
                       BT L (ImmInt 3) r_tmp,
                       JXX GEU lbl_test2,
871
                       instr (ImmInt 8) r_dst,
872
873
874
875

                       LABEL lbl_test2,
                       BT L (ImmInt 2) r_tmp,
                       JXX GEU lbl_test1,
876
                       instr (ImmInt 4) r_dst,
877
878
879
880

                       LABEL lbl_test1,
                       BT L (ImmInt 1) r_tmp,
                       JXX GEU lbl_test0,
881
                       instr (ImmInt 2) r_dst,
882
883
884
885

                       LABEL lbl_test0,
                       BT L (ImmInt 0) r_tmp,
                       JXX GEU lbl_after,
886
                       instr (ImmInt 1) r_dst,
887
888
889
890
891
                       LABEL lbl_after,
                                           
                       COMMENT (_PK_ "end shift sequence")
                    ]
       in
892
       returnNat (Any IntRep code__2)
893

894
    --------------------
895
    add_code :: Size -> StixTree -> StixTree -> NatM Register
896
897

    add_code sz x (StInt y)
898
899
      = getRegister x		`thenNat` \ register ->
	getNewRegNCG IntRep	`thenNat` \ tmp ->
900
901
902
903
	let
	    code = registerCode register tmp
	    src1 = registerName register tmp
	    src2 = ImmInt (fromInteger y)
904
	    code__2 dst 
905
906
907
               = code `snocOL`
		 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
                        (OpReg dst)
908
	in
909
	returnNat (Any IntRep code__2)
910

911
    add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
912
913

    --------------------
914
    sub_code :: Size -> StixTree -> StixTree -> NatM Register
915
916

    sub_code sz x (StInt y)
917
918
      = getRegister x		`thenNat` \ register ->
	getNewRegNCG IntRep	`thenNat` \ tmp ->
919
920
921
922
	let
	    code = registerCode register tmp
	    src1 = registerName register tmp
	    src2 = ImmInt (-(fromInteger y))
923
	    code__2 dst 
924
925
926
               = code `snocOL`
		 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
                        (OpReg dst)
927
	in
928
	returnNat (Any IntRep code__2)
929

930
    sub_code sz x y = trivialCode (SUB sz) Nothing x y
931
932
933


getRegister (StInd pk mem)
934
  = getAmode mem    	    	    `thenNat` \ amode ->
935
936
    let
    	code = amodeCode amode
937
    	src  = amodeAddr amode
938
    	size = primRepToSize pk
939
940
941
    	code__2 dst = code `snocOL`
		      if   pk == DoubleRep || pk == FloatRep
		      then GLD size src dst
942
943
944
945
946
947
948
949
		      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)
950
    in
951
    	returnNat (Any pk code__2)
952
953
954
955

getRegister (StInt i)
  = let
    	src = ImmInt (fromInteger i)
956
957
958
959
960
    	code dst 
           | i == 0
           = unitOL (XOR L (OpReg dst) (OpReg dst))
           | otherwise
           = unitOL (MOV L (OpImm src) (OpReg dst))
961
    in
962
    	returnNat (Any IntRep code)
963
964
965

getRegister leaf
  | maybeToBool imm
966
  = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
967
    in
968
    	returnNat (Any PtrRep code)
969
  | otherwise
970
  = pprPanic "getRegister(x86)" (pprStixTree leaf)
971
972
973
974
975
976
977
978
  where
    imm = maybeImm leaf
    imm__2 = case imm of Just x -> x

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

979
980
981
982
983
984
985
986
987
988
989
990
991
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)

992
getRegister (StDouble d)
993
994
  = getNatLabelNCG 	    	    `thenNat` \ lbl ->
    getNewRegNCG PtrRep    	    `thenNat` \ tmp ->
995
    let code dst = toOL [
996
997
    	    SEGMENT DataSegment,
	    LABEL lbl,
998
	    DATA DF [ImmDouble d],
999
1000
	    SEGMENT TextSegment,
	    SETHI (HI (ImmCLbl lbl)) tmp,