MachCode.lhs 118 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
-- DEBUGGING ONLY
import IOExts		( trace )
52
import Outputable	( assertPanic )
53

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

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

unLeft (Left x) = x
71
72
73
74
75
\end{code}

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

\begin{code}
76
stmtsToInstrs :: [StixStmt] -> NatM InstrBlock
77
stmtsToInstrs stmts
78
   = mapNat stmtToInstrs stmts		`thenNat` \ instrss ->
79
80
81
     returnNat (concatOL instrss)


82
stmtToInstrs :: StixStmt -> NatM InstrBlock
83
stmtToInstrs stmt = case stmt of
84
85
    StComment s    -> returnNat (unitOL (COMMENT s))
    StSegment seg  -> returnNat (unitOL (SEGMENT seg))
86

87
88
89
90
    StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
                                                       LABEL lab)))
    StFunEnd lab   -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
                                    returnNat nilOL)
91

92
    StLabel lab	   -> returnNat (unitOL (LABEL lab))
93

94
    StJump dsts arg	   -> genJump dsts (derefDLL arg)
95
96
    StCondJump lab arg	   -> genCondJump lab (derefDLL arg)

97
98
99
100
    -- 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)
101

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

    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)))
117
	,returnNat nilOL)
118
119

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

135
    -- Top-level lifted-out string.  The segment will already have been set
136
137
    -- (see Stix.liftStrings).
    StDataString str
138
139
      -> returnNat (unitOL (ASCII True (_UNPK_ str)))

140
#ifdef DEBUG
141
    other -> pprPanic "stmtToInstrs" (pprStixStmt other)
142
#endif
143

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

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

\begin{code}
182
mangleIndexTree :: StixExpr -> StixExpr
183
184

mangleIndexTree (StIndex pk base (StInt i))
185
  = StMachOp MO_Nat_Add [base, off]
186
  where
187
    off = StInt (i * toInteger (getPrimRepArrayElemSize pk))
188
189

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

\begin{code}
208
maybeImm :: StixExpr -> Maybe Imm
209

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

maybeImm _ = Nothing
\end{code}

223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
%************************************************************************
%*									*
\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
249
	-- therefore that the returned VRegUnique may be modified
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
339
340
341
342
343
344
345

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

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

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
430
431
432
433
434
435
436
#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 -}

-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
437
438
439

\end{code}

440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
%************************************************************************
%*									*
\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

460
registerCodeF (Fixed _ _ code) = code
461
registerCodeF (Any _ _)        = panic "registerCodeF"
462

463
registerCodeA (Any _ code)  = code
464
registerCodeA (Fixed _ _ _) = panic "registerCodeA"
465

466
467
registerName :: Register -> Reg -> Reg
registerName (Fixed _ reg _) _ = reg
468
469
470
registerName (Any _ _)   reg   = reg

registerNameF (Fixed _ reg _) = reg
471
registerNameF (Any _ _)       = panic "registerNameF"
472
473
474
475
476

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

477
478
479
480
swizzleRegisterRep :: Register -> PrimRep -> Register
swizzleRegisterRep (Fixed _ reg code) rep = Fixed rep reg code
swizzleRegisterRep (Any _ codefn)     rep = Any rep codefn

481
482
483
484
485
486
487
488
489
{-# INLINE registerCode  #-}
{-# INLINE registerCodeF #-}
{-# INLINE registerName  #-}
{-# INLINE registerNameF #-}
{-# INLINE registerRep   #-}
{-# INLINE isFixed       #-}
{-# INLINE isAny         #-}

isFixed, isAny :: Register -> Bool
490
491
isFixed (Fixed _ _ _) = True
isFixed (Any _ _)     = False
492

493
isAny = not . isFixed
494
495
496
497
498
\end{code}

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

499
getRegisterReg :: StixReg -> NatM Register
500
501
getRegister :: StixExpr -> NatM Register

502

503
504
505
506
507
508
509
510
511
512
513
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))
514
  = returnNat (Fixed pk (mkVReg u pk) nilOL)
515

516
517
-------------

518
519
520
521
-- Don't delete this -- it's very handy for debugging.
--getRegister expr 
--   | trace ("getRegiste: " ++ showSDoc (pprStixExpr expr)) False
--   = panic "getRegister(???)"
522
523
524
525
526
527

getRegister (StReg reg) 
  = getRegisterReg reg

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

sof's avatar
sof committed
529
getRegister (StCall fn cconv kind args)
530
  | not (ncg_target_is_32bit && is64BitRep kind)
531
532
  = genCCall fn cconv kind args   	    `thenNat` \ call ->
    returnNat (Fixed kind reg call)
533
534
  where
    reg = if isFloatingRep kind
535
	  then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,)))
536
537
538
	  else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))

getRegister (StString s)
539
  = getNatLabelNCG 	    	    `thenNat` \ lbl ->
540
541
542
    let
	imm_lbl = ImmCLbl lbl

543
	code dst = toOL [
544
	    SEGMENT RoDataSegment,
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
	    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
560
    returnNat (Any PtrRep code)
561

562
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
563
564
565
566
567
-- end of machine-"independent" bit; here we go on the rest...

#if alpha_TARGET_ARCH

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

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

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

639
      IntGtOp  -> trivialCode (CMP LTT) y x
640
      IntGeOp  -> trivialCode (CMP LE) y x
641
      IntEqOp  -> trivialCode (CMP EQQ) x y
642
      IntNeOp  -> int_NE_code x y
643
      IntLtOp  -> trivialCode (CMP LTT) x y
644
645
646
647
      IntLeOp  -> trivialCode (CMP LE) x y

      WordGtOp -> trivialCode (CMP ULT) y x
      WordGeOp -> trivialCode (CMP ULE) x y
648
      WordEqOp -> trivialCode (CMP EQQ)  x y
649
650
651
652
653
654
      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
655
      AddrEqOp -> trivialCode (CMP EQQ)  x y
656
657
658
      AddrNeOp -> int_NE_code x y
      AddrLtOp -> trivialCode (CMP ULT) x y
      AddrLeOp -> trivialCode (CMP ULE) x y
apt's avatar
apt committed
659
	
660
661
662
663
664
      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
665
666
      FloatLeOp -> cmpF_code (FCMP TF LE) NE x y

667
668
669
670
671
      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
672
673
674
675
676
677
678
679
      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

680
681
682
      WordAddOp  -> trivialCode (ADD Q False) x y
      WordSubOp  -> trivialCode (SUB Q False) x y
      WordMulOp  -> trivialCode (MUL Q False) x y
683
684
685
      WordQuotOp -> trivialCode (DIV Q True) x y
      WordRemOp  -> trivialCode (REM Q True) x y

686
687
688
689
690
691
692
693
694
695
      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
696
697
698
699
      AddrAddOp  -> trivialCode (ADD Q False) x y
      AddrSubOp  -> trivialCode (SUB Q False) x y
      AddrRemOp  -> trivialCode (REM Q True) x y

700
701
      AndOp  -> trivialCode AND x y
      OrOp   -> trivialCode OR  x y
702
      XorOp  -> trivialCode XOR x y
703
704
705
      SllOp  -> trivialCode SLL x y
      SrlOp  -> trivialCode SRL x y

sof's avatar
sof committed
706
      ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
sof's avatar
sof committed
707
      ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
sof's avatar
sof committed
708
      ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
709

710
711
      FloatPowerOp  -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
      DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
712
713
714
715
716
717
718
719
720
  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.
    -}
721
    int_NE_code :: StixTree -> StixTree -> NatM Register
722
723

    int_NE_code x y
724
725
      = trivialCode (CMP EQQ) x y	`thenNat` \ register ->
	getNewRegNCG IntRep		`thenNat` \ tmp ->
726
727
728
729
730
	let
	    code = registerCode register tmp
	    src  = registerName register tmp
	    code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
	in
731
	returnNat (Any IntRep code__2)
732
733
734
735
736
737
738
739

    {- ------------------------------------------------------------
	Comments for int_NE_code also apply to cmpF_code
    -}
    cmpF_code
	:: (Reg -> Reg -> Reg -> Instr)
	-> Cond
	-> StixTree -> StixTree
740
	-> NatM Register
741
742

    cmpF_code instr cond x y
743
744
745
      = trivialFCode pr instr x y	`thenNat` \ register ->
	getNewRegNCG DoubleRep		`thenNat` \ tmp ->
	getNatLabelNCG			`thenNat` \ lbl ->
746
747
748
749
750
	let
	    code = registerCode register tmp
	    result  = registerName register tmp

	    code__2 dst = code . mkSeqInstrs [
751
752
753
		OR zeroh (RIImm (ImmInt 1)) dst,
		BF cond  result (ImmCLbl lbl),
		OR zeroh (RIReg zeroh) dst,
754
755
		LABEL lbl]
	in
756
	returnNat (Any IntRep code__2)
757
758
759
760
761
      where
	pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
      ------------------------------------------------------------

getRegister (StInd pk mem)
762
  = getAmode mem    	    	    `thenNat` \ amode ->
763
764
765
766
767
768
    let
    	code = amodeCode amode
    	src   = amodeAddr amode
    	size = primRepToSize pk
    	code__2 dst = code . mkSeqInstr (LD size dst src)
    in
769
    returnNat (Any pk code__2)
770
771
772
773

getRegister (StInt i)
  | fits8Bits i
  = let
774
    	code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
775
    in
776
    returnNat (Any IntRep code)
777
778
779
780
  | otherwise
  = let
    	code dst = mkSeqInstr (LDI Q dst src)
    in
781
    returnNat (Any IntRep code)
782
783
784
785
786
787
788
789
  where
    src = ImmInt (fromInteger i)

getRegister leaf
  | maybeToBool imm
  = let
    	code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
    in
790
    returnNat (Any PtrRep code)
791
792
793
794
795
  where
    imm = maybeImm leaf
    imm__2 = case imm of Just x -> x

#endif {- alpha_TARGET_ARCH -}
796

797
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
798

799
800
#if i386_TARGET_ARCH

801
802
803
804
805
806
807
808
809
810
811
812
813
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)


814
getRegister (StDouble d)
815
816
817

  | d == 0.0
  = let code dst = unitOL (GLDZ dst)
818
    in  returnNat (Any DoubleRep code)
819
820
821

  | d == 1.0
  = let code dst = unitOL (GLD1 dst)
822
    in  returnNat (Any DoubleRep code)
823
824
825
826

  | otherwise
  = getNatLabelNCG 	    	    `thenNat` \ lbl ->
    let code dst = toOL [
827
828
    	    SEGMENT DataSegment,
	    LABEL lbl,
829
	    DATA DF [ImmDouble d],
830
	    SEGMENT TextSegment,
831
	    GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
832
833
	    ]
    in
834
    returnNat (Any DoubleRep code)
835

836

837
838
839
840
getRegister (StMachOp mop [x]) -- unary MachOps
  = case mop of
      MO_NatS_Neg  -> trivialUCode (NEGI L) x
      MO_Nat_Not   -> trivialUCode (NOT L) x
841
      MO_32U_to_8U -> trivialUCode (AND L (OpImm (ImmInt 255))) x
842

843
844
      MO_Flt_Neg  -> trivialUFCode FloatRep  (GNEG F) x
      MO_Dbl_Neg  -> trivialUFCode DoubleRep (GNEG DF) x
845

846
847
      MO_Flt_Sqrt -> trivialUFCode FloatRep  (GSQRT F) x
      MO_Dbl_Sqrt -> trivialUFCode DoubleRep (GSQRT DF) x
848

849
850
      MO_Flt_Sin  -> trivialUFCode FloatRep  (GSIN F) x
      MO_Dbl_Sin  -> trivialUFCode DoubleRep (GSIN DF) x
851

852
853
      MO_Flt_Cos  -> trivialUFCode FloatRep  (GCOS F) x
      MO_Dbl_Cos  -> trivialUFCode DoubleRep (GCOS DF) x
854

855
856
      MO_Flt_Tan  -> trivialUFCode FloatRep  (GTAN F) x
      MO_Dbl_Tan  -> trivialUFCode DoubleRep (GTAN DF) x
857

858
      MO_Flt_to_NatS -> coerceFP2Int FloatRep x
859
      MO_NatS_to_Flt -> coerceInt2FP FloatRep x
860
      MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
861
      MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
862

863
864
865
      -- Conversions which are a nop on x86
      MO_NatS_to_32U  -> conversionNop WordRep   x
      MO_32U_to_NatS  -> conversionNop IntRep    x
866

867
868
869
870
871
872
      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
873

874
875
      MO_Dbl_to_Flt   -> conversionNop FloatRep  x
      MO_Flt_to_Dbl   -> conversionNop DoubleRep x
876

877
      -- sign-extending widenings
878
879
880
881
      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
882
      MO_8U_to_32U    -> integerExtend False 24 x
883

884
885
886
      other_op 
         -> getRegister (
               (if is_float_op then demote else id)
887
888
               (StCall (Left fn) CCallConv DoubleRep 
                       [(if is_float_op then promote else id) x])
889
890
891
892
893
            )
      where
        integerExtend signed nBits x
           = getRegister (
                StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr) 
894
                         [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
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
968
969
970
971
972
973
974
             )

        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
975
      MO_NatS_MulMayOflo -> imulMayOflo x y
976
977
978
979
980
981
982
983
984
985
986
987
988
989

      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
990

sof's avatar
sof committed
991
992
993
	{- 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.)
994
995
996
997
	-}	   
      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-}
998

999
      MO_Flt_Pwr  -> getRegister (demote 
1000
                                 (StCall (Left SLIT("pow")) CCallConv DoubleRep