MachCode.lhs 142 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
#include "HsVersions.h"
#include "nativeGen/NCG.h"

17
import Unique		( Unique )
18
19
import MachMisc		-- may differ per-platform
import MachRegs
20
21
import OrdList		( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
			  snocOL, consOL, concatOL )
22
import MachOp		( MachOp(..), pprMachOp )
23
import AbsCUtils	( magicIdPrimRep )
24
import PprAbsC		( pprMagicId )
25
import ForeignCall	( CCallConv(..) )
26
import CLabel		( CLabel, labelDynamic )
27
28
29
#if sparc_TARGET_ARCH || alpha_TARGET_ARCH
import CLabel 		( isAsmTemp )
#endif
30
import Maybes		( maybeToBool )
31
import PrimRep		( isFloatingRep, is64BitRep, PrimRep(..),
32
33
34
#if powerpc_TARGET_ARCH
			  getPrimRepSize,
#endif
35
			  getPrimRepSizeInBytes )
36
import Stix		( getNatLabelNCG, StixStmt(..), StixExpr(..),
37
			  StixReg(..), pprStixReg, StixVReg(..), CodeSegment(..), 
38
                          DestInfo, hasDestInfo,
39
                          pprStixExpr, repOfStixExpr,
40
                          liftStrings,
41
42
                          NatM, thenNat, returnNat, mapNat, 
                          mapAndUnzipNat, mapAccumLNat,
43
44
45
                          getDeltaNat, setDeltaNat, getUniqueNat,
                          ncgPrimopMoan,
			  ncg_target_is_32bit
46
			)
47
import Pretty
48
import Outputable	( panic, pprPanic, showSDoc )
49
import qualified Outputable
50
import CmdLineOpts	( opt_Static )
51
import Stix		( pprStixStmt )
52

53
-- DEBUGGING ONLY
54
import Outputable	( assertPanic )
55
import FastString
56
import TRACE		( trace )
57

58
infixr 3 `bind`
59
60
61
62
63
64
65
66
67
68
69
\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
70
71
72
73
74

isLeft (Left _)  = True
isLeft (Right _) = False

unLeft (Left x) = x
75
76
77
78
79
\end{code}

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

\begin{code}
80
stmtsToInstrs :: [StixStmt] -> NatM InstrBlock
81
stmtsToInstrs stmts
82
   = mapNat stmtToInstrs stmts		`thenNat` \ instrss ->
83
84
85
     returnNat (concatOL instrss)


86
stmtToInstrs :: StixStmt -> NatM InstrBlock
87
stmtToInstrs stmt = case stmt of
88
89
    StComment s    -> returnNat (unitOL (COMMENT s))
    StSegment seg  -> returnNat (unitOL (SEGMENT seg))
90

91
92
93
94
    StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
                                                       LABEL lab)))
    StFunEnd lab   -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
                                    returnNat nilOL)
95

96
    StLabel lab	   -> returnNat (unitOL (LABEL lab))
97

98
    StJump dsts arg	   -> genJump dsts (derefDLL arg)
99
100
    StCondJump lab arg	   -> genCondJump lab (derefDLL arg)

101
102
103
104
    -- A call returning void, ie one done for its side-effects.  Note
    -- that this is the only StVoidable we handle.
    StVoidable (StCall fn cconv VoidRep args) 
       -> genCCall fn cconv VoidRep (map derefDLL args)
105

106
107
    StAssignMem pk addr src
      | isFloatingRep pk -> assignMem_FltCode pk (derefDLL addr) (derefDLL src)
108
109
      | ncg_target_is_32bit
        && is64BitRep pk -> assignMem_I64Code    (derefDLL addr) (derefDLL src)
110
111
112
      | otherwise	 -> assignMem_IntCode pk (derefDLL addr) (derefDLL src)
    StAssignReg pk reg src
      | isFloatingRep pk -> assignReg_FltCode pk reg (derefDLL src)
113
114
      | ncg_target_is_32bit
        && is64BitRep pk -> assignReg_I64Code    reg (derefDLL src)
115
      | otherwise	 -> assignReg_IntCode pk reg (derefDLL src)
116
117
118
119
120

    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)))
121
	,returnNat nilOL)
122
123

    StData kind args
124
125
126
      -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
	 returnNat (DATA (primRepToSize kind) imms  
                    `consOL`  concatOL codes)
127
      where
128
	getData :: StixExpr -> NatM (InstrBlock, Imm)
129
130
	getData (StInt i)        = returnNat (nilOL, ImmInteger i)
	getData (StDouble d)     = returnNat (nilOL, ImmDouble d)
131
	getData (StFloat d)      = returnNat (nilOL, ImmFloat d)
132
	getData (StCLbl l)       = returnNat (nilOL, ImmCLbl l)
133
	getData (StString s)     = panic "MachCode.stmtToInstrs: unlifted StString"
134
135
	-- the linker can handle simple arithmetic...
	getData (StIndex rep (StCLbl lbl) (StInt off)) =
136
		returnNat (nilOL,
137
                           ImmIndex lbl (fromInteger off * getPrimRepSizeInBytes rep))
138

139
    -- Top-level lifted-out string.  The segment will already have been set
140
141
    -- (see Stix.liftStrings).
    StDataString str
142
      -> returnNat (unitOL (ASCII True (unpackFS str)))
143

144
#ifdef DEBUG
145
    other -> pprPanic "stmtToInstrs" (pprStixStmt other)
146
#endif
147

148
149
150
151
-- 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.
152
derefDLL :: StixExpr -> StixExpr
153
154
155
156
157
158
159
160
161
162
163
164
165
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)
166
                StMachOp mop args      -> StMachOp mop (map qq args)
167
                StInd pk addr          -> StInd pk (qq addr)
168
169
                StCall (Left nm) cc pk args -> StCall (Left nm) cc pk (map qq args)
                StCall (Right f) cc pk args -> StCall (Right (qq f)) cc pk (map qq args)
170
                StInt    _             -> t
171
                StFloat  _             -> t
172
173
174
175
                StDouble _             -> t
                StString _             -> t
                StReg    _             -> t
                _                      -> pprPanic "derefDLL: unhandled case" 
176
                                                   (pprStixExpr t)
177
178
179
180
181
182
183
184
185
\end{code}

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

\begin{code}
186
mangleIndexTree :: StixExpr -> StixExpr
187
188

mangleIndexTree (StIndex pk base (StInt i))
189
  = StMachOp MO_Nat_Add [base, off]
190
  where
191
    off = StInt (i * toInteger (getPrimRepSizeInBytes pk))
192
193

mangleIndexTree (StIndex pk base off)
194
  = StMachOp MO_Nat_Add [
195
196
       base,
       let s = shift pk
197
198
       in  if s == 0 then off 
                     else StMachOp MO_Nat_Shl [off, StInt (toInteger s)]
199
    ]
200
  where
201
    shift :: PrimRep -> Int
202
    shift rep = case getPrimRepSizeInBytes rep of
203
204
205
206
207
                   1 -> 0
                   2 -> 1
                   4 -> 2
                   8 -> 3
                   other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size" 
208
                                     (Outputable.int other)
209
210
211
\end{code}

\begin{code}
212
maybeImm :: StixExpr -> Maybe Imm
213

214
215
216
maybeImm (StCLbl l)       
   = Just (ImmCLbl l)
maybeImm (StIndex rep (StCLbl l) (StInt off)) 
217
   = Just (ImmIndex l (fromInteger off * getPrimRepSizeInBytes rep))
218
maybeImm (StInt i)
sof's avatar
sof committed
219
  | i >= toInteger (minBound::Int) && i <= toInteger (maxBound::Int)
220
221
222
223
224
225
226
  = Just (ImmInt (fromInteger i))
  | otherwise
  = Just (ImmInteger i)

maybeImm _ = Nothing
\end{code}

227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
%************************************************************************
%*									*
\subsection{The @Register64@ type}
%*									*
%************************************************************************

Simple support for generating 64-bit code (ie, 64 bit values and 64
bit assignments) on 32-bit platforms.  Unlike the main code generator
we merely shoot for generating working code as simply as possible, and
pay little attention to code quality.  Specifically, there is no
attempt to deal cleverly with the fixed-vs-floating register
distinction; all values are generated into (pairs of) floating
registers, even if this would mean some redundant reg-reg moves as a
result.  Only one of the VRegUniques is returned, since it will be
of the VRegUniqueLo form, and the upper-half VReg can be determined
by applying getHiVRegFromLo to it.

\begin{code}

data ChildCode64 	-- a.k.a "Register64"
   = ChildCode64 
        InstrBlock 	-- code
        VRegUnique 	-- unique for the lower 32-bit temporary
	-- which contains the result; use getHiVRegFromLo to find
	-- the other VRegUnique.
	-- Rules of this simplified insn selection game are
253
	-- therefore that the returned VRegUnique may be modified
254
255
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
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349

assignMem_I64Code :: StixExpr -> StixExpr -> NatM InstrBlock
assignReg_I64Code :: StixReg  -> StixExpr -> NatM InstrBlock
iselExpr64        :: StixExpr -> NatM ChildCode64

-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

#if i386_TARGET_ARCH

assignMem_I64Code addrTree valueTree
   = iselExpr64 valueTree		`thenNat` \ (ChildCode64 vcode vrlo) ->
     getRegister addrTree		`thenNat` \ register_addr ->
     getNewRegNCG IntRep		`thenNat` \ t_addr ->
     let rlo = VirtualRegI vrlo
         rhi = getHiVRegFromLo rlo
         code_addr = registerCode register_addr t_addr
         reg_addr  = registerName register_addr t_addr
         -- Little-endian store
         mov_lo = MOV L (OpReg rlo)
                        (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
         mov_hi = MOV L (OpReg rhi)
                        (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
     in
         returnNat (vcode `appOL` code_addr `snocOL` mov_lo `snocOL` mov_hi)

assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
   = iselExpr64 valueTree		`thenNat` \ (ChildCode64 vcode vr_src_lo) ->
     let 
         r_dst_lo = mkVReg u_dst IntRep
         r_src_lo = VirtualRegI vr_src_lo
         r_dst_hi = getHiVRegFromLo r_dst_lo
         r_src_hi = getHiVRegFromLo r_src_lo
         mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
         mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
     in
         returnNat (
            vcode `snocOL` mov_lo `snocOL` mov_hi
         )

assignReg_I64Code lvalue valueTree
   = pprPanic "assignReg_I64Code(i386): invalid lvalue"
              (pprStixReg lvalue)



iselExpr64 (StInd pk addrTree)
   | is64BitRep pk
   = getRegister addrTree		`thenNat` \ register_addr ->
     getNewRegNCG IntRep		`thenNat` \ t_addr ->
     getNewRegNCG IntRep		`thenNat` \ rlo ->
     let rhi = getHiVRegFromLo rlo
         code_addr = registerCode register_addr t_addr
         reg_addr  = registerName register_addr t_addr
         mov_lo = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
                        (OpReg rlo)
         mov_hi = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
                        (OpReg rhi)
     in
         returnNat (
            ChildCode64 (code_addr `snocOL` mov_lo `snocOL` mov_hi) 
                        (getVRegUnique rlo)
         )

iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
   | is64BitRep pk
   = getNewRegNCG IntRep 		`thenNat` \ r_dst_lo ->
     let r_dst_hi = getHiVRegFromLo r_dst_lo
         r_src_lo = mkVReg vu IntRep
         r_src_hi = getHiVRegFromLo r_src_lo
         mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
         mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
     in
         returnNat (
            ChildCode64 (toOL [mov_lo, mov_hi]) (getVRegUnique r_dst_lo)
         )
         
iselExpr64 (StCall fn cconv kind args)
  | is64BitRep kind
  = genCCall fn cconv kind args			`thenNat` \ call ->
    getNewRegNCG IntRep				`thenNat` \ r_dst_lo ->
    let r_dst_hi = getHiVRegFromLo r_dst_lo
        mov_lo = MOV L (OpReg eax) (OpReg r_dst_lo)
        mov_hi = MOV L (OpReg edx) (OpReg r_dst_hi)
    in
    returnNat (
       ChildCode64 (call `snocOL` mov_lo `snocOL` mov_hi) 
                   (getVRegUnique r_dst_lo)
    )

iselExpr64 expr
   = pprPanic "iselExpr64(i386)" (pprStixExpr expr)

#endif {- i386_TARGET_ARCH -}

-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
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
434
435
436
437
438
#if sparc_TARGET_ARCH

assignMem_I64Code addrTree valueTree
   = iselExpr64 valueTree		`thenNat` \ (ChildCode64 vcode vrlo) ->
     getRegister addrTree		`thenNat` \ register_addr ->
     getNewRegNCG IntRep		`thenNat` \ t_addr ->
     let rlo = VirtualRegI vrlo
         rhi = getHiVRegFromLo rlo
         code_addr = registerCode register_addr t_addr
         reg_addr  = registerName register_addr t_addr
         -- Big-endian store
         mov_hi = ST W rhi (AddrRegImm reg_addr (ImmInt 0))
         mov_lo = ST W rlo (AddrRegImm reg_addr (ImmInt 4))
     in
         returnNat (vcode `appOL` code_addr `snocOL` mov_hi `snocOL` mov_lo)


assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
   = iselExpr64 valueTree		`thenNat` \ (ChildCode64 vcode vr_src_lo) ->
     let 
         r_dst_lo = mkVReg u_dst IntRep
         r_src_lo = VirtualRegI vr_src_lo
         r_dst_hi = getHiVRegFromLo r_dst_lo
         r_src_hi = getHiVRegFromLo r_src_lo
         mov_lo = mkMOV r_src_lo r_dst_lo
         mov_hi = mkMOV r_src_hi r_dst_hi
         mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
     in
         returnNat (
            vcode `snocOL` mov_hi `snocOL` mov_lo
         )
assignReg_I64Code lvalue valueTree
   = pprPanic "assignReg_I64Code(sparc): invalid lvalue"
              (pprStixReg lvalue)


-- Don't delete this -- it's very handy for debugging.
--iselExpr64 expr 
--   | trace ("iselExpr64: " ++ showSDoc (pprStixExpr expr)) False
--   = panic "iselExpr64(???)"

iselExpr64 (StInd pk addrTree)
   | is64BitRep pk
   = getRegister addrTree		`thenNat` \ register_addr ->
     getNewRegNCG IntRep		`thenNat` \ t_addr ->
     getNewRegNCG IntRep		`thenNat` \ rlo ->
     let rhi = getHiVRegFromLo rlo
         code_addr = registerCode register_addr t_addr
         reg_addr  = registerName register_addr t_addr
         mov_hi = LD W (AddrRegImm reg_addr (ImmInt 0)) rhi
         mov_lo = LD W (AddrRegImm reg_addr (ImmInt 4)) rlo
     in
         returnNat (
            ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo) 
                        (getVRegUnique rlo)
         )

iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
   | is64BitRep pk
   = getNewRegNCG IntRep 		`thenNat` \ r_dst_lo ->
     let r_dst_hi = getHiVRegFromLo r_dst_lo
         r_src_lo = mkVReg vu IntRep
         r_src_hi = getHiVRegFromLo r_src_lo
         mov_lo = mkMOV r_src_lo r_dst_lo
         mov_hi = mkMOV r_src_hi r_dst_hi
         mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
     in
         returnNat (
            ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo)
         )

iselExpr64 (StCall fn cconv kind args)
  | is64BitRep kind
  = genCCall fn cconv kind args			`thenNat` \ call ->
    getNewRegNCG IntRep				`thenNat` \ r_dst_lo ->
    let r_dst_hi = getHiVRegFromLo r_dst_lo
        mov_lo = mkMOV o0 r_dst_lo
        mov_hi = mkMOV o1 r_dst_hi
        mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
    in
    returnNat (
       ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo) 
                   (getVRegUnique r_dst_lo)
    )

iselExpr64 expr
   = pprPanic "iselExpr64(sparc)" (pprStixExpr expr)

#endif {- sparc_TARGET_ARCH -}
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

#if powerpc_TARGET_ARCH

assignMem_I64Code addrTree valueTree
   = iselExpr64 valueTree		`thenNat` \ (ChildCode64 vcode vrlo) ->
     getRegister addrTree		`thenNat` \ register_addr ->
     getNewRegNCG IntRep		`thenNat` \ t_addr ->
     let rlo = VirtualRegI vrlo
         rhi = getHiVRegFromLo rlo
         code_addr = registerCode register_addr t_addr
         reg_addr  = registerName register_addr t_addr
         -- Big-endian store
         mov_hi = ST W rhi (AddrRegImm reg_addr (ImmInt 0))
         mov_lo = ST W rlo (AddrRegImm reg_addr (ImmInt 4))
     in
         returnNat (vcode `appOL` code_addr `snocOL` mov_hi `snocOL` mov_lo)


assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
   = iselExpr64 valueTree		`thenNat` \ (ChildCode64 vcode vr_src_lo) ->
     let 
         r_dst_lo = mkVReg u_dst IntRep
         r_src_lo = VirtualRegI vr_src_lo
         r_dst_hi = getHiVRegFromLo r_dst_lo
         r_src_hi = getHiVRegFromLo r_src_lo
         mov_lo = MR r_dst_lo r_src_lo
         mov_hi = MR r_dst_hi r_src_hi
     in
         returnNat (
            vcode `snocOL` mov_hi `snocOL` mov_lo
         )
assignReg_I64Code lvalue valueTree
   = pprPanic "assignReg_I64Code(powerpc): invalid lvalue"
              (pprStixReg lvalue)


-- Don't delete this -- it's very handy for debugging.
--iselExpr64 expr 
--   | trace ("iselExpr64: " ++ showSDoc (pprStixExpr expr)) False
--   = panic "iselExpr64(???)"

iselExpr64 (StInd pk addrTree)
   | is64BitRep pk
   = getRegister addrTree		`thenNat` \ register_addr ->
     getNewRegNCG IntRep		`thenNat` \ t_addr ->
     getNewRegNCG IntRep		`thenNat` \ rlo ->
     let rhi = getHiVRegFromLo rlo
         code_addr = registerCode register_addr t_addr
         reg_addr  = registerName register_addr t_addr
         mov_hi = LD W rhi (AddrRegImm reg_addr (ImmInt 0))
         mov_lo = LD W rlo (AddrRegImm reg_addr (ImmInt 4))
     in
         returnNat (
            ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo) 
                        (getVRegUnique rlo)
         )

iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
   | is64BitRep pk
   = getNewRegNCG IntRep 		`thenNat` \ r_dst_lo ->
     let r_dst_hi = getHiVRegFromLo r_dst_lo
         r_src_lo = mkVReg vu IntRep
         r_src_hi = getHiVRegFromLo r_src_lo
         mov_lo = MR r_dst_lo r_src_lo
         mov_hi = MR r_dst_hi r_src_hi
     in
         returnNat (
            ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo)
         )

iselExpr64 (StCall fn cconv kind args)
  | is64BitRep kind
  = genCCall fn cconv kind args			`thenNat` \ call ->
    getNewRegNCG IntRep				`thenNat` \ r_dst_lo ->
    let r_dst_hi = getHiVRegFromLo r_dst_lo
        mov_lo = MR r_dst_lo r3
        mov_hi = MR r_dst_hi r4
    in
    returnNat (
       ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo) 
                   (getVRegUnique r_dst_lo)
    )

iselExpr64 expr
   = pprPanic "iselExpr64(powerpc)" (pprStixExpr expr)

#endif {- powerpc_TARGET_ARCH -}
527
528

-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
529
530
531

\end{code}

532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
%************************************************************************
%*									*
\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

552
registerCodeF (Fixed _ _ code) = code
553
registerCodeF (Any _ _)        = panic "registerCodeF"
554

555
registerCodeA (Any _ code)  = code
556
registerCodeA (Fixed _ _ _) = panic "registerCodeA"
557

558
559
registerName :: Register -> Reg -> Reg
registerName (Fixed _ reg _) _ = reg
560
561
562
registerName (Any _ _)   reg   = reg

registerNameF (Fixed _ reg _) = reg
563
registerNameF (Any _ _)       = panic "registerNameF"
564
565
566
567
568

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

569
570
571
572
swizzleRegisterRep :: Register -> PrimRep -> Register
swizzleRegisterRep (Fixed _ reg code) rep = Fixed rep reg code
swizzleRegisterRep (Any _ codefn)     rep = Any rep codefn

573
574
575
576
577
578
579
580
581
{-# INLINE registerCode  #-}
{-# INLINE registerCodeF #-}
{-# INLINE registerName  #-}
{-# INLINE registerNameF #-}
{-# INLINE registerRep   #-}
{-# INLINE isFixed       #-}
{-# INLINE isAny         #-}

isFixed, isAny :: Register -> Bool
582
583
isFixed (Fixed _ _ _) = True
isFixed (Any _ _)     = False
584

585
isAny = not . isFixed
586
587
588
589
590
\end{code}

Generate code to get a subtree into a @Register@:
\begin{code}

591
getRegisterReg :: StixReg -> NatM Register
592
593
getRegister :: StixExpr -> NatM Register

594

595
596
597
598
599
600
601
602
603
604
605
getRegisterReg (StixMagicId mid)
  = case get_MagicId_reg_or_addr mid of
       Left (RealReg rrno) 
          -> let pk = magicIdPrimRep mid
             in  returnNat (Fixed pk (RealReg rrno) nilOL)
       Right baseRegAddr 
          -- By this stage, the only MagicIds remaining should be the
          -- ones which map to a real machine register on this platform.  Hence ...
          -> pprPanic "getRegisterReg-memory" (pprMagicId mid)

getRegisterReg (StixTemp (StixVReg u pk))
606
  = returnNat (Fixed pk (mkVReg u pk) nilOL)
607

608
609
-------------

610
611
612
613
-- Don't delete this -- it's very handy for debugging.
--getRegister expr 
--   | trace ("getRegiste: " ++ showSDoc (pprStixExpr expr)) False
--   = panic "getRegister(???)"
614
615
616
617
618
619

getRegister (StReg reg) 
  = getRegisterReg reg

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

sof's avatar
sof committed
621
getRegister (StCall fn cconv kind args)
622
  | not (ncg_target_is_32bit && is64BitRep kind)
623
624
  = genCCall fn cconv kind args   	    `thenNat` \ call ->
    returnNat (Fixed kind reg call)
625
626
  where
    reg = if isFloatingRep kind
627
628
	  then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0, IF_ARCH_powerpc( f1,))))
	  else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0, IF_ARCH_powerpc( r3,))))
629
630

getRegister (StString s)
631
  = getNatLabelNCG 	    	    `thenNat` \ lbl ->
632
633
634
    let
	imm_lbl = ImmCLbl lbl

635
	code dst = toOL [
636
	    SEGMENT RoDataSegment,
637
	    LABEL lbl,
638
	    ASCII True (unpackFS s),
639
640
641
642
643
644
645
646
647
648
	    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
649
650
651
652
#endif
#if powerpc_TARGET_ARCH
	    LIS dst (HI imm_lbl),
	    OR dst dst (RIImm (LO imm_lbl))
653
654
655
#endif
	    ]
    in
656
    returnNat (Any PtrRep code)
657

658
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
659
660
661
662
663
-- end of machine-"independent" bit; here we go on the rest...

#if alpha_TARGET_ARCH

getRegister (StDouble d)
664
665
  = getNatLabelNCG 	    	    `thenNat` \ lbl ->
    getNewRegNCG PtrRep    	    `thenNat` \ tmp ->
666
667
668
    let code dst = mkSeqInstrs [
    	    SEGMENT DataSegment,
	    LABEL lbl,
sof's avatar
sof committed
669
	    DATA TF [ImmLab (rational d)],
670
671
672
673
	    SEGMENT TextSegment,
	    LDA tmp (AddrImm (ImmCLbl lbl)),
	    LD TF dst (AddrReg tmp)]
    in
674
    	returnNat (Any DoubleRep code)
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695

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

696
      other_op -> getRegister (StCall fn CCallConv DoubleRep [x])
697
698
	where
	  fn = case other_op of
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
		 FloatExpOp    -> FSLIT("exp")
		 FloatLogOp    -> FSLIT("log")
		 FloatSqrtOp   -> FSLIT("sqrt")
		 FloatSinOp    -> FSLIT("sin")
		 FloatCosOp    -> FSLIT("cos")
		 FloatTanOp    -> FSLIT("tan")
		 FloatAsinOp   -> FSLIT("asin")
		 FloatAcosOp   -> FSLIT("acos")
		 FloatAtanOp   -> FSLIT("atan")
		 FloatSinhOp   -> FSLIT("sinh")
		 FloatCoshOp   -> FSLIT("cosh")
		 FloatTanhOp   -> FSLIT("tanh")
		 DoubleExpOp   -> FSLIT("exp")
		 DoubleLogOp   -> FSLIT("log")
		 DoubleSqrtOp  -> FSLIT("sqrt")
		 DoubleSinOp   -> FSLIT("sin")
		 DoubleCosOp   -> FSLIT("cos")
		 DoubleTanOp   -> FSLIT("tan")
		 DoubleAsinOp  -> FSLIT("asin")
		 DoubleAcosOp  -> FSLIT("acos")
		 DoubleAtanOp  -> FSLIT("atan")
		 DoubleSinhOp  -> FSLIT("sinh")
		 DoubleCoshOp  -> FSLIT("cosh")
		 DoubleTanhOp  -> FSLIT("tanh")
723
724
725
726
727
  where
    pr = panic "MachCode.getRegister: no primrep needed for Alpha"

getRegister (StPrim primop [x, y]) -- dyadic PrimOps
  = case primop of
728
      CharGtOp -> trivialCode (CMP LTT) y x
729
      CharGeOp -> trivialCode (CMP LE) y x
730
      CharEqOp -> trivialCode (CMP EQQ) x y
731
      CharNeOp -> int_NE_code x y
732
      CharLtOp -> trivialCode (CMP LTT) x y
733
734
      CharLeOp -> trivialCode (CMP LE) x y

735
      IntGtOp  -> trivialCode (CMP LTT) y x
736
      IntGeOp  -> trivialCode (CMP LE) y x
737
      IntEqOp  -> trivialCode (CMP EQQ) x y
738
      IntNeOp  -> int_NE_code x y
739
      IntLtOp  -> trivialCode (CMP LTT) x y
740
741
742
743
      IntLeOp  -> trivialCode (CMP LE) x y

      WordGtOp -> trivialCode (CMP ULT) y x
      WordGeOp -> trivialCode (CMP ULE) x y
744
      WordEqOp -> trivialCode (CMP EQQ)  x y
745
746
747
748
749
750
      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
751
      AddrEqOp -> trivialCode (CMP EQQ)  x y
752
753
754
      AddrNeOp -> int_NE_code x y
      AddrLtOp -> trivialCode (CMP ULT) x y
      AddrLeOp -> trivialCode (CMP ULE) x y
apt's avatar
apt committed
755
	
756
757
758
759
760
      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
761
762
      FloatLeOp -> cmpF_code (FCMP TF LE) NE x y

763
764
765
766
767
      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
768
769
770
771
772
773
774
775
      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

776
777
778
      WordAddOp  -> trivialCode (ADD Q False) x y
      WordSubOp  -> trivialCode (SUB Q False) x y
      WordMulOp  -> trivialCode (MUL Q False) x y
779
780
781
      WordQuotOp -> trivialCode (DIV Q True) x y
      WordRemOp  -> trivialCode (REM Q True) x y

782
783
784
785
786
787
788
789
790
791
      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
792
793
794
795
      AddrAddOp  -> trivialCode (ADD Q False) x y
      AddrSubOp  -> trivialCode (SUB Q False) x y
      AddrRemOp  -> trivialCode (REM Q True) x y

796
797
      AndOp  -> trivialCode AND x y
      OrOp   -> trivialCode OR  x y
798
      XorOp  -> trivialCode XOR x y
799
800
801
      SllOp  -> trivialCode SLL x y
      SrlOp  -> trivialCode SRL x y

sof's avatar
sof committed
802
      ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
sof's avatar
sof committed
803
      ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
sof's avatar
sof committed
804
      ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
805

806
807
      FloatPowerOp  -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y])
      DoublePowerOp -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y])
808
809
810
811
812
813
814
815
816
  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.
    -}
817
    int_NE_code :: StixTree -> StixTree -> NatM Register
818
819

    int_NE_code x y
820
821
      = trivialCode (CMP EQQ) x y	`thenNat` \ register ->
	getNewRegNCG IntRep		`thenNat` \ tmp ->
822
823
824
825
826
	let
	    code = registerCode register tmp
	    src  = registerName register tmp
	    code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
	in
827
	returnNat (Any IntRep code__2)
828
829
830
831
832
833
834
835

    {- ------------------------------------------------------------
	Comments for int_NE_code also apply to cmpF_code
    -}
    cmpF_code
	:: (Reg -> Reg -> Reg -> Instr)
	-> Cond
	-> StixTree -> StixTree
836
	-> NatM Register
837
838

    cmpF_code instr cond x y
839
840
841
      = trivialFCode pr instr x y	`thenNat` \ register ->
	getNewRegNCG DoubleRep		`thenNat` \ tmp ->
	getNatLabelNCG			`thenNat` \ lbl ->
842
843
844
845
846
	let
	    code = registerCode register tmp
	    result  = registerName register tmp

	    code__2 dst = code . mkSeqInstrs [
847
848
849
		OR zeroh (RIImm (ImmInt 1)) dst,
		BF cond  result (ImmCLbl lbl),
		OR zeroh (RIReg zeroh) dst,
850
851
		LABEL lbl]
	in
852
	returnNat (Any IntRep code__2)
853
854
855
856
857
      where
	pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
      ------------------------------------------------------------

getRegister (StInd pk mem)
858
  = getAmode mem    	    	    `thenNat` \ amode ->
859
860
861
862
863
864
    let
    	code = amodeCode amode
    	src   = amodeAddr amode
    	size = primRepToSize pk
    	code__2 dst = code . mkSeqInstr (LD size dst src)
    in
865
    returnNat (Any pk code__2)
866
867
868
869

getRegister (StInt i)
  | fits8Bits i
  = let
870
    	code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
871
    in
872
    returnNat (Any IntRep code)
873
874
875
876
  | otherwise
  = let
    	code dst = mkSeqInstr (LDI Q dst src)
    in
877
    returnNat (Any IntRep code)
878
879
880
881
882
883
884
885
  where
    src = ImmInt (fromInteger i)

getRegister leaf
  | maybeToBool imm
  = let
    	code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
    in
886
    returnNat (Any PtrRep code)
887
888
889
890
891
  where
    imm = maybeImm leaf
    imm__2 = case imm of Just x -> x

#endif {- alpha_TARGET_ARCH -}
892

893
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
894

895
896
#if i386_TARGET_ARCH

897
898
899
900
901
902
903
904
905
906
907
908
909
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)


910
getRegister (StDouble d)
911
912
913

  | d == 0.0
  = let code dst = unitOL (GLDZ dst)
914
    in  returnNat (Any DoubleRep code)
915
916
917

  | d == 1.0
  = let code dst = unitOL (GLD1 dst)
918
    in  returnNat (Any DoubleRep code)
919
920
921
922

  | otherwise
  = getNatLabelNCG 	    	    `thenNat` \ lbl ->
    let code dst = toOL [
923
924
    	    SEGMENT DataSegment,
	    LABEL lbl,
925
	    DATA DF [ImmDouble d],
926
	    SEGMENT TextSegment,
927
	    GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
928
929
	    ]
    in
930
    returnNat (Any DoubleRep code)
931

932

933
934
935
936
getRegister (StMachOp mop [x]) -- unary MachOps
  = case mop of
      MO_NatS_Neg  -> trivialUCode (NEGI L) x
      MO_Nat_Not   -> trivialUCode (NOT L) x
937
      MO_32U_to_8U -> trivialUCode (AND L (OpImm (ImmInt 255))) x
938

939
940
      MO_Flt_Neg  -> trivialUFCode FloatRep  (GNEG F) x
      MO_Dbl_Neg  -> trivialUFCode DoubleRep (GNEG DF) x
941

942
943
      MO_Flt_Sqrt -> trivialUFCode FloatRep  (GSQRT F) x
      MO_Dbl_Sqrt -> trivialUFCode DoubleRep (GSQRT DF) x
944

945
946
      MO_Flt_Sin  -> trivialUFCode FloatRep  (GSIN F) x
      MO_Dbl_Sin  -> trivialUFCode DoubleRep (GSIN DF) x
947

948
949
      MO_Flt_Cos  -> trivialUFCode FloatRep  (GCOS F) x
      MO_Dbl_Cos  -> trivialUFCode DoubleRep (GCOS DF) x
950

951
952
      MO_Flt_Tan  -> trivialUFCode FloatRep  (GTAN F) x
      MO_Dbl_Tan  -> trivialUFCode DoubleRep (GTAN DF) x
953

954
      MO_Flt_to_NatS -> coerceFP2Int FloatRep x
955
      MO_NatS_to_Flt -> coerceInt2FP FloatRep x
956
      MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
957
      MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
958

959
960
      -- Conversions which are a nop on x86
      MO_32U_to_NatS  -> conversionNop IntRep    x
961
962
      MO_32S_to_NatS  -> conversionNop IntRep    x
      MO_NatS_to_32U  -> conversionNop WordRep   x
963
      MO_32U_to_NatU  -> conversionNop WordRep   x
964

965
966
967
968
969
970
      MO_NatU_to_NatS -> conversionNop IntRep    x
      MO_NatS_to_NatU -> conversionNop WordRep   x
      MO_NatP_to_NatU -> conversionNop WordRep   x
      MO_NatU_to_NatP -> conversionNop PtrRep    x
      MO_NatS_to_NatP -> conversionNop PtrRep    x
      MO_NatP_to_NatS -> conversionNop IntRep    x
971

972
973
      MO_Dbl_to_Flt   -> conversionNop FloatRep  x
      MO_Flt_to_Dbl   -> conversionNop DoubleRep x
974

975
      -- sign-extending widenings
976
977
978
979
      MO_8U_to_NatU   -> integerExtend False 24 x
      MO_8S_to_NatS   -> integerExtend True  24 x
      MO_16U_to_NatU  -> integerExtend False 16 x
      MO_16S_to_NatS  -> integerExtend True  16 x
980
      MO_8U_to_32U    -> integerExtend False 24 x
981

982
983
984
      other_op 
         -> getRegister (
               (if is_float_op then demote else id)
985
986
               (StCall (Left fn) CCallConv DoubleRep 
                       [(if is_float_op then promote else id) x])
987
988
989
990
991
            )
      where
        integerExtend signed nBits x
           = getRegister (
                StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr) 
992
                         [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
993
994
995
996
997
998
999
1000
1001
1002
             )

        conversionNop new_rep expr
            = getRegister expr		`thenNat` \ e_code ->
              returnNat (swizzleRegisterRep e_code new_rep)

        promote x = StMachOp MO_Flt_to_Dbl [x]
        demote  x = StMachOp MO_Dbl_to_Flt [x]
	(is_float_op, fn)
	  = case mop of
1003
1004
	      MO_Flt_Exp   -> (True,  FSLIT("exp"))
	      MO_Flt_Log   -> (True,  FSLIT("log"))
1005

1006
1007
1008
	      MO_Flt_Asin  -> (True,  FSLIT("asin"))
	      MO_Flt_Acos  -> (True,  FSLIT("acos"))
	      MO_Flt_Atan  -> (True,  FSLIT("atan"))
1009

1010
1011
1012
	      MO_Flt_Sinh  -> (True,  FSLIT("sinh"))
	      MO_Flt_Cosh  -> (True,  FSLIT("cosh"))
	      MO_Flt_Tanh  -> (True,  FSLIT("tanh"))
1013

1014
1015
	      MO_Dbl_Exp   -> (False, FSLIT("exp"))
	      MO_Dbl_Log   -> (False, FSLIT("log"))
1016

1017
1018
1019
	      MO_Dbl_Asin  -> (False, FSLIT("asin"))
	      MO_Dbl_Acos  -> (False, FSLIT("acos"))
	      MO_Dbl_Atan  -> (False, FSLIT("atan"))
1020

1021
1022
1023
	      MO_Dbl_Sinh  -> (False, FSLIT("sinh"))
	      MO_Dbl_Cosh  -> (False, FSLIT("cosh"))
	      MO_Dbl_Tanh  -> (False, FSLIT("tanh"))
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072

              other -> pprPanic "getRegister(x86) - binary StMachOp (2)" 
                                (pprMachOp mop)


getRegister (StMachOp mop [x, y]) -- dyadic MachOps
  = case mop of
      MO_32U_Gt  -> condIntReg GTT x y
      MO_32U_Ge  -> condIntReg GE x y
      MO_32U_Eq  -> condIntReg EQQ x y
      MO_32U_Ne  -> condIntReg NE x y
      MO_32U_Lt  -> condIntReg LTT x y
      MO_32U_Le  -> condIntReg LE x y

      MO_Nat_Eq   -> condIntReg EQQ x y
      MO_Nat_Ne   -> condIntReg NE x y

      MO_NatS_Gt  -> condIntReg GTT x y
      MO_NatS_Ge  -> condIntReg GE x y
      MO_NatS_Lt  -> condIntReg LTT x y
      MO_NatS_Le  -> condIntReg LE x y

      MO_NatU_Gt  -> condIntReg GU  x y
      MO_NatU_Ge  -> condIntReg GEU x y
      MO_NatU_Lt  -> condIntReg LU  x y
      MO_NatU_Le  -> condIntReg LEU x y

      MO_Flt_Gt -> condFltReg GTT x y
      MO_Flt_Ge -> condFltReg GE x y
      MO_Flt_Eq -> condFltReg EQQ x y
      MO_Flt_Ne -> condFltReg NE x y
      MO_Flt_Lt -> condFltReg LTT x y
      MO_Flt_Le -> condFltReg LE x y

      MO_Dbl_Gt -> condFltReg GTT x y
      MO_Dbl_Ge -> condFltReg GE x y
      MO_Dbl_Eq -> condFltReg EQQ x y
      MO_Dbl_Ne -> condFltReg NE x y
      MO_Dbl_Lt -> condFltReg LTT x y
      MO_Dbl_Le -> condFltReg LE x y

      MO_Nat_Add   -> add_code L x y
      MO_Nat_Sub   -> sub_code L x y
      MO_NatS_Quot -> trivialCode (IQUOT L) Nothing x y
      MO_NatS_Rem  -> trivialCode (IREM L) Nothing x y
      MO_NatU_Quot -> trivialCode (QUOT L) Nothing x y
      MO_NatU_Rem  -> trivialCode (REM L) Nothing x y
      MO_NatS_Mul  -> let op = IMUL L in trivialCode op (Just op) x y
      MO_NatU_Mul  -> let op = MUL L in trivialCode op (Just op) x y
1073
      MO_NatS_MulMayOflo -> imulMayOflo x y
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087

      MO_Flt_Add -> trivialFCode  FloatRep  GADD x y
      MO_Flt_Sub -> trivialFCode  FloatRep  GSUB x y
      MO_Flt_Mul -> trivialFCode  FloatRep  GMUL x y
      MO_Flt_Div -> trivialFCode  FloatRep  GDIV x y

      MO_Dbl_Add -> trivialFCode DoubleRep GADD x y
      MO_Dbl_Sub -> trivialFCode DoubleRep GSUB x y
      MO_Dbl_Mul -> trivialFCode DoubleRep GMUL x y
      MO_Dbl_Div -> trivialFCode DoubleRep GDIV x y

      MO_Nat_And -> let op = AND L in trivialCode op (Just op) x y
      MO_Nat_Or  -> let op = OR  L in trivialCode op (Just op) x y
      MO_Nat_Xor -> let op = XOR L in trivialCode op (Just op) x y
1088

sof's avatar
sof committed
1089
1090
1091
	{- 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.)
1092
1093
1094
1095
	-}	   
      MO_Nat_Shl  -> shift_code (SHL L) x y {-False-}
      MO_Nat_Shr  -> shift_code (SHR L) x y {-False-}
      MO_Nat_Sar  -> shift_code (SAR L) x y {-False-}
1096

1097
      MO_Flt_Pwr  -> getRegister (demote 
1098
                                 (StCall (Left FSLIT("pow")) CCallConv DoubleRep 
1099
                                         [promote x, promote y])
1100
                                 )
1101
      MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep 
1102
                                        [x, y])
1103
      other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop)
1104
  where
1105
1106
    promote x = StMachOp MO_Flt_to_Dbl [x]
    demote x  = StMachOp MO_Dbl_to_Flt [x]
1107

1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
    --------------------
    imulMayOflo :: StixExpr -> StixExpr -> NatM Register
    imulMayOflo a1 a2
       = getNewRegNCG IntRep		`thenNat` \ t1 ->
         getNewRegNCG IntRep		`thenNat` \ t2 ->
         getNewRegNCG IntRep		`thenNat` \ res_lo ->
         getNewRegNCG IntRep		`thenNat` \ res_hi ->
         getRegister a1			`thenNat` \ reg1 ->
         getRegister a2 		`thenNat` \ reg2 ->
         let code1 = registerCode reg1 t1
             code2 = registerCode reg2 t2
             src1  = registerName reg1 t1
             src2  = registerName reg2 t2
1121
1122
             code dst = code1 `appOL` code2 `appOL`
                        toOL [
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
                           MOV L (OpReg src1) (OpReg res_hi),
                           MOV L (OpReg src2) (OpReg res_lo),
                           IMUL64 res_hi res_lo, 		-- result in res_hi:res_lo
                           SAR L (ImmInt 31) (OpReg res_lo),	-- sign extend lower part
                           SUB L (OpReg res_hi) (OpReg res_lo),	-- compare against upper
                           MOV L (OpReg res_lo) (OpReg dst)
                           -- dst==0 if high part == sign extended low part
                        ]
         in
            returnNat (Any IntRep code)

1134
    --------------------
1135
    shift_code :: (Imm -> Operand -> Instr)
1136
1137
	       -> StixExpr
	       -> StixExpr
1138
	       -> NatM Register
1139

sof's avatar
sof committed
1140
1141
1142
1143
      {- Case1: shift length as immediate -}
      -- Code is the same as the first eq. for trivialCode -- sigh.
    shift_code instr x y{-amount-}
      | maybeToBool imm
1144
      = getRegister x	                   `thenNat` \ regx ->
1145
        let mkcode dst
1146
1147
1148
1149
              = if   isAny regx
                then registerCodeA regx dst  `bind` \ code_x ->
                     code_x `snocOL`
                     instr imm__2 (OpReg dst)
1150
1151
                else registerCodeF regx      `bind` \ code_x ->
                     registerNameF regx      `bind` \ r_x ->
1152
1153
1154
                     code_x `snocOL`
                     MOV L (OpReg r_x) (OpReg dst) `snocOL`
                     instr imm__2 (OpReg dst)
1155
        in
1156
        returnNat (Any IntRep mkcode)        
sof's avatar
sof committed
1157
1158
1159
1160
1161
      where
       imm = maybeImm y
       imm__2 = case imm of Just x -> x

      {- Case2: shift length is complex (non-immediate) -}
1162
1163
1164
1165
      -- 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.
1166
      -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE, 
1167
      -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
sof's avatar
sof committed
1168
    shift_code instr x y{-amount-}
1169
1170
1171
1172
1173
1174
1175
1176
     = 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 ->
1177
1178
1179
1180
1181
1182
1183
1184
       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
1185
1186
1187
1188
1189
                    code_amt `snocOL`
                    MOV L (OpReg src_amt) r_tmp `appOL`
                    code_val `snocOL`
                    MOV L (OpReg src_val) r_dst `appOL`
                    toOL [
1190
                       COMMENT (mkFastString "begin shift sequence"),
1191
1192
1193
1194
1195
                       MOV L (OpReg src_val) r_dst,
                       MOV L (OpReg src_amt) r_tmp,

                       BT L (ImmInt 4) r_tmp,
                       JXX GEU lbl_test3,
1196
                       instr (ImmInt 16) r_dst,
1197
1198
1199
1200

                       LABEL lbl_test3,
                       BT L (ImmInt 3) r_tmp,
                       JXX GEU lbl_test2,
1201
                       instr (ImmInt 8) r_dst,
1202
1203
1204
1205

                       LABEL lbl_test2,
                       BT L (ImmInt 2) r_tmp,
                       JXX GEU lbl_test1,
1206
                       instr (ImmInt 4) r_dst,
1207
1208
1209
1210

                       LABEL lbl_test1,
                       BT L (ImmInt 1) r_tmp,
                       JXX GEU lbl_test0,
1211
                       instr (ImmInt 2) r_dst,
1212
1213
1214
1215

                       LABEL lbl_test0,
                       BT L (ImmInt 0) r_tmp,
                       JXX GEU lbl_after,
1216
                       instr (ImmInt 1) r_dst,
1217
1218
                       LABEL lbl_after,
                                           
1219
                       COMMENT (mkFastString "end shift sequence")
1220
1221
                    ]
       in
1222
       returnNat (Any IntRep code__2)
1223

1224
    --------------------
1225
    add_code :: Size -> StixExpr -> StixExpr -> NatM Register
1226
1227

    add_code sz x (StInt y)
1228
1229
      = getRegister x		`thenNat` \ register ->
	getNewRegNCG IntRep	`thenNat` \ tmp ->
1230
1231
1232
1233
	let
	    code = registerCode register tmp
	    src1 = registerName register tmp
	    src2 = ImmInt (fromInteger y)
1234
	    code__2 dst 
1235
1236
1237
               = code `snocOL`
		 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
                        (OpReg dst)
1238
	in
1239
	returnNat (Any IntRep code__2)
1240

1241
    add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
1242
1243

    --------------------
1244
    sub_code :: Size -> StixExpr -> StixExpr -> NatM Register
1245
1246

    sub_code sz x (StInt y)
1247
1248
      = getRegister x		`thenNat` \ register ->
	getNewRegNCG IntRep	`thenNat` \ tmp ->
1249
1250
1251
1252
	let
	    code = registerCode register tmp
	    src1 = registerName register tmp
	    src2 = ImmInt (-(fromInteger y))
1253
	    code__2 dst 
1254
1255
1256
               = code `snocOL`
		 LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
                        (OpReg dst)
1257
	in
1258
	returnNat (Any IntRep code__2)
1259

1260
    sub_code sz x y = trivialCode (SUB sz) Nothing x y
1261
1262

getRegister (StInd pk mem)
1263
  | not (is64BitRep pk)
1264
  = getAmode mem    	    	    `thenNat` \ amode ->
1265
1266
    let
    	code = amodeCode amode
1267
    	src  = amodeAddr amode
1268
    	size = primRepToSize pk
1269
1270
1271
    	code__2 dst = code `snocOL`
		      if   pk == DoubleRep || pk == FloatRep
		      then GLD size src dst
1272
1273
1274
1275
1276
1277
1278
1279
		      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)
1280
    in
1281
    	returnNat (Any pk code__2)
1282
1283
1284
1285

getRegister (StInt i)
  = let
    	src = ImmInt (fromInteger i)
1286
1287
1288
1289
1290
    	code dst 
           | i == 0
           = unitOL (XOR L (OpReg dst) (OpReg dst))
           | otherwise
           = unitOL (MOV L (OpImm src) (OpReg dst))
1291
    in
1292
    	returnNat (Any IntRep code)
1293
1294
1295

getRegister leaf
  | maybeToBool imm
1296
  = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
1297
    in
1298
    	returnNat (Any PtrRep code)
1299
  | otherwise
1300
  = ncgPrimopMoan "getRegister(x86)" (pprStixExpr leaf)
1301
1302
1303
1304
1305
  where
    imm = maybeImm leaf
    imm__2 = case imm of Just x -> x

#endif {- i386_TARGET_ARCH -}
1306

1307
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1308

1309
1310
#if sparc_TARGET_ARCH

1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
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)

1324
getRegister (StDouble d)
1325
1326
  = getNatLabelNCG 	    	    `thenNat` \ lbl ->
    getNewRegNCG PtrRep    	    `thenNat` \ tmp ->
1327
    let code dst = toOL [
1328
1329
    	    SEGMENT DataSegment,
	    LABEL lbl,
1330
	    DATA DF [ImmDouble d],
1331
1332
	    SEGMENT TextSegment,
	    SETHI (HI (ImmCLbl lbl)) tmp,
sof's avatar
sof committed
1333
	    LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1334
    in
1335
    	returnNat (Any DoubleRep code)
1336

1337

1338
1339
1340
1341
getRegister (StMachOp mop [x]) -- unary PrimOps
  = case mop of
      MO_NatS_Neg      -> trivialUCode (SUB False False g0) x
      MO_Nat_Not       -> trivialUCode (XNOR False g0) x
1342
      MO_32U_to_8U     -> trivialCode (AND False) x (StInt 255)
1343

1344
1345
      MO_Flt_Neg       -> trivialUFCode FloatRep (FNEG F) x
      MO_Dbl_Neg       -> trivialUFCode DoubleRep (FNEG DF) x
1346

1347
1348
      MO_Dbl_to_Flt    -> coerceDbl2Flt x
      MO_Flt_to_Dbl    -> coerceFlt2Dbl x
1349

1350
1351
1352
1353
      MO_Flt_to_NatS   -> coerceFP2Int FloatRep x
      MO_NatS_to_Flt   -> coerceInt2FP FloatRep x
      MO_Dbl_to_NatS   -> coerceFP2Int DoubleRep x
      MO_NatS_to_Dbl   -> coerceInt2FP DoubleRep x
1354

1355
1356
      -- Conversions which are a nop on sparc
      MO_32U_to_NatS   -> conversionNop IntRep   x
1357
      MO_32S_to_NatS  -> conversionNop IntRep   x
1358
      MO_NatS_to_32U   -> conversionNop WordRep  x
1359
      MO_32U_to_NatU   -> conversionNop WordRep  x
1360

1361
1362
1363
1364
1365
1366
1367
1368
      MO_NatU_to_NatS -> conversionNop IntRep    x
      MO_NatS_to_NatU -> conversionNop WordRep   x
      MO_NatP_to_NatU -> conversionNop WordRep   x
      MO_NatU_to_NatP -> conversionNop PtrRep    x
      MO_NatS_to_NatP -> conversionNop PtrRep    x
      MO_NatP_to_NatS -> conversionNop IntRep    x

      -- sign-extending widenings
1369
      MO_8U_to_32U    -> integerExtend False 24 x
1370
1371
1372
1373
      MO_8U_to_NatU   -> integerExtend False 24 x
      MO_8S_to_NatS   -> integerExtend True  24 x
      MO_16U_to_NatU  -> integerExtend False 16 x
      MO_16S_to_NatS  -> integerExtend True  16 x
1374
1375

      other_op ->
1376
1377
1378
        let fixed_x = if   is_float_op  -- promote to double
                      then StMachOp MO_Flt_to_Dbl [x]
                      else x
1379
	in
1380
	getRegister (StCall (Left fn) CCallConv DoubleRep [fixed_x])
1381
1382
1383
1384
    where
        integerExtend signed nBits x
           = getRegister (
                StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)