← Back to branch summary

~ubuntu-branches/ubuntu/precise/ghc/precise

« back to all changes in this revision

Viewing changes to compiler/nativeGen/Alpha/CodeGen.hs

  • Committer: Bazaar Package Importer
  • Author(s): Joachim Breitner
  • Date: 2011-01-17 12:49:24 UTC
  • Revision ID: james.westby@ubuntu.com-20110117124924-do1pym1jlf5o636m
Tags: upstream-7.0.1
Import upstream version 7.0.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
compiler/nativeGen/Alpha/CodeGen.hs
 
1
module Alpha.CodeGen ()
 
2
 
 
3
where
 
4
 
 
5
{-
 
6
 
 
7
getRegister :: CmmExpr -> NatM Register
 
8
 
 
9
#if !x86_64_TARGET_ARCH
 
10
    -- on x86_64, we have %rip for PicBaseReg, but it's not a full-featured
 
11
    -- register, it can only be used for rip-relative addressing.
 
12
getRegister (CmmReg (CmmGlobal PicBaseReg))
 
13
  = do
 
14
      reg <- getPicBaseNat wordSize
 
15
      return (Fixed wordSize reg nilOL)
 
16
#endif
 
17
 
 
18
getRegister (CmmReg reg) 
 
19
  = return (Fixed (cmmTypeSize (cmmRegType reg)) 
 
20
                  (getRegisterReg reg) nilOL)
 
21
 
 
22
getRegister tree@(CmmRegOff _ _) 
 
23
  = getRegister (mangleIndexTree tree)
 
24
 
 
25
 
 
26
#if WORD_SIZE_IN_BITS==32
 
27
    -- for 32-bit architectuers, support some 64 -> 32 bit conversions:
 
28
    -- TO_W_(x), TO_W_(x >> 32)
 
29
 
 
30
getRegister (CmmMachOp (MO_UU_Conv W64 W32)
 
31
             [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
 
32
  ChildCode64 code rlo <- iselExpr64 x
 
33
  return $ Fixed II32 (getHiVRegFromLo rlo) code
 
34
 
 
35
getRegister (CmmMachOp (MO_SS_Conv W64 W32)
 
36
             [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
 
37
  ChildCode64 code rlo <- iselExpr64 x
 
38
  return $ Fixed II32 (getHiVRegFromLo rlo) code
 
39
 
 
40
getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do
 
41
  ChildCode64 code rlo <- iselExpr64 x
 
42
  return $ Fixed II32 rlo code
 
43
 
 
44
getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do
 
45
  ChildCode64 code rlo <- iselExpr64 x
 
46
  return $ Fixed II32 rlo code       
 
47
 
 
48
#endif
 
49
 
 
50
-- end of machine-"independent" bit; here we go on the rest...
 
51
 
 
52
 
 
53
getRegister (StDouble d)
 
54
  = getBlockIdNat                   `thenNat` \ lbl ->
 
55
    getNewRegNat PtrRep             `thenNat` \ tmp ->
 
56
    let code dst = mkSeqInstrs [
 
57
            LDATA RoDataSegment lbl [
 
58
                    DATA TF [ImmLab (rational d)]
 
59
                ],
 
60
            LDA tmp (AddrImm (ImmCLbl lbl)),
 
61
            LD TF dst (AddrReg tmp)]
 
62
    in
 
63
        return (Any FF64 code)
 
64
 
 
65
getRegister (StPrim primop [x]) -- unary PrimOps
 
66
  = case primop of
 
67
      IntNegOp -> trivialUCode (NEG Q False) x
 
68
 
 
69
      NotOp    -> trivialUCode NOT x
 
70
 
 
71
      FloatNegOp  -> trivialUFCode FloatRep (FNEG TF) x
 
72
      DoubleNegOp -> trivialUFCode FF64 (FNEG TF) x
 
73
 
 
74
      OrdOp -> coerceIntCode IntRep x
 
75
      ChrOp -> chrCode x
 
76
 
 
77
      Float2IntOp  -> coerceFP2Int    x
 
78
      Int2FloatOp  -> coerceInt2FP pr x
 
79
      Double2IntOp -> coerceFP2Int    x
 
80
      Int2DoubleOp -> coerceInt2FP pr x
 
81
 
 
82
      Double2FloatOp -> coerceFltCode x
 
83
      Float2DoubleOp -> coerceFltCode x
 
84
 
 
85
      other_op -> getRegister (StCall fn CCallConv FF64 [x])
 
86
        where
 
87
          fn = case other_op of
 
88
                 FloatExpOp    -> fsLit "exp"
 
89
                 FloatLogOp    -> fsLit "log"
 
90
                 FloatSqrtOp   -> fsLit "sqrt"
 
91
                 FloatSinOp    -> fsLit "sin"
 
92
                 FloatCosOp    -> fsLit "cos"
 
93
                 FloatTanOp    -> fsLit "tan"
 
94
                 FloatAsinOp   -> fsLit "asin"
 
95
                 FloatAcosOp   -> fsLit "acos"
 
96
                 FloatAtanOp   -> fsLit "atan"
 
97
                 FloatSinhOp   -> fsLit "sinh"
 
98
                 FloatCoshOp   -> fsLit "cosh"
 
99
                 FloatTanhOp   -> fsLit "tanh"
 
100
                 DoubleExpOp   -> fsLit "exp"
 
101
                 DoubleLogOp   -> fsLit "log"
 
102
                 DoubleSqrtOp  -> fsLit "sqrt"
 
103
                 DoubleSinOp   -> fsLit "sin"
 
104
                 DoubleCosOp   -> fsLit "cos"
 
105
                 DoubleTanOp   -> fsLit "tan"
 
106
                 DoubleAsinOp  -> fsLit "asin"
 
107
                 DoubleAcosOp  -> fsLit "acos"
 
108
                 DoubleAtanOp  -> fsLit "atan"
 
109
                 DoubleSinhOp  -> fsLit "sinh"
 
110
                 DoubleCoshOp  -> fsLit "cosh"
 
111
                 DoubleTanhOp  -> fsLit "tanh"
 
112
  where
 
113
    pr = panic "MachCode.getRegister: no primrep needed for Alpha"
 
114
 
 
115
getRegister (StPrim primop [x, y]) -- dyadic PrimOps
 
116
  = case primop of
 
117
      CharGtOp -> trivialCode (CMP LTT) y x
 
118
      CharGeOp -> trivialCode (CMP LE) y x
 
119
      CharEqOp -> trivialCode (CMP EQQ) x y
 
120
      CharNeOp -> int_NE_code x y
 
121
      CharLtOp -> trivialCode (CMP LTT) x y
 
122
      CharLeOp -> trivialCode (CMP LE) x y
 
123
 
 
124
      IntGtOp  -> trivialCode (CMP LTT) y x
 
125
      IntGeOp  -> trivialCode (CMP LE) y x
 
126
      IntEqOp  -> trivialCode (CMP EQQ) x y
 
127
      IntNeOp  -> int_NE_code x y
 
128
      IntLtOp  -> trivialCode (CMP LTT) x y
 
129
      IntLeOp  -> trivialCode (CMP LE) x y
 
130
 
 
131
      WordGtOp -> trivialCode (CMP ULT) y x
 
132
      WordGeOp -> trivialCode (CMP ULE) x y
 
133
      WordEqOp -> trivialCode (CMP EQQ)  x y
 
134
      WordNeOp -> int_NE_code x y
 
135
      WordLtOp -> trivialCode (CMP ULT) x y
 
136
      WordLeOp -> trivialCode (CMP ULE) x y
 
137
 
 
138
      AddrGtOp -> trivialCode (CMP ULT) y x
 
139
      AddrGeOp -> trivialCode (CMP ULE) y x
 
140
      AddrEqOp -> trivialCode (CMP EQQ)  x y
 
141
      AddrNeOp -> int_NE_code x y
 
142
      AddrLtOp -> trivialCode (CMP ULT) x y
 
143
      AddrLeOp -> trivialCode (CMP ULE) x y
 
144
        
 
145
      FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
 
146
      FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
 
147
      FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
 
148
      FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
 
149
      FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
 
150
      FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
 
151
 
 
152
      DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
 
153
      DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
 
154
      DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
 
155
      DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
 
156
      DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
 
157
      DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
 
158
 
 
159
      IntAddOp  -> trivialCode (ADD Q False) x y
 
160
      IntSubOp  -> trivialCode (SUB Q False) x y
 
161
      IntMulOp  -> trivialCode (MUL Q False) x y
 
162
      IntQuotOp -> trivialCode (DIV Q False) x y
 
163
      IntRemOp  -> trivialCode (REM Q False) x y
 
164
 
 
165
      WordAddOp  -> trivialCode (ADD Q False) x y
 
166
      WordSubOp  -> trivialCode (SUB Q False) x y
 
167
      WordMulOp  -> trivialCode (MUL Q False) x y
 
168
      WordQuotOp -> trivialCode (DIV Q True) x y
 
169
      WordRemOp  -> trivialCode (REM Q True) x y
 
170
 
 
171
      FloatAddOp -> trivialFCode  W32 (FADD TF) x y
 
172
      FloatSubOp -> trivialFCode  W32 (FSUB TF) x y
 
173
      FloatMulOp -> trivialFCode  W32 (FMUL TF) x y
 
174
      FloatDivOp -> trivialFCode  W32 (FDIV TF) x y
 
175
 
 
176
      DoubleAddOp -> trivialFCode  W64 (FADD TF) x y
 
177
      DoubleSubOp -> trivialFCode  W64 (FSUB TF) x y
 
178
      DoubleMulOp -> trivialFCode  W64 (FMUL TF) x y
 
179
      DoubleDivOp -> trivialFCode  W64 (FDIV TF) x y
 
180
 
 
181
      AddrAddOp  -> trivialCode (ADD Q False) x y
 
182
      AddrSubOp  -> trivialCode (SUB Q False) x y
 
183
      AddrRemOp  -> trivialCode (REM Q True) x y
 
184
 
 
185
      AndOp  -> trivialCode AND x y
 
186
      OrOp   -> trivialCode OR  x y
 
187
      XorOp  -> trivialCode XOR x y
 
188
      SllOp  -> trivialCode SLL x y
 
189
      SrlOp  -> trivialCode SRL x y
 
190
 
 
191
      ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
 
192
      ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
 
193
      ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
 
194
 
 
195
      FloatPowerOp  -> getRegister (StCall (fsLit "pow") CCallConv FF64 [x,y])
 
196
      DoublePowerOp -> getRegister (StCall (fsLit "pow") CCallConv FF64 [x,y])
 
197
  where
 
198
    {- ------------------------------------------------------------
 
199
        Some bizarre special code for getting condition codes into
 
200
        registers.  Integer non-equality is a test for equality
 
201
        followed by an XOR with 1.  (Integer comparisons always set
 
202
        the result register to 0 or 1.)  Floating point comparisons of
 
203
        any kind leave the result in a floating point register, so we
 
204
        need to wrangle an integer register out of things.
 
205
    -}
 
206
    int_NE_code :: StixTree -> StixTree -> NatM Register
 
207
 
 
208
    int_NE_code x y
 
209
      = trivialCode (CMP EQQ) x y       `thenNat` \ register ->
 
210
        getNewRegNat IntRep             `thenNat` \ tmp ->
 
211
        let
 
212
            code = registerCode register tmp
 
213
            src  = registerName register tmp
 
214
            code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
 
215
        in
 
216
        return (Any IntRep code__2)
 
217
 
 
218
    {- ------------------------------------------------------------
 
219
        Comments for int_NE_code also apply to cmpF_code
 
220
    -}
 
221
    cmpF_code
 
222
        :: (Reg -> Reg -> Reg -> Instr)
 
223
        -> Cond
 
224
        -> StixTree -> StixTree
 
225
        -> NatM Register
 
226
 
 
227
    cmpF_code instr cond x y
 
228
      = trivialFCode pr instr x y       `thenNat` \ register ->
 
229
        getNewRegNat FF64               `thenNat` \ tmp ->
 
230
        getBlockIdNat                   `thenNat` \ lbl ->
 
231
        let
 
232
            code = registerCode register tmp
 
233
            result  = registerName register tmp
 
234
 
 
235
            code__2 dst = code . mkSeqInstrs [
 
236
                OR zeroh (RIImm (ImmInt 1)) dst,
 
237
                BF cond  result (ImmCLbl lbl),
 
238
                OR zeroh (RIReg zeroh) dst,
 
239
                NEWBLOCK lbl]
 
240
        in
 
241
        return (Any IntRep code__2)
 
242
      where
 
243
        pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
 
244
      ------------------------------------------------------------
 
245
 
 
246
getRegister (CmmLoad pk mem)
 
247
  = getAmode mem                    `thenNat` \ amode ->
 
248
    let
 
249
        code = amodeCode amode
 
250
        src   = amodeAddr amode
 
251
        size = primRepToSize pk
 
252
        code__2 dst = code . mkSeqInstr (LD size dst src)
 
253
    in
 
254
    return (Any pk code__2)
 
255
 
 
256
getRegister (StInt i)
 
257
  | fits8Bits i
 
258
  = let
 
259
        code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
 
260
    in
 
261
    return (Any IntRep code)
 
262
  | otherwise
 
263
  = let
 
264
        code dst = mkSeqInstr (LDI Q dst src)
 
265
    in
 
266
    return (Any IntRep code)
 
267
  where
 
268
    src = ImmInt (fromInteger i)
 
269
 
 
270
getRegister leaf
 
271
  | isJust imm
 
272
  = let
 
273
        code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
 
274
    in
 
275
    return (Any PtrRep code)
 
276
  where
 
277
    imm = maybeImm leaf
 
278
    imm__2 = case imm of Just x -> x
 
279
 
 
280
 
 
281
getAmode :: CmmExpr -> NatM Amode
 
282
getAmode tree@(CmmRegOff _ _) = getAmode (mangleIndexTree tree)
 
283
 
 
284
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 
285
 
 
286
#if alpha_TARGET_ARCH
 
287
 
 
288
getAmode (StPrim IntSubOp [x, StInt i])
 
289
  = getNewRegNat PtrRep         `thenNat` \ tmp ->
 
290
    getRegister x               `thenNat` \ register ->
 
291
    let
 
292
        code = registerCode register tmp
 
293
        reg  = registerName register tmp
 
294
        off  = ImmInt (-(fromInteger i))
 
295
    in
 
296
    return (Amode (AddrRegImm reg off) code)
 
297
 
 
298
getAmode (StPrim IntAddOp [x, StInt i])
 
299
  = getNewRegNat PtrRep         `thenNat` \ tmp ->
 
300
    getRegister x               `thenNat` \ register ->
 
301
    let
 
302
        code = registerCode register tmp
 
303
        reg  = registerName register tmp
 
304
        off  = ImmInt (fromInteger i)
 
305
    in
 
306
    return (Amode (AddrRegImm reg off) code)
 
307
 
 
308
getAmode leaf
 
309
  | isJust imm
 
310
  = return (Amode (AddrImm imm__2) id)
 
311
  where
 
312
    imm = maybeImm leaf
 
313
    imm__2 = case imm of Just x -> x
 
314
 
 
315
getAmode other
 
316
  = getNewRegNat PtrRep         `thenNat` \ tmp ->
 
317
    getRegister other           `thenNat` \ register ->
 
318
    let
 
319
        code = registerCode register tmp
 
320
        reg  = registerName register tmp
 
321
    in
 
322
    return (Amode (AddrReg reg) code)
 
323
 
 
324
#endif /* alpha_TARGET_ARCH */
 
325
 
 
326
 
 
327
-- -----------------------------------------------------------------------------
 
328
-- Generating assignments
 
329
 
 
330
-- Assignments are really at the heart of the whole code generation
 
331
-- business.  Almost all top-level nodes of any real importance are
 
332
-- assignments, which correspond to loads, stores, or register
 
333
-- transfers.  If we're really lucky, some of the register transfers
 
334
-- will go away, because we can use the destination register to
 
335
-- complete the code generation for the right hand side.  This only
 
336
-- fails when the right hand side is forced into a fixed register
 
337
-- (e.g. the result of a call).
 
338
 
 
339
assignMem_IntCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock
 
340
assignReg_IntCode :: Size -> CmmReg  -> CmmExpr -> NatM InstrBlock
 
341
 
 
342
assignMem_FltCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock
 
343
assignReg_FltCode :: Size -> CmmReg  -> CmmExpr -> NatM InstrBlock
 
344
 
 
345
 
 
346
assignIntCode pk (CmmLoad dst _) src
 
347
  = getNewRegNat IntRep             `thenNat` \ tmp ->
 
348
    getAmode dst                    `thenNat` \ amode ->
 
349
    getRegister src                 `thenNat` \ register ->
 
350
    let
 
351
        code1   = amodeCode amode []
 
352
        dst__2  = amodeAddr amode
 
353
        code2   = registerCode register tmp []
 
354
        src__2  = registerName register tmp
 
355
        sz      = primRepToSize pk
 
356
        code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
 
357
    in
 
358
    return code__2
 
359
 
 
360
assignIntCode pk dst src
 
361
  = getRegister dst                         `thenNat` \ register1 ->
 
362
    getRegister src                         `thenNat` \ register2 ->
 
363
    let
 
364
        dst__2  = registerName register1 zeroh
 
365
        code    = registerCode register2 dst__2
 
366
        src__2  = registerName register2 dst__2
 
367
        code__2 = if isFixed register2
 
368
                  then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
 
369
                  else code
 
370
    in
 
371
    return code__2
 
372
 
 
373
assignFltCode pk (CmmLoad dst _) src
 
374
  = getNewRegNat pk                 `thenNat` \ tmp ->
 
375
    getAmode dst                    `thenNat` \ amode ->
 
376
    getRegister src                         `thenNat` \ register ->
 
377
    let
 
378
        code1   = amodeCode amode []
 
379
        dst__2  = amodeAddr amode
 
380
        code2   = registerCode register tmp []
 
381
        src__2  = registerName register tmp
 
382
        sz      = primRepToSize pk
 
383
        code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
 
384
    in
 
385
    return code__2
 
386
 
 
387
assignFltCode pk dst src
 
388
  = getRegister dst                         `thenNat` \ register1 ->
 
389
    getRegister src                         `thenNat` \ register2 ->
 
390
    let
 
391
        dst__2  = registerName register1 zeroh
 
392
        code    = registerCode register2 dst__2
 
393
        src__2  = registerName register2 dst__2
 
394
        code__2 = if isFixed register2
 
395
                  then code . mkSeqInstr (FMOV src__2 dst__2)
 
396
                  else code
 
397
    in
 
398
    return code__2
 
399
 
 
400
 
 
401
-- -----------------------------------------------------------------------------
 
402
-- Generating an non-local jump
 
403
 
 
404
-- (If applicable) Do not fill the delay slots here; you will confuse the
 
405
-- register allocator.
 
406
 
 
407
genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock
 
408
 
 
409
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 
410
 
 
411
 
 
412
genJump (CmmLabel lbl)
 
413
  | isAsmTemp lbl = returnInstr (BR target)
 
414
  | otherwise     = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
 
415
  where
 
416
    target = ImmCLbl lbl
 
417
 
 
418
genJump tree
 
419
  = getRegister tree                `thenNat` \ register ->
 
420
    getNewRegNat PtrRep             `thenNat` \ tmp ->
 
421
    let
 
422
        dst    = registerName register pv
 
423
        code   = registerCode register pv
 
424
        target = registerName register pv
 
425
    in
 
426
    if isFixed register then
 
427
        returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
 
428
    else
 
429
    return (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
 
430
 
 
431
 
 
432
-- -----------------------------------------------------------------------------
 
433
--  Unconditional branches
 
434
 
 
435
genBranch :: BlockId -> NatM InstrBlock
 
436
 
 
437
genBranch = return . toOL . mkBranchInstr
 
438
 
 
439
 
 
440
-- -----------------------------------------------------------------------------
 
441
--  Conditional jumps
 
442
 
 
443
{-
 
444
Conditional jumps are always to local labels, so we can use branch
 
445
instructions.  We peek at the arguments to decide what kind of
 
446
comparison to do.
 
447
 
 
448
ALPHA: For comparisons with 0, we're laughing, because we can just do
 
449
the desired conditional branch.
 
450
 
 
451
-}
 
452
 
 
453
 
 
454
genCondJump
 
455
    :: BlockId      -- the branch target
 
456
    -> CmmExpr      -- the condition on which to branch
 
457
    -> NatM InstrBlock
 
458
 
 
459
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 
460
 
 
461
genCondJump id (StPrim op [x, StInt 0])
 
462
  = getRegister x                           `thenNat` \ register ->
 
463
    getNewRegNat (registerRep register)
 
464
                                    `thenNat` \ tmp ->
 
465
    let
 
466
        code   = registerCode register tmp
 
467
        value  = registerName register tmp
 
468
        pk     = registerRep register
 
469
        target = ImmCLbl lbl
 
470
    in
 
471
    returnSeq code [BI (cmpOp op) value target]
 
472
  where
 
473
    cmpOp CharGtOp = GTT
 
474
    cmpOp CharGeOp = GE
 
475
    cmpOp CharEqOp = EQQ
 
476
    cmpOp CharNeOp = NE
 
477
    cmpOp CharLtOp = LTT
 
478
    cmpOp CharLeOp = LE
 
479
    cmpOp IntGtOp = GTT
 
480
    cmpOp IntGeOp = GE
 
481
    cmpOp IntEqOp = EQQ
 
482
    cmpOp IntNeOp = NE
 
483
    cmpOp IntLtOp = LTT
 
484
    cmpOp IntLeOp = LE
 
485
    cmpOp WordGtOp = NE
 
486
    cmpOp WordGeOp = ALWAYS
 
487
    cmpOp WordEqOp = EQQ
 
488
    cmpOp WordNeOp = NE
 
489
    cmpOp WordLtOp = NEVER
 
490
    cmpOp WordLeOp = EQQ
 
491
    cmpOp AddrGtOp = NE
 
492
    cmpOp AddrGeOp = ALWAYS
 
493
    cmpOp AddrEqOp = EQQ
 
494
    cmpOp AddrNeOp = NE
 
495
    cmpOp AddrLtOp = NEVER
 
496
    cmpOp AddrLeOp = EQQ
 
497
 
 
498
genCondJump lbl (StPrim op [x, StDouble 0.0])
 
499
  = getRegister x                           `thenNat` \ register ->
 
500
    getNewRegNat (registerRep register)
 
501
                                    `thenNat` \ tmp ->
 
502
    let
 
503
        code   = registerCode register tmp
 
504
        value  = registerName register tmp
 
505
        pk     = registerRep register
 
506
        target = ImmCLbl lbl
 
507
    in
 
508
    return (code . mkSeqInstr (BF (cmpOp op) value target))
 
509
  where
 
510
    cmpOp FloatGtOp = GTT
 
511
    cmpOp FloatGeOp = GE
 
512
    cmpOp FloatEqOp = EQQ
 
513
    cmpOp FloatNeOp = NE
 
514
    cmpOp FloatLtOp = LTT
 
515
    cmpOp FloatLeOp = LE
 
516
    cmpOp DoubleGtOp = GTT
 
517
    cmpOp DoubleGeOp = GE
 
518
    cmpOp DoubleEqOp = EQQ
 
519
    cmpOp DoubleNeOp = NE
 
520
    cmpOp DoubleLtOp = LTT
 
521
    cmpOp DoubleLeOp = LE
 
522
 
 
523
genCondJump lbl (StPrim op [x, y])
 
524
  | fltCmpOp op
 
525
  = trivialFCode pr instr x y       `thenNat` \ register ->
 
526
    getNewRegNat FF64               `thenNat` \ tmp ->
 
527
    let
 
528
        code   = registerCode register tmp
 
529
        result = registerName register tmp
 
530
        target = ImmCLbl lbl
 
531
    in
 
532
    return (code . mkSeqInstr (BF cond result target))
 
533
  where
 
534
    pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
 
535
 
 
536
    fltCmpOp op = case op of
 
537
        FloatGtOp -> True
 
538
        FloatGeOp -> True
 
539
        FloatEqOp -> True
 
540
        FloatNeOp -> True
 
541
        FloatLtOp -> True
 
542
        FloatLeOp -> True
 
543
        DoubleGtOp -> True
 
544
        DoubleGeOp -> True
 
545
        DoubleEqOp -> True
 
546
        DoubleNeOp -> True
 
547
        DoubleLtOp -> True
 
548
        DoubleLeOp -> True
 
549
        _ -> False
 
550
    (instr, cond) = case op of
 
551
        FloatGtOp -> (FCMP TF LE, EQQ)
 
552
        FloatGeOp -> (FCMP TF LTT, EQQ)
 
553
        FloatEqOp -> (FCMP TF EQQ, NE)
 
554
        FloatNeOp -> (FCMP TF EQQ, EQQ)
 
555
        FloatLtOp -> (FCMP TF LTT, NE)
 
556
        FloatLeOp -> (FCMP TF LE, NE)
 
557
        DoubleGtOp -> (FCMP TF LE, EQQ)
 
558
        DoubleGeOp -> (FCMP TF LTT, EQQ)
 
559
        DoubleEqOp -> (FCMP TF EQQ, NE)
 
560
        DoubleNeOp -> (FCMP TF EQQ, EQQ)
 
561
        DoubleLtOp -> (FCMP TF LTT, NE)
 
562
        DoubleLeOp -> (FCMP TF LE, NE)
 
563
 
 
564
genCondJump lbl (StPrim op [x, y])
 
565
  = trivialCode instr x y           `thenNat` \ register ->
 
566
    getNewRegNat IntRep             `thenNat` \ tmp ->
 
567
    let
 
568
        code   = registerCode register tmp
 
569
        result = registerName register tmp
 
570
        target = ImmCLbl lbl
 
571
    in
 
572
    return (code . mkSeqInstr (BI cond result target))
 
573
  where
 
574
    (instr, cond) = case op of
 
575
        CharGtOp -> (CMP LE, EQQ)
 
576
        CharGeOp -> (CMP LTT, EQQ)
 
577
        CharEqOp -> (CMP EQQ, NE)
 
578
        CharNeOp -> (CMP EQQ, EQQ)
 
579
        CharLtOp -> (CMP LTT, NE)
 
580
        CharLeOp -> (CMP LE, NE)
 
581
        IntGtOp -> (CMP LE, EQQ)
 
582
        IntGeOp -> (CMP LTT, EQQ)
 
583
        IntEqOp -> (CMP EQQ, NE)
 
584
        IntNeOp -> (CMP EQQ, EQQ)
 
585
        IntLtOp -> (CMP LTT, NE)
 
586
        IntLeOp -> (CMP LE, NE)
 
587
        WordGtOp -> (CMP ULE, EQQ)
 
588
        WordGeOp -> (CMP ULT, EQQ)
 
589
        WordEqOp -> (CMP EQQ, NE)
 
590
        WordNeOp -> (CMP EQQ, EQQ)
 
591
        WordLtOp -> (CMP ULT, NE)
 
592
        WordLeOp -> (CMP ULE, NE)
 
593
        AddrGtOp -> (CMP ULE, EQQ)
 
594
        AddrGeOp -> (CMP ULT, EQQ)
 
595
        AddrEqOp -> (CMP EQQ, NE)
 
596
        AddrNeOp -> (CMP EQQ, EQQ)
 
597
        AddrLtOp -> (CMP ULT, NE)
 
598
        AddrLeOp -> (CMP ULE, NE)
 
599
 
 
600
-- -----------------------------------------------------------------------------
 
601
--  Generating C calls
 
602
 
 
603
-- Now the biggest nightmare---calls.  Most of the nastiness is buried in
 
604
-- @get_arg@, which moves the arguments to the correct registers/stack
 
605
-- locations.  Apart from that, the code is easy.
 
606
-- 
 
607
-- (If applicable) Do not fill the delay slots here; you will confuse the
 
608
-- register allocator.
 
609
 
 
610
genCCall
 
611
    :: CmmCallTarget            -- function to call
 
612
    -> HintedCmmFormals         -- where to put the result
 
613
    -> HintedCmmActuals         -- arguments (of mixed type)
 
614
    -> NatM InstrBlock
 
615
 
 
616
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 
617
 
 
618
ccallResultRegs = 
 
619
 
 
620
genCCall fn cconv result_regs args
 
621
  = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
 
622
                          `thenNat` \ ((unused,_), argCode) ->
 
623
    let
 
624
        nRegs = length allArgRegs - length unused
 
625
        code = asmSeqThen (map ($ []) argCode)
 
626
    in
 
627
        returnSeq code [
 
628
            LDA pv (AddrImm (ImmLab (ptext fn))),
 
629
            JSR ra (AddrReg pv) nRegs,
 
630
            LDGP gp (AddrReg ra)]
 
631
  where
 
632
    ------------------------
 
633
    {-  Try to get a value into a specific register (or registers) for
 
634
        a call.  The first 6 arguments go into the appropriate
 
635
        argument register (separate registers for integer and floating
 
636
        point arguments, but used in lock-step), and the remaining
 
637
        arguments are dumped to the stack, beginning at 0(sp).  Our
 
638
        first argument is a pair of the list of remaining argument
 
639
        registers to be assigned for this call and the next stack
 
640
        offset to use for overflowing arguments.  This way,
 
641
        @get_Arg@ can be applied to all of a call's arguments using
 
642
        @mapAccumLNat@.
 
643
    -}
 
644
    get_arg
 
645
        :: ([(Reg,Reg)], Int)   -- Argument registers and stack offset (accumulator)
 
646
        -> StixTree             -- Current argument
 
647
        -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
 
648
 
 
649
    -- We have to use up all of our argument registers first...
 
650
 
 
651
    get_arg ((iDst,fDst):dsts, offset) arg
 
652
      = getRegister arg                     `thenNat` \ register ->
 
653
        let
 
654
            reg  = if isFloatType pk then fDst else iDst
 
655
            code = registerCode register reg
 
656
            src  = registerName register reg
 
657
            pk   = registerRep register
 
658
        in
 
659
        return (
 
660
            if isFloatType pk then
 
661
                ((dsts, offset), if isFixed register then
 
662
                    code . mkSeqInstr (FMOV src fDst)
 
663
                    else code)
 
664
            else
 
665
                ((dsts, offset), if isFixed register then
 
666
                    code . mkSeqInstr (OR src (RIReg src) iDst)
 
667
                    else code))
 
668
 
 
669
    -- Once we have run out of argument registers, we move to the
 
670
    -- stack...
 
671
 
 
672
    get_arg ([], offset) arg
 
673
      = getRegister arg                 `thenNat` \ register ->
 
674
        getNewRegNat (registerRep register)
 
675
                                        `thenNat` \ tmp ->
 
676
        let
 
677
            code = registerCode register tmp
 
678
            src  = registerName register tmp
 
679
            pk   = registerRep register
 
680
            sz   = primRepToSize pk
 
681
        in
 
682
        return (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
 
683
 
 
684
trivialCode instr x (StInt y)
 
685
  | fits8Bits y
 
686
  = getRegister x               `thenNat` \ register ->
 
687
    getNewRegNat IntRep         `thenNat` \ tmp ->
 
688
    let
 
689
        code = registerCode register tmp
 
690
        src1 = registerName register tmp
 
691
        src2 = ImmInt (fromInteger y)
 
692
        code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
 
693
    in
 
694
    return (Any IntRep code__2)
 
695
 
 
696
trivialCode instr x y
 
697
  = getRegister x               `thenNat` \ register1 ->
 
698
    getRegister y               `thenNat` \ register2 ->
 
699
    getNewRegNat IntRep         `thenNat` \ tmp1 ->
 
700
    getNewRegNat IntRep         `thenNat` \ tmp2 ->
 
701
    let
 
702
        code1 = registerCode register1 tmp1 []
 
703
        src1  = registerName register1 tmp1
 
704
        code2 = registerCode register2 tmp2 []
 
705
        src2  = registerName register2 tmp2
 
706
        code__2 dst = asmSeqThen [code1, code2] .
 
707
                     mkSeqInstr (instr src1 (RIReg src2) dst)
 
708
    in
 
709
    return (Any IntRep code__2)
 
710
 
 
711
------------
 
712
trivialUCode instr x
 
713
  = getRegister x               `thenNat` \ register ->
 
714
    getNewRegNat IntRep         `thenNat` \ tmp ->
 
715
    let
 
716
        code = registerCode register tmp
 
717
        src  = registerName register tmp
 
718
        code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
 
719
    in
 
720
    return (Any IntRep code__2)
 
721
 
 
722
------------
 
723
trivialFCode _ instr x y
 
724
  = getRegister x               `thenNat` \ register1 ->
 
725
    getRegister y               `thenNat` \ register2 ->
 
726
    getNewRegNat FF64   `thenNat` \ tmp1 ->
 
727
    getNewRegNat FF64   `thenNat` \ tmp2 ->
 
728
    let
 
729
        code1 = registerCode register1 tmp1
 
730
        src1  = registerName register1 tmp1
 
731
 
 
732
        code2 = registerCode register2 tmp2
 
733
        src2  = registerName register2 tmp2
 
734
 
 
735
        code__2 dst = asmSeqThen [code1 [], code2 []] .
 
736
                      mkSeqInstr (instr src1 src2 dst)
 
737
    in
 
738
    return (Any FF64 code__2)
 
739
 
 
740
trivialUFCode _ instr x
 
741
  = getRegister x               `thenNat` \ register ->
 
742
    getNewRegNat FF64   `thenNat` \ tmp ->
 
743
    let
 
744
        code = registerCode register tmp
 
745
        src  = registerName register tmp
 
746
        code__2 dst = code . mkSeqInstr (instr src dst)
 
747
    in
 
748
    return (Any FF64 code__2)
 
749
 
 
750
#if alpha_TARGET_ARCH
 
751
 
 
752
coerceInt2FP _ x
 
753
  = getRegister x               `thenNat` \ register ->
 
754
    getNewRegNat IntRep         `thenNat` \ reg ->
 
755
    let
 
756
        code = registerCode register reg
 
757
        src  = registerName register reg
 
758
 
 
759
        code__2 dst = code . mkSeqInstrs [
 
760
            ST Q src (spRel 0),
 
761
            LD TF dst (spRel 0),
 
762
            CVTxy Q TF dst dst]
 
763
    in
 
764
    return (Any FF64 code__2)
 
765
 
 
766
-------------
 
767
coerceFP2Int x
 
768
  = getRegister x               `thenNat` \ register ->
 
769
    getNewRegNat FF64   `thenNat` \ tmp ->
 
770
    let
 
771
        code = registerCode register tmp
 
772
        src  = registerName register tmp
 
773
 
 
774
        code__2 dst = code . mkSeqInstrs [
 
775
            CVTxy TF Q src tmp,
 
776
            ST TF tmp (spRel 0),
 
777
            LD Q dst (spRel 0)]
 
778
    in
 
779
    return (Any IntRep code__2)
 
780
 
 
781
#endif /* alpha_TARGET_ARCH */
 
782
 
 
783
 
 
784
-}
 
785
 
 
786
 
 
787
 
 
788
 
 
789