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 )
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

      OrdOp -> coerceIntCode IntRep x
      ChrOp -> chrCode x

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

674
675
676
677
678
679
680
      IntToInt8Op    -> extendIntCode Int8Rep   IntRep  x
      IntToInt16Op   -> extendIntCode Int16Rep  IntRep  x
      IntToInt32Op   -> getRegister x
      WordToWord8Op  -> extendIntCode Word8Rep  WordRep x
      WordToWord16Op -> extendIntCode Word16Rep WordRep x
      WordToWord32Op -> getRegister x

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

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

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

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

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

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

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

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

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

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

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

776
777
778
      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
779

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

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

    --------------------
802
    shift_code :: (Imm -> Operand -> Instr)
sof's avatar
sof committed
803
804
	       -> StixTree
	       -> StixTree
805
	       -> NatM Register
806

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

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

                       LABEL lbl_test3,
                       BT L (ImmInt 3) r_tmp,
                       JXX GEU lbl_test2,
868
                       instr (ImmInt 8) r_dst,
869
870
871
872

                       LABEL lbl_test2,
                       BT L (ImmInt 2) r_tmp,
                       JXX GEU lbl_test1,
873
                       instr (ImmInt 4) r_dst,
874
875
876
877

                       LABEL lbl_test1,
                       BT L (ImmInt 1) r_tmp,
                       JXX GEU lbl_test0,
878
                       instr (ImmInt 2) r_dst,
879
880
881
882

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

891
    --------------------
892
    add_code :: Size -> StixTree -> StixTree -> NatM Register
893
894

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

908
    add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
909
910

    --------------------
911
    sub_code :: Size -> StixTree -> StixTree -> NatM Register
912
913

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

927
    sub_code sz x y = trivialCode (SUB sz) Nothing x y
928
929
930


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

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

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

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

976
977
978
979
980
981
982
983
984
985
986
987
988
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)

989
getRegister (StDouble d)
990
991
  = getNatLabelNCG 	    	    `thenNat` \ lbl ->
    getNewRegNCG PtrRep    	    `thenNat` \ tmp ->
992
    let code dst = toOL [
993
994
    	    SEGMENT DataSegment,
	    LABEL lbl,
995
	    DATA DF [ImmDouble d],
996
997
	    SEGMENT TextSegment,
	    SETHI (HI (ImmCLbl lbl)) tmp,
sof's avatar
sof committed
998
	    LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
999
    in
1000
    	returnNat (Any DoubleRep code)