MachCode.lhs 117 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
32
import PrimRep		( isFloatingRep, is64BitRep, PrimRep(..),
                          getPrimRepArrayElemSize )
33
import Stix		( getNatLabelNCG, StixStmt(..), StixExpr(..),
34
			  StixReg(..), pprStixReg, StixVReg(..), CodeSegment(..), 
35
                          DestInfo, hasDestInfo,
36
                          pprStixExpr, repOfStixExpr,
37
                          liftStrings,
38
39
                          NatM, thenNat, returnNat, mapNat, 
                          mapAndUnzipNat, mapAccumLNat,
40
41
42
                          getDeltaNat, setDeltaNat, getUniqueNat,
                          ncgPrimopMoan,
			  ncg_target_is_32bit
43
			)
44
import Pretty
45
import Outputable	( panic, pprPanic, showSDoc )
46
import qualified Outputable
47
import CmdLineOpts	( opt_Static )
48
import Stix		( pprStixStmt )
49

50
51
52
-- DEBUGGING ONLY
import IOExts		( trace )

53
infixr 3 `bind`
54
55
56
57
58
59
60
61
62
63
64
\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
65
66
67
68
69
\end{code}

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

\begin{code}
70
stmtsToInstrs :: [StixStmt] -> NatM InstrBlock
71
stmtsToInstrs stmts
72
   = mapNat stmtToInstrs stmts		`thenNat` \ instrss ->
73
74
75
     returnNat (concatOL instrss)


76
stmtToInstrs :: StixStmt -> NatM InstrBlock
77
stmtToInstrs stmt = case stmt of
78
79
    StComment s    -> returnNat (unitOL (COMMENT s))
    StSegment seg  -> returnNat (unitOL (SEGMENT seg))
80

81
82
83
84
    StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
                                                       LABEL lab)))
    StFunEnd lab   -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
                                    returnNat nilOL)
85

86
    StLabel lab	   -> returnNat (unitOL (LABEL lab))
87

88
    StJump dsts arg	   -> genJump dsts (derefDLL arg)
89
90
    StCondJump lab arg	   -> genCondJump lab (derefDLL arg)

91
92
93
94
    -- 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)
95

96
97
    StAssignMem pk addr src
      | isFloatingRep pk -> assignMem_FltCode pk (derefDLL addr) (derefDLL src)
98
99
      | ncg_target_is_32bit
        && is64BitRep pk -> assignMem_I64Code    (derefDLL addr) (derefDLL src)
100
101
102
      | otherwise	 -> assignMem_IntCode pk (derefDLL addr) (derefDLL src)
    StAssignReg pk reg src
      | isFloatingRep pk -> assignReg_FltCode pk reg (derefDLL src)
103
104
      | ncg_target_is_32bit
        && is64BitRep pk -> assignReg_I64Code    reg (derefDLL src)
105
      | otherwise	 -> assignReg_IntCode pk reg (derefDLL src)
106
107
108
109
110

    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)))
111
	,returnNat nilOL)
112
113

    StData kind args
114
115
116
      -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
	 returnNat (DATA (primRepToSize kind) imms  
                    `consOL`  concatOL codes)
117
      where
118
	getData :: StixExpr -> NatM (InstrBlock, Imm)
119
120
	getData (StInt i)        = returnNat (nilOL, ImmInteger i)
	getData (StDouble d)     = returnNat (nilOL, ImmDouble d)
121
	getData (StFloat d)      = returnNat (nilOL, ImmFloat d)
122
	getData (StCLbl l)       = returnNat (nilOL, ImmCLbl l)
123
	getData (StString s)     = panic "MachCode.stmtToInstrs: unlifted StString"
124
125
	-- the linker can handle simple arithmetic...
	getData (StIndex rep (StCLbl lbl) (StInt off)) =
126
		returnNat (nilOL,
127
                           ImmIndex lbl (fromInteger off * getPrimRepArrayElemSize rep))
128

129
    -- Top-level lifted-out string.  The segment will already have been set
130
131
    -- (see Stix.liftStrings).
    StDataString str
132
133
      -> returnNat (unitOL (ASCII True (_UNPK_ str)))

134
#ifdef DEBUG
135
    other -> pprPanic "stmtToInstrs" (pprStixStmt other)
136
#endif
137

138
139
140
141
-- 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.
142
derefDLL :: StixExpr -> StixExpr
143
144
145
146
147
148
149
150
151
152
153
154
155
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)
156
                StMachOp mop args      -> StMachOp mop (map qq args)
157
158
159
                StInd pk addr          -> StInd pk (qq addr)
                StCall who cc pk args  -> StCall who cc pk (map qq args)
                StInt    _             -> t
160
                StFloat  _             -> t
161
162
163
164
                StDouble _             -> t
                StString _             -> t
                StReg    _             -> t
                _                      -> pprPanic "derefDLL: unhandled case" 
165
                                                   (pprStixExpr t)
166
167
168
169
170
171
172
173
174
\end{code}

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

\begin{code}
175
mangleIndexTree :: StixExpr -> StixExpr
176
177

mangleIndexTree (StIndex pk base (StInt i))
178
  = StMachOp MO_Nat_Add [base, off]
179
  where
180
    off = StInt (i * toInteger (getPrimRepArrayElemSize pk))
181
182

mangleIndexTree (StIndex pk base off)
183
  = StMachOp MO_Nat_Add [
184
185
       base,
       let s = shift pk
186
187
       in  if s == 0 then off 
                     else StMachOp MO_Nat_Shl [off, StInt (toInteger s)]
188
    ]
189
  where
190
    shift :: PrimRep -> Int
191
    shift rep = case getPrimRepArrayElemSize rep of
192
193
194
195
196
                   1 -> 0
                   2 -> 1
                   4 -> 2
                   8 -> 3
                   other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size" 
197
                                     (Outputable.int other)
198
199
200
\end{code}

\begin{code}
201
maybeImm :: StixExpr -> Maybe Imm
202

203
204
205
maybeImm (StCLbl l)       
   = Just (ImmCLbl l)
maybeImm (StIndex rep (StCLbl l) (StInt off)) 
206
   = Just (ImmIndex l (fromInteger off * getPrimRepArrayElemSize rep))
207
maybeImm (StInt i)
sof's avatar
sof committed
208
  | i >= toInteger (minBound::Int) && i <= toInteger (maxBound::Int)
209
210
211
212
213
214
215
  = Just (ImmInt (fromInteger i))
  | otherwise
  = Just (ImmInteger i)

maybeImm _ = Nothing
\end{code}

216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
%************************************************************************
%*									*
\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
242
	-- therefore that the returned VRegUnique may be modified
243
244
245
246
247
248
249
250
251
252
253
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

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

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

339
340
341
342
343
344
345
346
347
348
349
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
#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 -}

-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
430
431
432

\end{code}

433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
%************************************************************************
%*									*
\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

453
registerCodeF (Fixed _ _ code) = code
454
registerCodeF (Any _ _)        = panic "registerCodeF"
455

456
registerCodeA (Any _ code)  = code
457
registerCodeA (Fixed _ _ _) = panic "registerCodeA"
458

459
460
registerName :: Register -> Reg -> Reg
registerName (Fixed _ reg _) _ = reg
461
462
463
registerName (Any _ _)   reg   = reg

registerNameF (Fixed _ reg _) = reg
464
registerNameF (Any _ _)       = panic "registerNameF"
465
466
467
468
469

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

470
471
472
473
swizzleRegisterRep :: Register -> PrimRep -> Register
swizzleRegisterRep (Fixed _ reg code) rep = Fixed rep reg code
swizzleRegisterRep (Any _ codefn)     rep = Any rep codefn

474
475
476
477
478
479
480
481
482
{-# INLINE registerCode  #-}
{-# INLINE registerCodeF #-}
{-# INLINE registerName  #-}
{-# INLINE registerNameF #-}
{-# INLINE registerRep   #-}
{-# INLINE isFixed       #-}
{-# INLINE isAny         #-}

isFixed, isAny :: Register -> Bool
483
484
isFixed (Fixed _ _ _) = True
isFixed (Any _ _)     = False
485

486
isAny = not . isFixed
487
488
489
490
491
\end{code}

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

492
getRegisterReg :: StixReg -> NatM Register
493
494
getRegister :: StixExpr -> NatM Register

495

496
497
498
499
500
501
502
503
504
505
506
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))
507
  = returnNat (Fixed pk (mkVReg u pk) nilOL)
508

509
510
-------------

511
512
513
514
-- Don't delete this -- it's very handy for debugging.
--getRegister expr 
--   | trace ("getRegiste: " ++ showSDoc (pprStixExpr expr)) False
--   = panic "getRegister(???)"
515
516
517
518
519
520

getRegister (StReg reg) 
  = getRegisterReg reg

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

sof's avatar
sof committed
522
getRegister (StCall fn cconv kind args)
523
  | not (ncg_target_is_32bit && is64BitRep kind)
524
525
  = genCCall fn cconv kind args   	    `thenNat` \ call ->
    returnNat (Fixed kind reg call)
526
527
  where
    reg = if isFloatingRep kind
528
	  then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,)))
529
530
531
	  else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))

getRegister (StString s)
532
  = getNatLabelNCG 	    	    `thenNat` \ lbl ->
533
534
535
    let
	imm_lbl = ImmCLbl lbl

536
	code dst = toOL [
537
	    SEGMENT RoDataSegment,
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
	    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
553
    returnNat (Any PtrRep code)
554

555
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
556
557
558
559
560
-- end of machine-"independent" bit; here we go on the rest...

#if alpha_TARGET_ARCH

getRegister (StDouble d)
561
562
  = getNatLabelNCG 	    	    `thenNat` \ lbl ->
    getNewRegNCG PtrRep    	    `thenNat` \ tmp ->
563
564
565
    let code dst = mkSeqInstrs [
    	    SEGMENT DataSegment,
	    LABEL lbl,
sof's avatar
sof committed
566
	    DATA TF [ImmLab (rational d)],
567
568
569
570
	    SEGMENT TextSegment,
	    LDA tmp (AddrImm (ImmCLbl lbl)),
	    LD TF dst (AddrReg tmp)]
    in
571
    	returnNat (Any DoubleRep code)
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592

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

593
      other_op -> getRegister (StCall fn CCallConv DoubleRep [x])
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
	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
625
      CharGtOp -> trivialCode (CMP LTT) y x
626
      CharGeOp -> trivialCode (CMP LE) y x
627
      CharEqOp -> trivialCode (CMP EQQ) x y
628
      CharNeOp -> int_NE_code x y
629
      CharLtOp -> trivialCode (CMP LTT) x y
630
631
      CharLeOp -> trivialCode (CMP LE) x y

632
      IntGtOp  -> trivialCode (CMP LTT) y x
633
      IntGeOp  -> trivialCode (CMP LE) y x
634
      IntEqOp  -> trivialCode (CMP EQQ) x y
635
      IntNeOp  -> int_NE_code x y
636
      IntLtOp  -> trivialCode (CMP LTT) x y
637
638
639
640
      IntLeOp  -> trivialCode (CMP LE) x y

      WordGtOp -> trivialCode (CMP ULT) y x
      WordGeOp -> trivialCode (CMP ULE) x y
641
      WordEqOp -> trivialCode (CMP EQQ)  x y
642
643
644
645
646
647
      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
648
      AddrEqOp -> trivialCode (CMP EQQ)  x y
649
650
651
      AddrNeOp -> int_NE_code x y
      AddrLtOp -> trivialCode (CMP ULT) x y
      AddrLeOp -> trivialCode (CMP ULE) x y
apt's avatar
apt committed
652
	
653
654
655
656
657
      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
658
659
      FloatLeOp -> cmpF_code (FCMP TF LE) NE x y

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

673
674
675
      WordAddOp  -> trivialCode (ADD Q False) x y
      WordSubOp  -> trivialCode (SUB Q False) x y
      WordMulOp  -> trivialCode (MUL Q False) x y
676
677
678
      WordQuotOp -> trivialCode (DIV Q True) x y
      WordRemOp  -> trivialCode (REM Q True) x y

679
680
681
682
683
684
685
686
687
688
      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
689
690
691
692
      AddrAddOp  -> trivialCode (ADD Q False) x y
      AddrSubOp  -> trivialCode (SUB Q False) x y
      AddrRemOp  -> trivialCode (REM Q True) x y

693
694
      AndOp  -> trivialCode AND x y
      OrOp   -> trivialCode OR  x y
695
      XorOp  -> trivialCode XOR x y
696
697
698
      SllOp  -> trivialCode SLL x y
      SrlOp  -> trivialCode SRL x y

sof's avatar
sof committed
699
      ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
sof's avatar
sof committed
700
      ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
sof's avatar
sof committed
701
      ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
702

703
704
      FloatPowerOp  -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
      DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
705
706
707
708
709
710
711
712
713
  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.
    -}
714
    int_NE_code :: StixTree -> StixTree -> NatM Register
715
716

    int_NE_code x y
717
718
      = trivialCode (CMP EQQ) x y	`thenNat` \ register ->
	getNewRegNCG IntRep		`thenNat` \ tmp ->
719
720
721
722
723
	let
	    code = registerCode register tmp
	    src  = registerName register tmp
	    code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
	in
724
	returnNat (Any IntRep code__2)
725
726
727
728
729
730
731
732

    {- ------------------------------------------------------------
	Comments for int_NE_code also apply to cmpF_code
    -}
    cmpF_code
	:: (Reg -> Reg -> Reg -> Instr)
	-> Cond
	-> StixTree -> StixTree
733
	-> NatM Register
734
735

    cmpF_code instr cond x y
736
737
738
      = trivialFCode pr instr x y	`thenNat` \ register ->
	getNewRegNCG DoubleRep		`thenNat` \ tmp ->
	getNatLabelNCG			`thenNat` \ lbl ->
739
740
741
742
743
	let
	    code = registerCode register tmp
	    result  = registerName register tmp

	    code__2 dst = code . mkSeqInstrs [
744
745
746
		OR zeroh (RIImm (ImmInt 1)) dst,
		BF cond  result (ImmCLbl lbl),
		OR zeroh (RIReg zeroh) dst,
747
748
		LABEL lbl]
	in
749
	returnNat (Any IntRep code__2)
750
751
752
753
754
      where
	pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
      ------------------------------------------------------------

getRegister (StInd pk mem)
755
  = getAmode mem    	    	    `thenNat` \ amode ->
756
757
758
759
760
761
    let
    	code = amodeCode amode
    	src   = amodeAddr amode
    	size = primRepToSize pk
    	code__2 dst = code . mkSeqInstr (LD size dst src)
    in
762
    returnNat (Any pk code__2)
763
764
765
766

getRegister (StInt i)
  | fits8Bits i
  = let
767
    	code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
768
    in
769
    returnNat (Any IntRep code)
770
771
772
773
  | otherwise
  = let
    	code dst = mkSeqInstr (LDI Q dst src)
    in
774
    returnNat (Any IntRep code)
775
776
777
778
779
780
781
782
  where
    src = ImmInt (fromInteger i)

getRegister leaf
  | maybeToBool imm
  = let
    	code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
    in
783
    returnNat (Any PtrRep code)
784
785
786
787
788
  where
    imm = maybeImm leaf
    imm__2 = case imm of Just x -> x

#endif {- alpha_TARGET_ARCH -}
789

790
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
791

792
793
#if i386_TARGET_ARCH

794
795
796
797
798
799
800
801
802
803
804
805
806
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)


807
getRegister (StDouble d)
808
809
810

  | d == 0.0
  = let code dst = unitOL (GLDZ dst)
811
    in  returnNat (Any DoubleRep code)
812
813
814

  | d == 1.0
  = let code dst = unitOL (GLD1 dst)
815
    in  returnNat (Any DoubleRep code)
816
817
818
819

  | otherwise
  = getNatLabelNCG 	    	    `thenNat` \ lbl ->
    let code dst = toOL [
820
821
    	    SEGMENT DataSegment,
	    LABEL lbl,
822
	    DATA DF [ImmDouble d],
823
	    SEGMENT TextSegment,
824
	    GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
825
826
	    ]
    in
827
    returnNat (Any DoubleRep code)
828

829

830
831
832
833
getRegister (StMachOp mop [x]) -- unary MachOps
  = case mop of
      MO_NatS_Neg  -> trivialUCode (NEGI L) x
      MO_Nat_Not   -> trivialUCode (NOT L) x
834
      MO_32U_to_8U -> trivialUCode (AND L (OpImm (ImmInt 255))) x
835

836
837
      MO_Flt_Neg  -> trivialUFCode FloatRep  (GNEG F) x
      MO_Dbl_Neg  -> trivialUFCode DoubleRep (GNEG DF) x
838

839
840
      MO_Flt_Sqrt -> trivialUFCode FloatRep  (GSQRT F) x
      MO_Dbl_Sqrt -> trivialUFCode DoubleRep (GSQRT DF) x
841

842
843
      MO_Flt_Sin  -> trivialUFCode FloatRep  (GSIN F) x
      MO_Dbl_Sin  -> trivialUFCode DoubleRep (GSIN DF) x
844

845
846
      MO_Flt_Cos  -> trivialUFCode FloatRep  (GCOS F) x
      MO_Dbl_Cos  -> trivialUFCode DoubleRep (GCOS DF) x
847

848
849
      MO_Flt_Tan  -> trivialUFCode FloatRep  (GTAN F) x
      MO_Dbl_Tan  -> trivialUFCode DoubleRep (GTAN DF) x
850

851
      MO_Flt_to_NatS -> coerceFP2Int FloatRep x
852
      MO_NatS_to_Flt -> coerceInt2FP FloatRep x
853
      MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
854
      MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
855

856
857
858
      -- Conversions which are a nop on x86
      MO_NatS_to_32U  -> conversionNop WordRep   x
      MO_32U_to_NatS  -> conversionNop IntRep    x
859

860
861
862
863
864
865
      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
866

867
868
      MO_Dbl_to_Flt   -> conversionNop FloatRep  x
      MO_Flt_to_Dbl   -> conversionNop DoubleRep x
869

870
      -- sign-extending widenings
871
872
873
874
      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
875
      MO_8U_to_32U    -> integerExtend False 24 x
876

877
878
879
880
881
882
883
884
885
886
      other_op 
         -> getRegister (
               (if is_float_op then demote else id)
               (StCall fn CCallConv DoubleRep 
                          [(if is_float_op then promote else id) x])
            )
      where
        integerExtend signed nBits x
           = getRegister (
                StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr) 
887
                         [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
             )

        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
	      MO_Flt_Exp   -> (True,  SLIT("exp"))
	      MO_Flt_Log   -> (True,  SLIT("log"))

	      MO_Flt_Asin  -> (True,  SLIT("asin"))
	      MO_Flt_Acos  -> (True,  SLIT("acos"))
	      MO_Flt_Atan  -> (True,  SLIT("atan"))

	      MO_Flt_Sinh  -> (True,  SLIT("sinh"))
	      MO_Flt_Cosh  -> (True,  SLIT("cosh"))
	      MO_Flt_Tanh  -> (True,  SLIT("tanh"))

	      MO_Dbl_Exp   -> (False, SLIT("exp"))
	      MO_Dbl_Log   -> (False, SLIT("log"))

	      MO_Dbl_Asin  -> (False, SLIT("asin"))
	      MO_Dbl_Acos  -> (False, SLIT("acos"))
	      MO_Dbl_Atan  -> (False, SLIT("atan"))

	      MO_Dbl_Sinh  -> (False, SLIT("sinh"))
	      MO_Dbl_Cosh  -> (False, SLIT("cosh"))
	      MO_Dbl_Tanh  -> (False, SLIT("tanh"))

              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
968
      MO_NatS_MulMayOflo -> imulMayOflo x y
969
970
971
972
973
974
975
976
977
978
979
980
981
982

      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
983

sof's avatar
sof committed
984
985
986
	{- 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.)
987
988
989
990
	-}	   
      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-}
991

992
993
      MO_Flt_Pwr  -> getRegister (demote 
                                 (StCall SLIT("pow") CCallConv DoubleRep 
994
                                           [promote x, promote y])
995
996
                                 )
      MO_Dbl_Pwr -> getRegister (StCall SLIT("pow") CCallConv DoubleRep 
997
                                           [x, y])
998
      other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop)
999
  where
1000
    promote x = StMachOp MO_Flt_to_Dbl [x]