[project @ 2002-03-12 16:48:52 by simonmar]
[ghc-hetmet.git] / ghc / compiler / nativeGen / MachCode.lhs
1 %
2 % (c) The AQUA Project, Glasgow University, 1996-1998
3 %
4 \section[MachCode]{Generating machine code}
5
6 This is a big module, but, if you pay attention to
7 (a) the sectioning, (b) the type signatures, and
8 (c) the \tr{#if blah_TARGET_ARCH} things, the
9 structure should not be too overwhelming.
10
11 \begin{code}
12 module MachCode ( stmtsToInstrs, InstrBlock ) where
13
14 #include "HsVersions.h"
15 #include "nativeGen/NCG.h"
16
17 import Unique           ( Unique )
18 import MachMisc         -- may differ per-platform
19 import MachRegs
20 import OrdList          ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
21                           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 #if sparc_TARGET_ARCH || alpha_TARGET_ARCH
28 import CLabel           ( isAsmTemp )
29 #endif
30 import Maybes           ( maybeToBool )
31 import PrimRep          ( isFloatingRep, is64BitRep, PrimRep(..),
32                           getPrimRepArrayElemSize )
33 import Stix             ( getNatLabelNCG, StixStmt(..), StixExpr(..),
34                           StixReg(..), pprStixReg, StixVReg(..), CodeSegment(..), 
35                           DestInfo, hasDestInfo,
36                           pprStixExpr, repOfStixExpr,
37                           liftStrings,
38                           NatM, thenNat, returnNat, mapNat, 
39                           mapAndUnzipNat, mapAccumLNat,
40                           getDeltaNat, setDeltaNat, getUniqueNat,
41                           ncgPrimopMoan,
42                           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 -- DEBUGGING ONLY
51 import IOExts           ( trace )
52 import Outputable       ( assertPanic )
53
54 infixr 3 `bind`
55 \end{code}
56
57 @InstrBlock@s are the insn sequences generated by the insn selectors.
58 They are really trees of insns to facilitate fast appending, where a
59 left-to-right traversal (pre-order?) yields the insns in the correct
60 order.
61
62 \begin{code}
63 type InstrBlock = OrdList Instr
64
65 x `bind` f = f x
66
67 isLeft (Left _)  = True
68 isLeft (Right _) = False
69
70 unLeft (Left x) = x
71 \end{code}
72
73 Code extractor for an entire stix tree---stix statement level.
74
75 \begin{code}
76 stmtsToInstrs :: [StixStmt] -> NatM InstrBlock
77 stmtsToInstrs stmts
78    = mapNat stmtToInstrs stmts          `thenNat` \ instrss ->
79      returnNat (concatOL instrss)
80
81
82 stmtToInstrs :: StixStmt -> NatM InstrBlock
83 stmtToInstrs stmt = case stmt of
84     StComment s    -> returnNat (unitOL (COMMENT s))
85     StSegment seg  -> returnNat (unitOL (SEGMENT seg))
86
87     StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab,
88                                                        LABEL lab)))
89     StFunEnd lab   -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)),
90                                     returnNat nilOL)
91
92     StLabel lab    -> returnNat (unitOL (LABEL lab))
93
94     StJump dsts arg        -> genJump dsts (derefDLL arg)
95     StCondJump lab arg     -> genCondJump lab (derefDLL arg)
96
97     -- A call returning void, ie one done for its side-effects.  Note
98     -- that this is the only StVoidable we handle.
99     StVoidable (StCall fn cconv VoidRep args) 
100        -> genCCall fn cconv VoidRep (map derefDLL args)
101
102     StAssignMem pk addr src
103       | isFloatingRep pk -> assignMem_FltCode pk (derefDLL addr) (derefDLL src)
104       | ncg_target_is_32bit
105         && is64BitRep pk -> assignMem_I64Code    (derefDLL addr) (derefDLL src)
106       | otherwise        -> assignMem_IntCode pk (derefDLL addr) (derefDLL src)
107     StAssignReg pk reg src
108       | isFloatingRep pk -> assignReg_FltCode pk reg (derefDLL src)
109       | ncg_target_is_32bit
110         && is64BitRep pk -> assignReg_I64Code    reg (derefDLL src)
111       | otherwise        -> assignReg_IntCode pk reg (derefDLL src)
112
113     StFallThrough lbl
114         -- When falling through on the Alpha, we still have to load pv
115         -- with the address of the next routine, so that it can load gp.
116       -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
117         ,returnNat nilOL)
118
119     StData kind args
120       -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) ->
121          returnNat (DATA (primRepToSize kind) imms  
122                     `consOL`  concatOL codes)
123       where
124         getData :: StixExpr -> NatM (InstrBlock, Imm)
125         getData (StInt i)        = returnNat (nilOL, ImmInteger i)
126         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         -- the linker can handle simple arithmetic...
131         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     -- (see Stix.liftStrings).
137     StDataString str
138       -> returnNat (unitOL (ASCII True (_UNPK_ str)))
139
140 #ifdef DEBUG
141     other -> pprPanic "stmtToInstrs" (pprStixStmt other)
142 #endif
143
144 -- Walk a Stix tree, and insert dereferences to CLabels which are marked
145 -- as labelDynamic.  stmt2Instrs calls derefDLL selectively, because
146 -- not all such CLabel occurrences need this dereferencing -- SRTs don't
147 -- for one.
148 derefDLL :: StixExpr -> StixExpr
149 derefDLL tree
150    | opt_Static   -- short out the entire deal if not doing DLLs
151    = tree
152    | otherwise
153    = qq tree
154      where
155         qq t
156            = case t of
157                 StCLbl lbl -> if   labelDynamic lbl
158                               then StInd PtrRep (StCLbl lbl)
159                               else t
160                 -- all the rest are boring
161                 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                 StCall (Left nm) cc pk args -> StCall (Left nm) cc pk (map qq args)
165                 StCall (Right f) cc pk args -> StCall (Right (qq f)) cc pk (map qq args)
166                 StInt    _             -> t
167                 StFloat  _             -> t
168                 StDouble _             -> t
169                 StString _             -> t
170                 StReg    _             -> t
171                 _                      -> pprPanic "derefDLL: unhandled case" 
172                                                    (pprStixExpr t)
173 \end{code}
174
175 %************************************************************************
176 %*                                                                      *
177 \subsection{General things for putting together code sequences}
178 %*                                                                      *
179 %************************************************************************
180
181 \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        base,
192        let s = shift pk
193        in  if s == 0 then off 
194                      else StMachOp MO_Nat_Shl [off, StInt (toInteger s)]
195     ]
196   where
197     shift :: PrimRep -> Int
198     shift rep = case getPrimRepArrayElemSize rep of
199                    1 -> 0
200                    2 -> 1
201                    4 -> 2
202                    8 -> 3
203                    other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size" 
204                                      (Outputable.int other)
205 \end{code}
206
207 \begin{code}
208 maybeImm :: StixExpr -> Maybe Imm
209
210 maybeImm (StCLbl l)       
211    = Just (ImmCLbl l)
212 maybeImm (StIndex rep (StCLbl l) (StInt off)) 
213    = Just (ImmIndex l (fromInteger off * getPrimRepArrayElemSize rep))
214 maybeImm (StInt i)
215   | i >= toInteger (minBound::Int) && i <= toInteger (maxBound::Int)
216   = Just (ImmInt (fromInteger i))
217   | otherwise
218   = Just (ImmInteger i)
219
220 maybeImm _ = Nothing
221 \end{code}
222
223 %************************************************************************
224 %*                                                                      *
225 \subsection{The @Register64@ type}
226 %*                                                                      *
227 %************************************************************************
228
229 Simple support for generating 64-bit code (ie, 64 bit values and 64
230 bit assignments) on 32-bit platforms.  Unlike the main code generator
231 we merely shoot for generating working code as simply as possible, and
232 pay little attention to code quality.  Specifically, there is no
233 attempt to deal cleverly with the fixed-vs-floating register
234 distinction; all values are generated into (pairs of) floating
235 registers, even if this would mean some redundant reg-reg moves as a
236 result.  Only one of the VRegUniques is returned, since it will be
237 of the VRegUniqueLo form, and the upper-half VReg can be determined
238 by applying getHiVRegFromLo to it.
239
240 \begin{code}
241
242 data ChildCode64        -- a.k.a "Register64"
243    = ChildCode64 
244         InstrBlock      -- code
245         VRegUnique      -- unique for the lower 32-bit temporary
246         -- which contains the result; use getHiVRegFromLo to find
247         -- the other VRegUnique.
248         -- Rules of this simplified insn selection game are
249         -- therefore that the returned VRegUnique may be modified
250
251 assignMem_I64Code :: StixExpr -> StixExpr -> NatM InstrBlock
252 assignReg_I64Code :: StixReg  -> StixExpr -> NatM InstrBlock
253 iselExpr64        :: StixExpr -> NatM ChildCode64
254
255 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
256
257 #if i386_TARGET_ARCH
258
259 assignMem_I64Code addrTree valueTree
260    = iselExpr64 valueTree               `thenNat` \ (ChildCode64 vcode vrlo) ->
261      getRegister addrTree               `thenNat` \ register_addr ->
262      getNewRegNCG IntRep                `thenNat` \ t_addr ->
263      let rlo = VirtualRegI vrlo
264          rhi = getHiVRegFromLo rlo
265          code_addr = registerCode register_addr t_addr
266          reg_addr  = registerName register_addr t_addr
267          -- Little-endian store
268          mov_lo = MOV L (OpReg rlo)
269                         (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
270          mov_hi = MOV L (OpReg rhi)
271                         (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
272      in
273          returnNat (vcode `appOL` code_addr `snocOL` mov_lo `snocOL` mov_hi)
274
275 assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
276    = iselExpr64 valueTree               `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
277      let 
278          r_dst_lo = mkVReg u_dst IntRep
279          r_src_lo = VirtualRegI vr_src_lo
280          r_dst_hi = getHiVRegFromLo r_dst_lo
281          r_src_hi = getHiVRegFromLo r_src_lo
282          mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
283          mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
284      in
285          returnNat (
286             vcode `snocOL` mov_lo `snocOL` mov_hi
287          )
288
289 assignReg_I64Code lvalue valueTree
290    = pprPanic "assignReg_I64Code(i386): invalid lvalue"
291               (pprStixReg lvalue)
292
293
294
295 iselExpr64 (StInd pk addrTree)
296    | is64BitRep pk
297    = getRegister addrTree               `thenNat` \ register_addr ->
298      getNewRegNCG IntRep                `thenNat` \ t_addr ->
299      getNewRegNCG IntRep                `thenNat` \ rlo ->
300      let rhi = getHiVRegFromLo rlo
301          code_addr = registerCode register_addr t_addr
302          reg_addr  = registerName register_addr t_addr
303          mov_lo = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0)))
304                         (OpReg rlo)
305          mov_hi = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4)))
306                         (OpReg rhi)
307      in
308          returnNat (
309             ChildCode64 (code_addr `snocOL` mov_lo `snocOL` mov_hi) 
310                         (getVRegUnique rlo)
311          )
312
313 iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
314    | is64BitRep pk
315    = getNewRegNCG IntRep                `thenNat` \ r_dst_lo ->
316      let r_dst_hi = getHiVRegFromLo r_dst_lo
317          r_src_lo = mkVReg vu IntRep
318          r_src_hi = getHiVRegFromLo r_src_lo
319          mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo)
320          mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi)
321      in
322          returnNat (
323             ChildCode64 (toOL [mov_lo, mov_hi]) (getVRegUnique r_dst_lo)
324          )
325          
326 iselExpr64 (StCall fn cconv kind args)
327   | is64BitRep kind
328   = genCCall fn cconv kind args                 `thenNat` \ call ->
329     getNewRegNCG IntRep                         `thenNat` \ r_dst_lo ->
330     let r_dst_hi = getHiVRegFromLo r_dst_lo
331         mov_lo = MOV L (OpReg eax) (OpReg r_dst_lo)
332         mov_hi = MOV L (OpReg edx) (OpReg r_dst_hi)
333     in
334     returnNat (
335        ChildCode64 (call `snocOL` mov_lo `snocOL` mov_hi) 
336                    (getVRegUnique r_dst_lo)
337     )
338
339 iselExpr64 expr
340    = pprPanic "iselExpr64(i386)" (pprStixExpr expr)
341
342 #endif {- i386_TARGET_ARCH -}
343
344 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
345
346 #if sparc_TARGET_ARCH
347
348 assignMem_I64Code addrTree valueTree
349    = iselExpr64 valueTree               `thenNat` \ (ChildCode64 vcode vrlo) ->
350      getRegister addrTree               `thenNat` \ register_addr ->
351      getNewRegNCG IntRep                `thenNat` \ t_addr ->
352      let rlo = VirtualRegI vrlo
353          rhi = getHiVRegFromLo rlo
354          code_addr = registerCode register_addr t_addr
355          reg_addr  = registerName register_addr t_addr
356          -- Big-endian store
357          mov_hi = ST W rhi (AddrRegImm reg_addr (ImmInt 0))
358          mov_lo = ST W rlo (AddrRegImm reg_addr (ImmInt 4))
359      in
360          returnNat (vcode `appOL` code_addr `snocOL` mov_hi `snocOL` mov_lo)
361
362
363 assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
364    = iselExpr64 valueTree               `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
365      let 
366          r_dst_lo = mkVReg u_dst IntRep
367          r_src_lo = VirtualRegI vr_src_lo
368          r_dst_hi = getHiVRegFromLo r_dst_lo
369          r_src_hi = getHiVRegFromLo r_src_lo
370          mov_lo = mkMOV r_src_lo r_dst_lo
371          mov_hi = mkMOV r_src_hi r_dst_hi
372          mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
373      in
374          returnNat (
375             vcode `snocOL` mov_hi `snocOL` mov_lo
376          )
377 assignReg_I64Code lvalue valueTree
378    = pprPanic "assignReg_I64Code(sparc): invalid lvalue"
379               (pprStixReg lvalue)
380
381
382 -- Don't delete this -- it's very handy for debugging.
383 --iselExpr64 expr 
384 --   | trace ("iselExpr64: " ++ showSDoc (pprStixExpr expr)) False
385 --   = panic "iselExpr64(???)"
386
387 iselExpr64 (StInd pk addrTree)
388    | is64BitRep pk
389    = getRegister addrTree               `thenNat` \ register_addr ->
390      getNewRegNCG IntRep                `thenNat` \ t_addr ->
391      getNewRegNCG IntRep                `thenNat` \ rlo ->
392      let rhi = getHiVRegFromLo rlo
393          code_addr = registerCode register_addr t_addr
394          reg_addr  = registerName register_addr t_addr
395          mov_hi = LD W (AddrRegImm reg_addr (ImmInt 0)) rhi
396          mov_lo = LD W (AddrRegImm reg_addr (ImmInt 4)) rlo
397      in
398          returnNat (
399             ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo) 
400                         (getVRegUnique rlo)
401          )
402
403 iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
404    | is64BitRep pk
405    = getNewRegNCG IntRep                `thenNat` \ r_dst_lo ->
406      let r_dst_hi = getHiVRegFromLo r_dst_lo
407          r_src_lo = mkVReg vu IntRep
408          r_src_hi = getHiVRegFromLo r_src_lo
409          mov_lo = mkMOV r_src_lo r_dst_lo
410          mov_hi = mkMOV r_src_hi r_dst_hi
411          mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
412      in
413          returnNat (
414             ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo)
415          )
416
417 iselExpr64 (StCall fn cconv kind args)
418   | is64BitRep kind
419   = genCCall fn cconv kind args                 `thenNat` \ call ->
420     getNewRegNCG IntRep                         `thenNat` \ r_dst_lo ->
421     let r_dst_hi = getHiVRegFromLo r_dst_lo
422         mov_lo = mkMOV o0 r_dst_lo
423         mov_hi = mkMOV o1 r_dst_hi
424         mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
425     in
426     returnNat (
427        ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo) 
428                    (getVRegUnique r_dst_lo)
429     )
430
431 iselExpr64 expr
432    = pprPanic "iselExpr64(sparc)" (pprStixExpr expr)
433
434 #endif {- sparc_TARGET_ARCH -}
435
436 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
437
438 \end{code}
439
440 %************************************************************************
441 %*                                                                      *
442 \subsection{The @Register@ type}
443 %*                                                                      *
444 %************************************************************************
445
446 @Register@s passed up the tree.  If the stix code forces the register
447 to live in a pre-decided machine register, it comes out as @Fixed@;
448 otherwise, it comes out as @Any@, and the parent can decide which
449 register to put it in.
450
451 \begin{code}
452 data Register
453   = Fixed   PrimRep Reg InstrBlock
454   | Any     PrimRep (Reg -> InstrBlock)
455
456 registerCode :: Register -> Reg -> InstrBlock
457 registerCode (Fixed _ _ code) reg = code
458 registerCode (Any _ code) reg = code reg
459
460 registerCodeF (Fixed _ _ code) = code
461 registerCodeF (Any _ _)        = panic "registerCodeF"
462
463 registerCodeA (Any _ code)  = code
464 registerCodeA (Fixed _ _ _) = panic "registerCodeA"
465
466 registerName :: Register -> Reg -> Reg
467 registerName (Fixed _ reg _) _ = reg
468 registerName (Any _ _)   reg   = reg
469
470 registerNameF (Fixed _ reg _) = reg
471 registerNameF (Any _ _)       = panic "registerNameF"
472
473 registerRep :: Register -> PrimRep
474 registerRep (Fixed pk _ _) = pk
475 registerRep (Any   pk _) = pk
476
477 swizzleRegisterRep :: Register -> PrimRep -> Register
478 swizzleRegisterRep (Fixed _ reg code) rep = Fixed rep reg code
479 swizzleRegisterRep (Any _ codefn)     rep = Any rep codefn
480
481 {-# INLINE registerCode  #-}
482 {-# INLINE registerCodeF #-}
483 {-# INLINE registerName  #-}
484 {-# INLINE registerNameF #-}
485 {-# INLINE registerRep   #-}
486 {-# INLINE isFixed       #-}
487 {-# INLINE isAny         #-}
488
489 isFixed, isAny :: Register -> Bool
490 isFixed (Fixed _ _ _) = True
491 isFixed (Any _ _)     = False
492
493 isAny = not . isFixed
494 \end{code}
495
496 Generate code to get a subtree into a @Register@:
497 \begin{code}
498
499 getRegisterReg :: StixReg -> NatM Register
500 getRegister :: StixExpr -> NatM Register
501
502
503 getRegisterReg (StixMagicId mid)
504   = case get_MagicId_reg_or_addr mid of
505        Left (RealReg rrno) 
506           -> let pk = magicIdPrimRep mid
507              in  returnNat (Fixed pk (RealReg rrno) nilOL)
508        Right baseRegAddr 
509           -- By this stage, the only MagicIds remaining should be the
510           -- ones which map to a real machine register on this platform.  Hence ...
511           -> pprPanic "getRegisterReg-memory" (pprMagicId mid)
512
513 getRegisterReg (StixTemp (StixVReg u pk))
514   = returnNat (Fixed pk (mkVReg u pk) nilOL)
515
516 -------------
517
518 -- Don't delete this -- it's very handy for debugging.
519 --getRegister expr 
520 --   | trace ("getRegiste: " ++ showSDoc (pprStixExpr expr)) False
521 --   = panic "getRegister(???)"
522
523 getRegister (StReg reg) 
524   = getRegisterReg reg
525
526 getRegister tree@(StIndex _ _ _) 
527   = getRegister (mangleIndexTree tree)
528
529 getRegister (StCall fn cconv kind args)
530   | not (ncg_target_is_32bit && is64BitRep kind)
531   = genCCall fn cconv kind args             `thenNat` \ call ->
532     returnNat (Fixed kind reg call)
533   where
534     reg = if isFloatingRep kind
535           then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,)))
536           else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
537
538 getRegister (StString s)
539   = getNatLabelNCG                  `thenNat` \ lbl ->
540     let
541         imm_lbl = ImmCLbl lbl
542
543         code dst = toOL [
544             SEGMENT RoDataSegment,
545             LABEL lbl,
546             ASCII True (_UNPK_ s),
547             SEGMENT TextSegment,
548 #if alpha_TARGET_ARCH
549             LDA dst (AddrImm imm_lbl)
550 #endif
551 #if i386_TARGET_ARCH
552             MOV L (OpImm imm_lbl) (OpReg dst)
553 #endif
554 #if sparc_TARGET_ARCH
555             SETHI (HI imm_lbl) dst,
556             OR False dst (RIImm (LO imm_lbl)) dst
557 #endif
558             ]
559     in
560     returnNat (Any PtrRep code)
561
562 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
563 -- end of machine-"independent" bit; here we go on the rest...
564
565 #if alpha_TARGET_ARCH
566
567 getRegister (StDouble d)
568   = getNatLabelNCG                  `thenNat` \ lbl ->
569     getNewRegNCG PtrRep             `thenNat` \ tmp ->
570     let code dst = mkSeqInstrs [
571             SEGMENT DataSegment,
572             LABEL lbl,
573             DATA TF [ImmLab (rational d)],
574             SEGMENT TextSegment,
575             LDA tmp (AddrImm (ImmCLbl lbl)),
576             LD TF dst (AddrReg tmp)]
577     in
578         returnNat (Any DoubleRep code)
579
580 getRegister (StPrim primop [x]) -- unary PrimOps
581   = case primop of
582       IntNegOp -> trivialUCode (NEG Q False) x
583
584       NotOp    -> trivialUCode NOT x
585
586       FloatNegOp  -> trivialUFCode FloatRep  (FNEG TF) x
587       DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
588
589       OrdOp -> coerceIntCode IntRep x
590       ChrOp -> chrCode x
591
592       Float2IntOp  -> coerceFP2Int    x
593       Int2FloatOp  -> coerceInt2FP pr x
594       Double2IntOp -> coerceFP2Int    x
595       Int2DoubleOp -> coerceInt2FP pr x
596
597       Double2FloatOp -> coerceFltCode x
598       Float2DoubleOp -> coerceFltCode x
599
600       other_op -> getRegister (StCall fn CCallConv DoubleRep [x])
601         where
602           fn = case other_op of
603                  FloatExpOp    -> SLIT("exp")
604                  FloatLogOp    -> SLIT("log")
605                  FloatSqrtOp   -> SLIT("sqrt")
606                  FloatSinOp    -> SLIT("sin")
607                  FloatCosOp    -> SLIT("cos")
608                  FloatTanOp    -> SLIT("tan")
609                  FloatAsinOp   -> SLIT("asin")
610                  FloatAcosOp   -> SLIT("acos")
611                  FloatAtanOp   -> SLIT("atan")
612                  FloatSinhOp   -> SLIT("sinh")
613                  FloatCoshOp   -> SLIT("cosh")
614                  FloatTanhOp   -> SLIT("tanh")
615                  DoubleExpOp   -> SLIT("exp")
616                  DoubleLogOp   -> SLIT("log")
617                  DoubleSqrtOp  -> SLIT("sqrt")
618                  DoubleSinOp   -> SLIT("sin")
619                  DoubleCosOp   -> SLIT("cos")
620                  DoubleTanOp   -> SLIT("tan")
621                  DoubleAsinOp  -> SLIT("asin")
622                  DoubleAcosOp  -> SLIT("acos")
623                  DoubleAtanOp  -> SLIT("atan")
624                  DoubleSinhOp  -> SLIT("sinh")
625                  DoubleCoshOp  -> SLIT("cosh")
626                  DoubleTanhOp  -> SLIT("tanh")
627   where
628     pr = panic "MachCode.getRegister: no primrep needed for Alpha"
629
630 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
631   = 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       CharLeOp -> trivialCode (CMP LE) x y
638
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       IntLeOp  -> trivialCode (CMP LE) x y
645
646       WordGtOp -> trivialCode (CMP ULT) y x
647       WordGeOp -> trivialCode (CMP ULE) x y
648       WordEqOp -> trivialCode (CMP EQQ)  x y
649       WordNeOp -> int_NE_code x y
650       WordLtOp -> trivialCode (CMP ULT) x y
651       WordLeOp -> trivialCode (CMP ULE) x y
652
653       AddrGtOp -> trivialCode (CMP ULT) y x
654       AddrGeOp -> trivialCode (CMP ULE) y x
655       AddrEqOp -> trivialCode (CMP EQQ)  x y
656       AddrNeOp -> int_NE_code x y
657       AddrLtOp -> trivialCode (CMP ULT) x y
658       AddrLeOp -> trivialCode (CMP ULE) x y
659         
660       FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
661       FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
662       FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
663       FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
664       FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
665       FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
666
667       DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
668       DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
669       DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
670       DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
671       DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
672       DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
673
674       IntAddOp  -> trivialCode (ADD Q False) x y
675       IntSubOp  -> trivialCode (SUB Q False) x y
676       IntMulOp  -> trivialCode (MUL Q False) x y
677       IntQuotOp -> trivialCode (DIV Q False) x y
678       IntRemOp  -> trivialCode (REM Q False) x y
679
680       WordAddOp  -> trivialCode (ADD Q False) x y
681       WordSubOp  -> trivialCode (SUB Q False) x y
682       WordMulOp  -> trivialCode (MUL Q False) x y
683       WordQuotOp -> trivialCode (DIV Q True) x y
684       WordRemOp  -> trivialCode (REM Q True) x y
685
686       FloatAddOp -> trivialFCode  FloatRep (FADD TF) x y
687       FloatSubOp -> trivialFCode  FloatRep (FSUB TF) x y
688       FloatMulOp -> trivialFCode  FloatRep (FMUL TF) x y
689       FloatDivOp -> trivialFCode  FloatRep (FDIV TF) x y
690
691       DoubleAddOp -> trivialFCode  DoubleRep (FADD TF) x y
692       DoubleSubOp -> trivialFCode  DoubleRep (FSUB TF) x y
693       DoubleMulOp -> trivialFCode  DoubleRep (FMUL TF) x y
694       DoubleDivOp -> trivialFCode  DoubleRep (FDIV TF) x y
695
696       AddrAddOp  -> trivialCode (ADD Q False) x y
697       AddrSubOp  -> trivialCode (SUB Q False) x y
698       AddrRemOp  -> trivialCode (REM Q True) x y
699
700       AndOp  -> trivialCode AND x y
701       OrOp   -> trivialCode OR  x y
702       XorOp  -> trivialCode XOR x y
703       SllOp  -> trivialCode SLL x y
704       SrlOp  -> trivialCode SRL x y
705
706       ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
707       ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
708       ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
709
710       FloatPowerOp  -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
711       DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y])
712   where
713     {- ------------------------------------------------------------
714         Some bizarre special code for getting condition codes into
715         registers.  Integer non-equality is a test for equality
716         followed by an XOR with 1.  (Integer comparisons always set
717         the result register to 0 or 1.)  Floating point comparisons of
718         any kind leave the result in a floating point register, so we
719         need to wrangle an integer register out of things.
720     -}
721     int_NE_code :: StixTree -> StixTree -> NatM Register
722
723     int_NE_code x y
724       = trivialCode (CMP EQQ) x y       `thenNat` \ register ->
725         getNewRegNCG IntRep             `thenNat` \ tmp ->
726         let
727             code = registerCode register tmp
728             src  = registerName register tmp
729             code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
730         in
731         returnNat (Any IntRep code__2)
732
733     {- ------------------------------------------------------------
734         Comments for int_NE_code also apply to cmpF_code
735     -}
736     cmpF_code
737         :: (Reg -> Reg -> Reg -> Instr)
738         -> Cond
739         -> StixTree -> StixTree
740         -> NatM Register
741
742     cmpF_code instr cond x y
743       = trivialFCode pr instr x y       `thenNat` \ register ->
744         getNewRegNCG DoubleRep          `thenNat` \ tmp ->
745         getNatLabelNCG                  `thenNat` \ lbl ->
746         let
747             code = registerCode register tmp
748             result  = registerName register tmp
749
750             code__2 dst = code . mkSeqInstrs [
751                 OR zeroh (RIImm (ImmInt 1)) dst,
752                 BF cond  result (ImmCLbl lbl),
753                 OR zeroh (RIReg zeroh) dst,
754                 LABEL lbl]
755         in
756         returnNat (Any IntRep code__2)
757       where
758         pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
759       ------------------------------------------------------------
760
761 getRegister (StInd pk mem)
762   = getAmode mem                    `thenNat` \ amode ->
763     let
764         code = amodeCode amode
765         src   = amodeAddr amode
766         size = primRepToSize pk
767         code__2 dst = code . mkSeqInstr (LD size dst src)
768     in
769     returnNat (Any pk code__2)
770
771 getRegister (StInt i)
772   | fits8Bits i
773   = let
774         code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
775     in
776     returnNat (Any IntRep code)
777   | otherwise
778   = let
779         code dst = mkSeqInstr (LDI Q dst src)
780     in
781     returnNat (Any IntRep code)
782   where
783     src = ImmInt (fromInteger i)
784
785 getRegister leaf
786   | maybeToBool imm
787   = let
788         code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
789     in
790     returnNat (Any PtrRep code)
791   where
792     imm = maybeImm leaf
793     imm__2 = case imm of Just x -> x
794
795 #endif {- alpha_TARGET_ARCH -}
796
797 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
798
799 #if i386_TARGET_ARCH
800
801 getRegister (StFloat f)
802   = getNatLabelNCG                  `thenNat` \ lbl ->
803     let code dst = toOL [
804             SEGMENT DataSegment,
805             LABEL lbl,
806             DATA F [ImmFloat f],
807             SEGMENT TextSegment,
808             GLD F (ImmAddr (ImmCLbl lbl) 0) dst
809             ]
810     in
811     returnNat (Any FloatRep code)
812
813
814 getRegister (StDouble d)
815
816   | d == 0.0
817   = let code dst = unitOL (GLDZ dst)
818     in  returnNat (Any DoubleRep code)
819
820   | d == 1.0
821   = let code dst = unitOL (GLD1 dst)
822     in  returnNat (Any DoubleRep code)
823
824   | otherwise
825   = getNatLabelNCG                  `thenNat` \ lbl ->
826     let code dst = toOL [
827             SEGMENT DataSegment,
828             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 getRegister (StMachOp mop [x]) -- unary MachOps
838   = case mop of
839       MO_NatS_Neg  -> trivialUCode (NEGI L) x
840       MO_Nat_Not   -> trivialUCode (NOT L) x
841       MO_32U_to_8U -> trivialUCode (AND L (OpImm (ImmInt 255))) x
842
843       MO_Flt_Neg  -> trivialUFCode FloatRep  (GNEG F) x
844       MO_Dbl_Neg  -> trivialUFCode DoubleRep (GNEG DF) x
845
846       MO_Flt_Sqrt -> trivialUFCode FloatRep  (GSQRT F) x
847       MO_Dbl_Sqrt -> trivialUFCode DoubleRep (GSQRT DF) x
848
849       MO_Flt_Sin  -> trivialUFCode FloatRep  (GSIN F) x
850       MO_Dbl_Sin  -> trivialUFCode DoubleRep (GSIN DF) x
851
852       MO_Flt_Cos  -> trivialUFCode FloatRep  (GCOS F) x
853       MO_Dbl_Cos  -> trivialUFCode DoubleRep (GCOS DF) x
854
855       MO_Flt_Tan  -> trivialUFCode FloatRep  (GTAN F) x
856       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       -- Conversions which are a nop on x86
864       MO_NatS_to_32U  -> conversionNop WordRep   x
865       MO_32U_to_NatS  -> conversionNop IntRep    x
866
867       MO_NatU_to_NatS -> conversionNop IntRep    x
868       MO_NatS_to_NatU -> conversionNop WordRep   x
869       MO_NatP_to_NatU -> conversionNop WordRep   x
870       MO_NatU_to_NatP -> conversionNop PtrRep    x
871       MO_NatS_to_NatP -> conversionNop PtrRep    x
872       MO_NatP_to_NatS -> conversionNop IntRep    x
873
874       MO_Dbl_to_Flt   -> conversionNop FloatRep  x
875       MO_Flt_to_Dbl   -> conversionNop DoubleRep x
876
877       -- sign-extending widenings
878       MO_8U_to_NatU   -> integerExtend False 24 x
879       MO_8S_to_NatS   -> integerExtend True  24 x
880       MO_16U_to_NatU  -> integerExtend False 16 x
881       MO_16S_to_NatS  -> integerExtend True  16 x
882       MO_8U_to_32U    -> integerExtend False 24 x
883
884       other_op 
885          -> getRegister (
886                (if is_float_op then demote else id)
887                (StCall (Left fn) CCallConv DoubleRep 
888                        [(if is_float_op then promote else id) x])
889             )
890       where
891         integerExtend signed nBits x
892            = getRegister (
893                 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr) 
894                          [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
895              )
896
897         conversionNop new_rep expr
898             = getRegister expr          `thenNat` \ e_code ->
899               returnNat (swizzleRegisterRep e_code new_rep)
900
901         promote x = StMachOp MO_Flt_to_Dbl [x]
902         demote  x = StMachOp MO_Dbl_to_Flt [x]
903         (is_float_op, fn)
904           = case mop of
905               MO_Flt_Exp   -> (True,  SLIT("exp"))
906               MO_Flt_Log   -> (True,  SLIT("log"))
907
908               MO_Flt_Asin  -> (True,  SLIT("asin"))
909               MO_Flt_Acos  -> (True,  SLIT("acos"))
910               MO_Flt_Atan  -> (True,  SLIT("atan"))
911
912               MO_Flt_Sinh  -> (True,  SLIT("sinh"))
913               MO_Flt_Cosh  -> (True,  SLIT("cosh"))
914               MO_Flt_Tanh  -> (True,  SLIT("tanh"))
915
916               MO_Dbl_Exp   -> (False, SLIT("exp"))
917               MO_Dbl_Log   -> (False, SLIT("log"))
918
919               MO_Dbl_Asin  -> (False, SLIT("asin"))
920               MO_Dbl_Acos  -> (False, SLIT("acos"))
921               MO_Dbl_Atan  -> (False, SLIT("atan"))
922
923               MO_Dbl_Sinh  -> (False, SLIT("sinh"))
924               MO_Dbl_Cosh  -> (False, SLIT("cosh"))
925               MO_Dbl_Tanh  -> (False, SLIT("tanh"))
926
927               other -> pprPanic "getRegister(x86) - binary StMachOp (2)" 
928                                 (pprMachOp mop)
929
930
931 getRegister (StMachOp mop [x, y]) -- dyadic MachOps
932   = case mop of
933       MO_32U_Gt  -> condIntReg GTT x y
934       MO_32U_Ge  -> condIntReg GE x y
935       MO_32U_Eq  -> condIntReg EQQ x y
936       MO_32U_Ne  -> condIntReg NE x y
937       MO_32U_Lt  -> condIntReg LTT x y
938       MO_32U_Le  -> condIntReg LE x y
939
940       MO_Nat_Eq   -> condIntReg EQQ x y
941       MO_Nat_Ne   -> condIntReg NE x y
942
943       MO_NatS_Gt  -> condIntReg GTT x y
944       MO_NatS_Ge  -> condIntReg GE x y
945       MO_NatS_Lt  -> condIntReg LTT x y
946       MO_NatS_Le  -> condIntReg LE x y
947
948       MO_NatU_Gt  -> condIntReg GU  x y
949       MO_NatU_Ge  -> condIntReg GEU x y
950       MO_NatU_Lt  -> condIntReg LU  x y
951       MO_NatU_Le  -> condIntReg LEU x y
952
953       MO_Flt_Gt -> condFltReg GTT x y
954       MO_Flt_Ge -> condFltReg GE x y
955       MO_Flt_Eq -> condFltReg EQQ x y
956       MO_Flt_Ne -> condFltReg NE x y
957       MO_Flt_Lt -> condFltReg LTT x y
958       MO_Flt_Le -> condFltReg LE x y
959
960       MO_Dbl_Gt -> condFltReg GTT x y
961       MO_Dbl_Ge -> condFltReg GE x y
962       MO_Dbl_Eq -> condFltReg EQQ x y
963       MO_Dbl_Ne -> condFltReg NE x y
964       MO_Dbl_Lt -> condFltReg LTT x y
965       MO_Dbl_Le -> condFltReg LE x y
966
967       MO_Nat_Add   -> add_code L x y
968       MO_Nat_Sub   -> sub_code L x y
969       MO_NatS_Quot -> trivialCode (IQUOT L) Nothing x y
970       MO_NatS_Rem  -> trivialCode (IREM L) Nothing x y
971       MO_NatU_Quot -> trivialCode (QUOT L) Nothing x y
972       MO_NatU_Rem  -> trivialCode (REM L) Nothing x y
973       MO_NatS_Mul  -> let op = IMUL L in trivialCode op (Just op) x y
974       MO_NatU_Mul  -> let op = MUL L in trivialCode op (Just op) x y
975       MO_NatS_MulMayOflo -> imulMayOflo x y
976
977       MO_Flt_Add -> trivialFCode  FloatRep  GADD x y
978       MO_Flt_Sub -> trivialFCode  FloatRep  GSUB x y
979       MO_Flt_Mul -> trivialFCode  FloatRep  GMUL x y
980       MO_Flt_Div -> trivialFCode  FloatRep  GDIV x y
981
982       MO_Dbl_Add -> trivialFCode DoubleRep GADD x y
983       MO_Dbl_Sub -> trivialFCode DoubleRep GSUB x y
984       MO_Dbl_Mul -> trivialFCode DoubleRep GMUL x y
985       MO_Dbl_Div -> trivialFCode DoubleRep GDIV x y
986
987       MO_Nat_And -> let op = AND L in trivialCode op (Just op) x y
988       MO_Nat_Or  -> let op = OR  L in trivialCode op (Just op) x y
989       MO_Nat_Xor -> let op = XOR L in trivialCode op (Just op) x y
990
991         {- Shift ops on x86s have constraints on their source, it
992            either has to be Imm, CL or 1
993             => trivialCode's is not restrictive enough (sigh.)
994         -}         
995       MO_Nat_Shl  -> shift_code (SHL L) x y {-False-}
996       MO_Nat_Shr  -> shift_code (SHR L) x y {-False-}
997       MO_Nat_Sar  -> shift_code (SAR L) x y {-False-}
998
999       MO_Flt_Pwr  -> getRegister (demote 
1000                                  (StCall (Left SLIT("pow")) CCallConv DoubleRep 
1001                                          [promote x, promote y])
1002                                  )
1003       MO_Dbl_Pwr -> getRegister (StCall (Left SLIT("pow")) CCallConv DoubleRep 
1004                                         [x, y])
1005       other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop)
1006   where
1007     promote x = StMachOp MO_Flt_to_Dbl [x]
1008     demote x  = StMachOp MO_Dbl_to_Flt [x]
1009
1010     --------------------
1011     imulMayOflo :: StixExpr -> StixExpr -> NatM Register
1012     imulMayOflo a1 a2
1013        = getNewRegNCG IntRep            `thenNat` \ t1 ->
1014          getNewRegNCG IntRep            `thenNat` \ t2 ->
1015          getNewRegNCG IntRep            `thenNat` \ res_lo ->
1016          getNewRegNCG IntRep            `thenNat` \ res_hi ->
1017          getRegister a1                 `thenNat` \ reg1 ->
1018          getRegister a2                 `thenNat` \ reg2 ->
1019          let code1 = registerCode reg1 t1
1020              code2 = registerCode reg2 t2
1021              src1  = registerName reg1 t1
1022              src2  = registerName reg2 t2
1023              code dst = code1 `appOL` code2 `appOL`
1024                         toOL [
1025                            MOV L (OpReg src1) (OpReg res_hi),
1026                            MOV L (OpReg src2) (OpReg res_lo),
1027                            IMUL64 res_hi res_lo,                -- result in res_hi:res_lo
1028                            SAR L (ImmInt 31) (OpReg res_lo),    -- sign extend lower part
1029                            SUB L (OpReg res_hi) (OpReg res_lo), -- compare against upper
1030                            MOV L (OpReg res_lo) (OpReg dst)
1031                            -- dst==0 if high part == sign extended low part
1032                         ]
1033          in
1034             returnNat (Any IntRep code)
1035
1036     --------------------
1037     shift_code :: (Imm -> Operand -> Instr)
1038                -> StixExpr
1039                -> StixExpr
1040                -> NatM Register
1041
1042       {- Case1: shift length as immediate -}
1043       -- Code is the same as the first eq. for trivialCode -- sigh.
1044     shift_code instr x y{-amount-}
1045       | maybeToBool imm
1046       = getRegister x                      `thenNat` \ regx ->
1047         let mkcode dst
1048               = if   isAny regx
1049                 then registerCodeA regx dst  `bind` \ code_x ->
1050                      code_x `snocOL`
1051                      instr imm__2 (OpReg dst)
1052                 else registerCodeF regx      `bind` \ code_x ->
1053                      registerNameF regx      `bind` \ r_x ->
1054                      code_x `snocOL`
1055                      MOV L (OpReg r_x) (OpReg dst) `snocOL`
1056                      instr imm__2 (OpReg dst)
1057         in
1058         returnNat (Any IntRep mkcode)        
1059       where
1060        imm = maybeImm y
1061        imm__2 = case imm of Just x -> x
1062
1063       {- Case2: shift length is complex (non-immediate) -}
1064       -- Since ECX is always used as a spill temporary, we can't
1065       -- use it here to do non-immediate shifts.  No big deal --
1066       -- they are only very rare, and we can use an equivalent
1067       -- test-and-jump sequence which doesn't use ECX.
1068       -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE, 
1069       -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
1070     shift_code instr x y{-amount-}
1071      = getRegister x   `thenNat` \ register1 ->
1072        getRegister y   `thenNat` \ register2 ->
1073        getNatLabelNCG  `thenNat` \ lbl_test3 ->
1074        getNatLabelNCG  `thenNat` \ lbl_test2 ->
1075        getNatLabelNCG  `thenNat` \ lbl_test1 ->
1076        getNatLabelNCG  `thenNat` \ lbl_test0 ->
1077        getNatLabelNCG  `thenNat` \ lbl_after ->
1078        getNewRegNCG IntRep   `thenNat` \ tmp ->
1079        let code__2 dst
1080               = let src_val  = registerName register1 dst
1081                     code_val = registerCode register1 dst
1082                     src_amt  = registerName register2 tmp
1083                     code_amt = registerCode register2 tmp
1084                     r_dst    = OpReg dst
1085                     r_tmp    = OpReg tmp
1086                 in
1087                     code_amt `snocOL`
1088                     MOV L (OpReg src_amt) r_tmp `appOL`
1089                     code_val `snocOL`
1090                     MOV L (OpReg src_val) r_dst `appOL`
1091                     toOL [
1092                        COMMENT (_PK_ "begin shift sequence"),
1093                        MOV L (OpReg src_val) r_dst,
1094                        MOV L (OpReg src_amt) r_tmp,
1095
1096                        BT L (ImmInt 4) r_tmp,
1097                        JXX GEU lbl_test3,
1098                        instr (ImmInt 16) r_dst,
1099
1100                        LABEL lbl_test3,
1101                        BT L (ImmInt 3) r_tmp,
1102                        JXX GEU lbl_test2,
1103                        instr (ImmInt 8) r_dst,
1104
1105                        LABEL lbl_test2,
1106                        BT L (ImmInt 2) r_tmp,
1107                        JXX GEU lbl_test1,
1108                        instr (ImmInt 4) r_dst,
1109
1110                        LABEL lbl_test1,
1111                        BT L (ImmInt 1) r_tmp,
1112                        JXX GEU lbl_test0,
1113                        instr (ImmInt 2) r_dst,
1114
1115                        LABEL lbl_test0,
1116                        BT L (ImmInt 0) r_tmp,
1117                        JXX GEU lbl_after,
1118                        instr (ImmInt 1) r_dst,
1119                        LABEL lbl_after,
1120                                            
1121                        COMMENT (_PK_ "end shift sequence")
1122                     ]
1123        in
1124        returnNat (Any IntRep code__2)
1125
1126     --------------------
1127     add_code :: Size -> StixExpr -> StixExpr -> NatM Register
1128
1129     add_code sz x (StInt y)
1130       = getRegister x           `thenNat` \ register ->
1131         getNewRegNCG IntRep     `thenNat` \ tmp ->
1132         let
1133             code = registerCode register tmp
1134             src1 = registerName register tmp
1135             src2 = ImmInt (fromInteger y)
1136             code__2 dst 
1137                = code `snocOL`
1138                  LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
1139                         (OpReg dst)
1140         in
1141         returnNat (Any IntRep code__2)
1142
1143     add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
1144
1145     --------------------
1146     sub_code :: Size -> StixExpr -> StixExpr -> NatM Register
1147
1148     sub_code sz x (StInt y)
1149       = getRegister x           `thenNat` \ register ->
1150         getNewRegNCG IntRep     `thenNat` \ tmp ->
1151         let
1152             code = registerCode register tmp
1153             src1 = registerName register tmp
1154             src2 = ImmInt (-(fromInteger y))
1155             code__2 dst 
1156                = code `snocOL`
1157                  LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
1158                         (OpReg dst)
1159         in
1160         returnNat (Any IntRep code__2)
1161
1162     sub_code sz x y = trivialCode (SUB sz) Nothing x y
1163
1164 getRegister (StInd pk mem)
1165   | not (is64BitRep pk)
1166   = getAmode mem                    `thenNat` \ amode ->
1167     let
1168         code = amodeCode amode
1169         src  = amodeAddr amode
1170         size = primRepToSize pk
1171         code__2 dst = code `snocOL`
1172                       if   pk == DoubleRep || pk == FloatRep
1173                       then GLD size src dst
1174                       else (case size of
1175                                B  -> MOVSxL B
1176                                Bu -> MOVZxL Bu
1177                                W  -> MOVSxL W
1178                                Wu -> MOVZxL Wu
1179                                L  -> MOV L
1180                                Lu -> MOV L)
1181                                (OpAddr src) (OpReg dst)
1182     in
1183         returnNat (Any pk code__2)
1184
1185 getRegister (StInt i)
1186   = let
1187         src = ImmInt (fromInteger i)
1188         code dst 
1189            | i == 0
1190            = unitOL (XOR L (OpReg dst) (OpReg dst))
1191            | otherwise
1192            = unitOL (MOV L (OpImm src) (OpReg dst))
1193     in
1194         returnNat (Any IntRep code)
1195
1196 getRegister leaf
1197   | maybeToBool imm
1198   = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
1199     in
1200         returnNat (Any PtrRep code)
1201   | otherwise
1202   = ncgPrimopMoan "getRegister(x86)" (pprStixExpr leaf)
1203   where
1204     imm = maybeImm leaf
1205     imm__2 = case imm of Just x -> x
1206
1207 #endif {- i386_TARGET_ARCH -}
1208
1209 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1210
1211 #if sparc_TARGET_ARCH
1212
1213 getRegister (StFloat d)
1214   = getNatLabelNCG                  `thenNat` \ lbl ->
1215     getNewRegNCG PtrRep             `thenNat` \ tmp ->
1216     let code dst = toOL [
1217             SEGMENT DataSegment,
1218             LABEL lbl,
1219             DATA F [ImmFloat d],
1220             SEGMENT TextSegment,
1221             SETHI (HI (ImmCLbl lbl)) tmp,
1222             LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1223     in
1224         returnNat (Any FloatRep code)
1225
1226 getRegister (StDouble d)
1227   = getNatLabelNCG                  `thenNat` \ lbl ->
1228     getNewRegNCG PtrRep             `thenNat` \ tmp ->
1229     let code dst = toOL [
1230             SEGMENT DataSegment,
1231             LABEL lbl,
1232             DATA DF [ImmDouble d],
1233             SEGMENT TextSegment,
1234             SETHI (HI (ImmCLbl lbl)) tmp,
1235             LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1236     in
1237         returnNat (Any DoubleRep code)
1238
1239
1240 getRegister (StMachOp mop [x]) -- unary PrimOps
1241   = case mop of
1242       MO_NatS_Neg      -> trivialUCode (SUB False False g0) x
1243       MO_Nat_Not       -> trivialUCode (XNOR False g0) x
1244       MO_32U_to_8U     -> trivialCode (AND False) x (StInt 255)
1245
1246       MO_Flt_Neg       -> trivialUFCode FloatRep (FNEG F) x
1247       MO_Dbl_Neg       -> trivialUFCode DoubleRep (FNEG DF) x
1248
1249       MO_Dbl_to_Flt    -> coerceDbl2Flt x
1250       MO_Flt_to_Dbl    -> coerceFlt2Dbl x
1251
1252       MO_Flt_to_NatS   -> coerceFP2Int FloatRep x
1253       MO_NatS_to_Flt   -> coerceInt2FP FloatRep x
1254       MO_Dbl_to_NatS   -> coerceFP2Int DoubleRep x
1255       MO_NatS_to_Dbl   -> coerceInt2FP DoubleRep x
1256
1257       -- Conversions which are a nop on sparc
1258       MO_32U_to_NatS   -> conversionNop IntRep   x
1259       MO_NatS_to_32U   -> conversionNop WordRep  x
1260
1261       MO_NatU_to_NatS -> conversionNop IntRep    x
1262       MO_NatS_to_NatU -> conversionNop WordRep   x
1263       MO_NatP_to_NatU -> conversionNop WordRep   x
1264       MO_NatU_to_NatP -> conversionNop PtrRep    x
1265       MO_NatS_to_NatP -> conversionNop PtrRep    x
1266       MO_NatP_to_NatS -> conversionNop IntRep    x
1267
1268       -- sign-extending widenings
1269       MO_8U_to_32U    -> integerExtend False 24 x
1270       MO_8U_to_NatU   -> integerExtend False 24 x
1271       MO_8S_to_NatS   -> integerExtend True  24 x
1272       MO_16U_to_NatU  -> integerExtend False 16 x
1273       MO_16S_to_NatS  -> integerExtend True  16 x
1274
1275       other_op ->
1276         let fixed_x = if   is_float_op  -- promote to double
1277                       then StMachOp MO_Flt_to_Dbl [x]
1278                       else x
1279         in
1280         getRegister (StCall (Left fn) CCallConv DoubleRep [fixed_x])
1281     where
1282         integerExtend signed nBits x
1283            = getRegister (
1284                 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr) 
1285                          [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
1286              )
1287         conversionNop new_rep expr
1288             = getRegister expr          `thenNat` \ e_code ->
1289               returnNat (swizzleRegisterRep e_code new_rep)
1290
1291         (is_float_op, fn)
1292           = case mop of
1293               MO_Flt_Exp    -> (True,  SLIT("exp"))
1294               MO_Flt_Log    -> (True,  SLIT("log"))
1295               MO_Flt_Sqrt   -> (True,  SLIT("sqrt"))
1296
1297               MO_Flt_Sin    -> (True,  SLIT("sin"))
1298               MO_Flt_Cos    -> (True,  SLIT("cos"))
1299               MO_Flt_Tan    -> (True,  SLIT("tan"))
1300
1301               MO_Flt_Asin   -> (True,  SLIT("asin"))
1302               MO_Flt_Acos   -> (True,  SLIT("acos"))
1303               MO_Flt_Atan   -> (True,  SLIT("atan"))
1304
1305               MO_Flt_Sinh   -> (True,  SLIT("sinh"))
1306               MO_Flt_Cosh   -> (True,  SLIT("cosh"))
1307               MO_Flt_Tanh   -> (True,  SLIT("tanh"))
1308
1309               MO_Dbl_Exp    -> (False, SLIT("exp"))
1310               MO_Dbl_Log    -> (False, SLIT("log"))
1311               MO_Dbl_Sqrt   -> (False, SLIT("sqrt"))
1312
1313               MO_Dbl_Sin    -> (False, SLIT("sin"))
1314               MO_Dbl_Cos    -> (False, SLIT("cos"))
1315               MO_Dbl_Tan    -> (False, SLIT("tan"))
1316
1317               MO_Dbl_Asin   -> (False, SLIT("asin"))
1318               MO_Dbl_Acos   -> (False, SLIT("acos"))
1319               MO_Dbl_Atan   -> (False, SLIT("atan"))
1320
1321               MO_Dbl_Sinh   -> (False, SLIT("sinh"))
1322               MO_Dbl_Cosh   -> (False, SLIT("cosh"))
1323               MO_Dbl_Tanh   -> (False, SLIT("tanh"))
1324
1325               other -> pprPanic "getRegister(sparc) - binary StMachOp (2)" 
1326                                 (pprMachOp mop)
1327
1328
1329 getRegister (StMachOp mop [x, y]) -- dyadic PrimOps
1330   = case mop of
1331       MO_32U_Gt  -> condIntReg GTT x y
1332       MO_32U_Ge  -> condIntReg GE x y
1333       MO_32U_Eq  -> condIntReg EQQ x y
1334       MO_32U_Ne  -> condIntReg NE x y
1335       MO_32U_Lt  -> condIntReg LTT x y
1336       MO_32U_Le  -> condIntReg LE x y
1337
1338       MO_Nat_Eq   -> condIntReg EQQ x y
1339       MO_Nat_Ne   -> condIntReg NE x y
1340
1341       MO_NatS_Gt  -> condIntReg GTT x y
1342       MO_NatS_Ge  -> condIntReg GE x y
1343       MO_NatS_Lt  -> condIntReg LTT x y
1344       MO_NatS_Le  -> condIntReg LE x y
1345
1346       MO_NatU_Gt  -> condIntReg GU  x y
1347       MO_NatU_Ge  -> condIntReg GEU x y
1348       MO_NatU_Lt  -> condIntReg LU  x y
1349       MO_NatU_Le  -> condIntReg LEU x y
1350
1351       MO_Flt_Gt -> condFltReg GTT x y
1352       MO_Flt_Ge -> condFltReg GE x y
1353       MO_Flt_Eq -> condFltReg EQQ x y
1354       MO_Flt_Ne -> condFltReg NE x y
1355       MO_Flt_Lt -> condFltReg LTT x y
1356       MO_Flt_Le -> condFltReg LE x y
1357
1358       MO_Dbl_Gt -> condFltReg GTT x y
1359       MO_Dbl_Ge -> condFltReg GE x y
1360       MO_Dbl_Eq -> condFltReg EQQ x y
1361       MO_Dbl_Ne -> condFltReg NE x y
1362       MO_Dbl_Lt -> condFltReg LTT x y
1363       MO_Dbl_Le -> condFltReg LE x y
1364
1365       MO_Nat_Add -> trivialCode (ADD False False) x y
1366       MO_Nat_Sub -> trivialCode (SUB False False) x y
1367
1368       MO_NatS_Mul  -> trivialCode (SMUL False) x y
1369       MO_NatU_Mul  -> trivialCode (UMUL False) x y
1370       MO_NatS_MulMayOflo -> imulMayOflo x y
1371
1372       -- ToDo: teach about V8+ SPARC div instructions
1373       MO_NatS_Quot -> idiv SLIT(".div")  x y
1374       MO_NatS_Rem  -> idiv SLIT(".rem")  x y
1375       MO_NatU_Quot -> idiv SLIT(".udiv")  x y
1376       MO_NatU_Rem  -> idiv SLIT(".urem")  x y
1377
1378       MO_Flt_Add   -> trivialFCode FloatRep  FADD x y
1379       MO_Flt_Sub   -> trivialFCode FloatRep  FSUB x y
1380       MO_Flt_Mul   -> trivialFCode FloatRep  FMUL x y
1381       MO_Flt_Div   -> trivialFCode FloatRep  FDIV x y
1382
1383       MO_Dbl_Add   -> trivialFCode DoubleRep FADD x y
1384       MO_Dbl_Sub   -> trivialFCode DoubleRep FSUB x y
1385       MO_Dbl_Mul   -> trivialFCode DoubleRep FMUL x y
1386       MO_Dbl_Div   -> trivialFCode DoubleRep FDIV x y
1387
1388       MO_Nat_And   -> trivialCode (AND False) x y
1389       MO_Nat_Or    -> trivialCode (OR  False) x y
1390       MO_Nat_Xor   -> trivialCode (XOR False) x y
1391
1392       MO_Nat_Shl   -> trivialCode SLL x y
1393       MO_Nat_Shr   -> trivialCode SRL x y
1394       MO_Nat_Sar   -> trivialCode SRA x y
1395
1396       MO_Flt_Pwr  -> getRegister (StCall (Left SLIT("pow")) CCallConv DoubleRep 
1397                                          [promote x, promote y])
1398                        where promote x = StMachOp MO_Flt_to_Dbl [x]
1399       MO_Dbl_Pwr -> getRegister (StCall (Left SLIT("pow")) CCallConv DoubleRep 
1400                                         [x, y])
1401
1402       other -> pprPanic "getRegister(sparc) - binary StMachOp (1)" (pprMachOp mop)
1403   where
1404     idiv fn x y = getRegister (StCall (Left fn) CCallConv IntRep [x, y])
1405
1406     --------------------
1407     imulMayOflo :: StixExpr -> StixExpr -> NatM Register
1408     imulMayOflo a1 a2
1409        = getNewRegNCG IntRep            `thenNat` \ t1 ->
1410          getNewRegNCG IntRep            `thenNat` \ t2 ->
1411          getNewRegNCG IntRep            `thenNat` \ res_lo ->
1412          getNewRegNCG IntRep            `thenNat` \ res_hi ->
1413          getRegister a1                 `thenNat` \ reg1 ->
1414          getRegister a2                 `thenNat` \ reg2 ->
1415          let code1 = registerCode reg1 t1
1416              code2 = registerCode reg2 t2
1417              src1  = registerName reg1 t1
1418              src2  = registerName reg2 t2
1419              code dst = code1 `appOL` code2 `appOL`
1420                         toOL [
1421                            SMUL False src1 (RIReg src2) res_lo,
1422                            RDY res_hi,
1423                            SRA res_lo (RIImm (ImmInt 31)) res_lo,
1424                            SUB False False res_lo (RIReg res_hi) dst
1425                         ]
1426          in
1427             returnNat (Any IntRep code)
1428
1429 getRegister (StInd pk mem)
1430   = getAmode mem                    `thenNat` \ amode ->
1431     let
1432         code = amodeCode amode
1433         src   = amodeAddr amode
1434         size = primRepToSize pk
1435         code__2 dst = code `snocOL` LD size src dst
1436     in
1437         returnNat (Any pk code__2)
1438
1439 getRegister (StInt i)
1440   | fits13Bits i
1441   = let
1442         src = ImmInt (fromInteger i)
1443         code dst = unitOL (OR False g0 (RIImm src) dst)
1444     in
1445         returnNat (Any IntRep code)
1446
1447 getRegister leaf
1448   | maybeToBool imm
1449   = let
1450         code dst = toOL [
1451             SETHI (HI imm__2) dst,
1452             OR False dst (RIImm (LO imm__2)) dst]
1453     in
1454         returnNat (Any PtrRep code)
1455   | otherwise
1456   = ncgPrimopMoan "getRegister(sparc)" (pprStixExpr leaf)
1457   where
1458     imm = maybeImm leaf
1459     imm__2 = case imm of Just x -> x
1460
1461 #endif {- sparc_TARGET_ARCH -}
1462
1463 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1464
1465 \end{code}
1466
1467 %************************************************************************
1468 %*                                                                      *
1469 \subsection{The @Amode@ type}
1470 %*                                                                      *
1471 %************************************************************************
1472
1473 @Amode@s: Memory addressing modes passed up the tree.
1474 \begin{code}
1475 data Amode = Amode MachRegsAddr InstrBlock
1476
1477 amodeAddr (Amode addr _) = addr
1478 amodeCode (Amode _ code) = code
1479 \end{code}
1480
1481 Now, given a tree (the argument to an StInd) that references memory,
1482 produce a suitable addressing mode.
1483
1484 A Rule of the Game (tm) for Amodes: use of the addr bit must
1485 immediately follow use of the code part, since the code part puts
1486 values in registers which the addr then refers to.  So you can't put
1487 anything in between, lest it overwrite some of those registers.  If
1488 you need to do some other computation between the code part and use of
1489 the addr bit, first store the effective address from the amode in a
1490 temporary, then do the other computation, and then use the temporary:
1491
1492     code
1493     LEA amode, tmp
1494     ... other computation ...
1495     ... (tmp) ...
1496
1497 \begin{code}
1498 getAmode :: StixExpr -> NatM Amode
1499
1500 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1501
1502 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1503
1504 #if alpha_TARGET_ARCH
1505
1506 getAmode (StPrim IntSubOp [x, StInt i])
1507   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1508     getRegister x               `thenNat` \ register ->
1509     let
1510         code = registerCode register tmp
1511         reg  = registerName register tmp
1512         off  = ImmInt (-(fromInteger i))
1513     in
1514     returnNat (Amode (AddrRegImm reg off) code)
1515
1516 getAmode (StPrim IntAddOp [x, StInt i])
1517   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1518     getRegister x               `thenNat` \ register ->
1519     let
1520         code = registerCode register tmp
1521         reg  = registerName register tmp
1522         off  = ImmInt (fromInteger i)
1523     in
1524     returnNat (Amode (AddrRegImm reg off) code)
1525
1526 getAmode leaf
1527   | maybeToBool imm
1528   = returnNat (Amode (AddrImm imm__2) id)
1529   where
1530     imm = maybeImm leaf
1531     imm__2 = case imm of Just x -> x
1532
1533 getAmode other
1534   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1535     getRegister other           `thenNat` \ register ->
1536     let
1537         code = registerCode register tmp
1538         reg  = registerName register tmp
1539     in
1540     returnNat (Amode (AddrReg reg) code)
1541
1542 #endif {- alpha_TARGET_ARCH -}
1543
1544 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1545
1546 #if i386_TARGET_ARCH
1547
1548 -- This is all just ridiculous, since it carefully undoes 
1549 -- what mangleIndexTree has just done.
1550 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1551   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1552     getRegister x               `thenNat` \ register ->
1553     let
1554         code = registerCode register tmp
1555         reg  = registerName register tmp
1556         off  = ImmInt (-(fromInteger i))
1557     in
1558     returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1559
1560 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1561   | maybeToBool imm
1562   = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1563   where
1564     imm    = maybeImm x
1565     imm__2 = case imm of Just x -> x
1566
1567 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1568   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1569     getRegister x               `thenNat` \ register ->
1570     let
1571         code = registerCode register tmp
1572         reg  = registerName register tmp
1573         off  = ImmInt (fromInteger i)
1574     in
1575     returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1576
1577 getAmode (StMachOp MO_Nat_Add [x, StMachOp MO_Nat_Shl [y, StInt shift]])
1578   | shift == 0 || shift == 1 || shift == 2 || shift == 3
1579   = getNewRegNCG PtrRep         `thenNat` \ tmp1 ->
1580     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
1581     getRegister x               `thenNat` \ register1 ->
1582     getRegister y               `thenNat` \ register2 ->
1583     let
1584         code1 = registerCode register1 tmp1
1585         reg1  = registerName register1 tmp1
1586         code2 = registerCode register2 tmp2
1587         reg2  = registerName register2 tmp2
1588         code__2 = code1 `appOL` code2
1589         base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1590     in
1591     returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1592                code__2)
1593
1594 getAmode leaf
1595   | maybeToBool imm
1596   = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1597   where
1598     imm    = maybeImm leaf
1599     imm__2 = case imm of Just x -> x
1600
1601 getAmode other
1602   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1603     getRegister other           `thenNat` \ register ->
1604     let
1605         code = registerCode register tmp
1606         reg  = registerName register tmp
1607     in
1608     returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1609
1610 #endif {- i386_TARGET_ARCH -}
1611
1612 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1613
1614 #if sparc_TARGET_ARCH
1615
1616 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1617   | fits13Bits (-i)
1618   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1619     getRegister x               `thenNat` \ register ->
1620     let
1621         code = registerCode register tmp
1622         reg  = registerName register tmp
1623         off  = ImmInt (-(fromInteger i))
1624     in
1625     returnNat (Amode (AddrRegImm reg off) code)
1626
1627
1628 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1629   | fits13Bits i
1630   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1631     getRegister x               `thenNat` \ register ->
1632     let
1633         code = registerCode register tmp
1634         reg  = registerName register tmp
1635         off  = ImmInt (fromInteger i)
1636     in
1637     returnNat (Amode (AddrRegImm reg off) code)
1638
1639 getAmode (StMachOp MO_Nat_Add [x, y])
1640   = getNewRegNCG PtrRep         `thenNat` \ tmp1 ->
1641     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
1642     getRegister x               `thenNat` \ register1 ->
1643     getRegister y               `thenNat` \ register2 ->
1644     let
1645         code1 = registerCode register1 tmp1
1646         reg1  = registerName register1 tmp1
1647         code2 = registerCode register2 tmp2
1648         reg2  = registerName register2 tmp2
1649         code__2 = code1 `appOL` code2
1650     in
1651     returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1652
1653 getAmode leaf
1654   | maybeToBool imm
1655   = getNewRegNCG PtrRep             `thenNat` \ tmp ->
1656     let
1657         code = unitOL (SETHI (HI imm__2) tmp)
1658     in
1659     returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1660   where
1661     imm    = maybeImm leaf
1662     imm__2 = case imm of Just x -> x
1663
1664 getAmode other
1665   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1666     getRegister other           `thenNat` \ register ->
1667     let
1668         code = registerCode register tmp
1669         reg  = registerName register tmp
1670         off  = ImmInt 0
1671     in
1672     returnNat (Amode (AddrRegImm reg off) code)
1673
1674 #endif {- sparc_TARGET_ARCH -}
1675
1676 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1677 \end{code}
1678
1679 %************************************************************************
1680 %*                                                                      *
1681 \subsection{The @CondCode@ type}
1682 %*                                                                      *
1683 %************************************************************************
1684
1685 Condition codes passed up the tree.
1686 \begin{code}
1687 data CondCode = CondCode Bool Cond InstrBlock
1688
1689 condName  (CondCode _ cond _)     = cond
1690 condFloat (CondCode is_float _ _) = is_float
1691 condCode  (CondCode _ _ code)     = code
1692 \end{code}
1693
1694 Set up a condition code for a conditional branch.
1695
1696 \begin{code}
1697 getCondCode :: StixExpr -> NatM CondCode
1698
1699 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1700
1701 #if alpha_TARGET_ARCH
1702 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1703 #endif {- alpha_TARGET_ARCH -}
1704
1705 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1706
1707 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1708 -- yes, they really do seem to want exactly the same!
1709
1710 getCondCode (StMachOp mop [x, y])
1711   = case mop of
1712       MO_32U_Gt -> condIntCode GTT  x y
1713       MO_32U_Ge -> condIntCode GE   x y
1714       MO_32U_Eq -> condIntCode EQQ  x y
1715       MO_32U_Ne -> condIntCode NE   x y
1716       MO_32U_Lt -> condIntCode LTT  x y
1717       MO_32U_Le -> condIntCode LE   x y
1718  
1719       MO_Nat_Eq  -> condIntCode EQQ  x y
1720       MO_Nat_Ne  -> condIntCode NE   x y
1721
1722       MO_NatS_Gt -> condIntCode GTT  x y
1723       MO_NatS_Ge -> condIntCode GE   x y
1724       MO_NatS_Lt -> condIntCode LTT  x y
1725       MO_NatS_Le -> condIntCode LE   x y
1726
1727       MO_NatU_Gt -> condIntCode GU   x y
1728       MO_NatU_Ge -> condIntCode GEU  x y
1729       MO_NatU_Lt -> condIntCode LU   x y
1730       MO_NatU_Le -> condIntCode LEU  x y
1731
1732       MO_Flt_Gt -> condFltCode GTT x y
1733       MO_Flt_Ge -> condFltCode GE  x y
1734       MO_Flt_Eq -> condFltCode EQQ x y
1735       MO_Flt_Ne -> condFltCode NE  x y
1736       MO_Flt_Lt -> condFltCode LTT x y
1737       MO_Flt_Le -> condFltCode LE  x y
1738
1739       MO_Dbl_Gt -> condFltCode GTT x y
1740       MO_Dbl_Ge -> condFltCode GE  x y
1741       MO_Dbl_Eq -> condFltCode EQQ x y
1742       MO_Dbl_Ne -> condFltCode NE  x y
1743       MO_Dbl_Lt -> condFltCode LTT x y
1744       MO_Dbl_Le -> condFltCode LE  x y
1745
1746       other -> pprPanic "getCondCode(x86,sparc)" (pprMachOp mop)
1747
1748 getCondCode other =  pprPanic "getCondCode(2)(x86,sparc)" (pprStixExpr other)
1749
1750 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1751
1752 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1753 \end{code}
1754
1755 % -----------------
1756
1757 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1758 passed back up the tree.
1759
1760 \begin{code}
1761 condIntCode, condFltCode :: Cond -> StixExpr -> StixExpr -> NatM CondCode
1762
1763 #if alpha_TARGET_ARCH
1764 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1765 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1766 #endif {- alpha_TARGET_ARCH -}
1767
1768 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1769 #if i386_TARGET_ARCH
1770
1771 -- memory vs immediate
1772 condIntCode cond (StInd pk x) y
1773   | Just i <- maybeImm y
1774   = getAmode x                  `thenNat` \ amode ->
1775     let
1776         code1 = amodeCode amode
1777         x__2  = amodeAddr amode
1778         sz    = primRepToSize pk
1779         code__2 = code1 `snocOL`
1780                   CMP sz (OpImm i) (OpAddr x__2)
1781     in
1782     returnNat (CondCode False cond code__2)
1783
1784 -- anything vs zero
1785 condIntCode cond x (StInt 0)
1786   = getRegister x               `thenNat` \ register1 ->
1787     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
1788     let
1789         code1 = registerCode register1 tmp1
1790         src1  = registerName register1 tmp1
1791         code__2 = code1 `snocOL`
1792                   TEST L (OpReg src1) (OpReg src1)
1793     in
1794     returnNat (CondCode False cond code__2)
1795
1796 -- anything vs immediate
1797 condIntCode cond x y
1798   | Just i <- maybeImm y
1799   = getRegister x               `thenNat` \ register1 ->
1800     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
1801     let
1802         code1 = registerCode register1 tmp1
1803         src1  = registerName register1 tmp1
1804         code__2 = code1 `snocOL`
1805                   CMP L (OpImm i) (OpReg src1)
1806     in
1807     returnNat (CondCode False cond code__2)
1808
1809 -- memory vs anything
1810 condIntCode cond (StInd pk x) y
1811   = getAmode x                  `thenNat` \ amode_x ->
1812     getRegister y               `thenNat` \ reg_y ->
1813     getNewRegNCG IntRep         `thenNat` \ tmp ->
1814     let
1815         c_x   = amodeCode amode_x
1816         am_x  = amodeAddr amode_x
1817         c_y   = registerCode reg_y tmp
1818         r_y   = registerName reg_y tmp
1819         sz    = primRepToSize pk
1820
1821         -- optimisation: if there's no code for x, just an amode,
1822         -- use whatever reg y winds up in.  Assumes that c_y doesn't
1823         -- clobber any regs in the amode am_x, which I'm not sure is
1824         -- justified.  The otherwise clause makes the same assumption.
1825         code__2 | isNilOL c_x 
1826                 = c_y `snocOL`
1827                   CMP sz (OpReg r_y) (OpAddr am_x)
1828
1829                 | otherwise
1830                 = c_y `snocOL` 
1831                   MOV L (OpReg r_y) (OpReg tmp) `appOL`
1832                   c_x `snocOL`
1833                   CMP sz (OpReg tmp) (OpAddr am_x)
1834     in
1835     returnNat (CondCode False cond code__2)
1836
1837 -- anything vs memory
1838 -- 
1839 condIntCode cond y (StInd pk x)
1840   = getAmode x                  `thenNat` \ amode_x ->
1841     getRegister y               `thenNat` \ reg_y ->
1842     getNewRegNCG IntRep         `thenNat` \ tmp ->
1843     let
1844         c_x   = amodeCode amode_x
1845         am_x  = amodeAddr amode_x
1846         c_y   = registerCode reg_y tmp
1847         r_y   = registerName reg_y tmp
1848         sz    = primRepToSize pk
1849         -- same optimisation and nagging doubts as previous clause
1850         code__2 | isNilOL c_x
1851                 = c_y `snocOL`
1852                   CMP sz (OpAddr am_x) (OpReg r_y)
1853
1854                 | otherwise
1855                 = c_y `snocOL` 
1856                   MOV L (OpReg r_y) (OpReg tmp) `appOL`
1857                   c_x `snocOL`
1858                   CMP sz (OpAddr am_x) (OpReg tmp)
1859     in
1860     returnNat (CondCode False cond code__2)
1861
1862 -- anything vs anything
1863 condIntCode cond x y
1864   = getRegister x               `thenNat` \ register1 ->
1865     getRegister y               `thenNat` \ register2 ->
1866     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
1867     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
1868     let
1869         code1 = registerCode register1 tmp1
1870         src1  = registerName register1 tmp1
1871         code2 = registerCode register2 tmp2
1872         src2  = registerName register2 tmp2
1873         code__2 = code1 `snocOL`
1874                   MOV L (OpReg src1) (OpReg tmp1) `appOL`
1875                   code2 `snocOL`
1876                   CMP L (OpReg src2) (OpReg tmp1)
1877     in
1878     returnNat (CondCode False cond code__2)
1879
1880 -----------
1881 condFltCode cond x y
1882   = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT]))
1883     getRegister x               `thenNat` \ register1 ->
1884     getRegister y               `thenNat` \ register2 ->
1885     getNewRegNCG (registerRep register1)
1886                                 `thenNat` \ tmp1 ->
1887     getNewRegNCG (registerRep register2)
1888                                 `thenNat` \ tmp2 ->
1889     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
1890     let
1891         code1 = registerCode register1 tmp1
1892         src1  = registerName register1 tmp1
1893
1894         code2 = registerCode register2 tmp2
1895         src2  = registerName register2 tmp2
1896
1897         code__2 | isAny register1
1898                 = code1 `appOL`   -- result in tmp1
1899                   code2 `snocOL`
1900                   GCMP cond tmp1 src2
1901                   
1902                 | otherwise
1903                 = code1 `snocOL` 
1904                   GMOV src1 tmp1 `appOL`
1905                   code2 `snocOL`
1906                   GCMP cond tmp1 src2
1907     in
1908     -- The GCMP insn does the test and sets the zero flag if comparable
1909     -- and true.  Hence we always supply EQQ as the condition to test.
1910     returnNat (CondCode True EQQ code__2)
1911
1912 #endif {- i386_TARGET_ARCH -}
1913
1914 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1915
1916 #if sparc_TARGET_ARCH
1917
1918 condIntCode cond x (StInt y)
1919   | fits13Bits y
1920   = getRegister x               `thenNat` \ register ->
1921     getNewRegNCG IntRep         `thenNat` \ tmp ->
1922     let
1923         code = registerCode register tmp
1924         src1 = registerName register tmp
1925         src2 = ImmInt (fromInteger y)
1926         code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
1927     in
1928     returnNat (CondCode False cond code__2)
1929
1930 condIntCode cond x y
1931   = getRegister x               `thenNat` \ register1 ->
1932     getRegister y               `thenNat` \ register2 ->
1933     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
1934     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
1935     let
1936         code1 = registerCode register1 tmp1
1937         src1  = registerName register1 tmp1
1938         code2 = registerCode register2 tmp2
1939         src2  = registerName register2 tmp2
1940         code__2 = code1 `appOL` code2 `snocOL`
1941                   SUB False True src1 (RIReg src2) g0
1942     in
1943     returnNat (CondCode False cond code__2)
1944
1945 -----------
1946 condFltCode cond x y
1947   = getRegister x               `thenNat` \ register1 ->
1948     getRegister y               `thenNat` \ register2 ->
1949     getNewRegNCG (registerRep register1)
1950                                 `thenNat` \ tmp1 ->
1951     getNewRegNCG (registerRep register2)
1952                                 `thenNat` \ tmp2 ->
1953     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
1954     let
1955         promote x = FxTOy F DF x tmp
1956
1957         pk1   = registerRep register1
1958         code1 = registerCode register1 tmp1
1959         src1  = registerName register1 tmp1
1960
1961         pk2   = registerRep register2
1962         code2 = registerCode register2 tmp2
1963         src2  = registerName register2 tmp2
1964
1965         code__2 =
1966                 if pk1 == pk2 then
1967                     code1 `appOL` code2 `snocOL`
1968                     FCMP True (primRepToSize pk1) src1 src2
1969                 else if pk1 == FloatRep then
1970                     code1 `snocOL` promote src1 `appOL` code2 `snocOL`
1971                     FCMP True DF tmp src2
1972                 else
1973                     code1 `appOL` code2 `snocOL` promote src2 `snocOL`
1974                     FCMP True DF src1 tmp
1975     in
1976     returnNat (CondCode True cond code__2)
1977
1978 #endif {- sparc_TARGET_ARCH -}
1979
1980 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1981 \end{code}
1982
1983 %************************************************************************
1984 %*                                                                      *
1985 \subsection{Generating assignments}
1986 %*                                                                      *
1987 %************************************************************************
1988
1989 Assignments are really at the heart of the whole code generation
1990 business.  Almost all top-level nodes of any real importance are
1991 assignments, which correspond to loads, stores, or register transfers.
1992 If we're really lucky, some of the register transfers will go away,
1993 because we can use the destination register to complete the code
1994 generation for the right hand side.  This only fails when the right
1995 hand side is forced into a fixed register (e.g. the result of a call).
1996
1997 \begin{code}
1998 assignMem_IntCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
1999 assignReg_IntCode :: PrimRep -> StixReg  -> StixExpr -> NatM InstrBlock
2000
2001 assignMem_FltCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
2002 assignReg_FltCode :: PrimRep -> StixReg  -> StixExpr -> NatM InstrBlock
2003
2004 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2005
2006 #if alpha_TARGET_ARCH
2007
2008 assignIntCode pk (StInd _ dst) src
2009   = getNewRegNCG IntRep             `thenNat` \ tmp ->
2010     getAmode dst                    `thenNat` \ amode ->
2011     getRegister src                 `thenNat` \ register ->
2012     let
2013         code1   = amodeCode amode []
2014         dst__2  = amodeAddr amode
2015         code2   = registerCode register tmp []
2016         src__2  = registerName register tmp
2017         sz      = primRepToSize pk
2018         code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2019     in
2020     returnNat code__2
2021
2022 assignIntCode pk dst src
2023   = getRegister dst                         `thenNat` \ register1 ->
2024     getRegister src                         `thenNat` \ register2 ->
2025     let
2026         dst__2  = registerName register1 zeroh
2027         code    = registerCode register2 dst__2
2028         src__2  = registerName register2 dst__2
2029         code__2 = if isFixed register2
2030                   then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
2031                   else code
2032     in
2033     returnNat code__2
2034
2035 #endif {- alpha_TARGET_ARCH -}
2036
2037 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2038
2039 #if i386_TARGET_ARCH
2040
2041 -- non-FP assignment to memory
2042 assignMem_IntCode pk addr src
2043   = getAmode addr               `thenNat` \ amode ->
2044     get_op_RI src               `thenNat` \ (codesrc, opsrc) ->
2045     getNewRegNCG PtrRep         `thenNat` \ tmp ->
2046     let
2047         -- In general, if the address computation for dst may require
2048         -- some insns preceding the addressing mode itself.  So there's
2049         -- no guarantee that the code for dst and the code for src won't
2050         -- write the same register.  This means either the address or 
2051         -- the value needs to be copied into a temporary.  We detect the
2052         -- common case where the amode has no code, and elide the copy.
2053         codea   = amodeCode amode
2054         dst__a  = amodeAddr amode
2055
2056         code    | isNilOL codea
2057                 = codesrc `snocOL`
2058                   MOV (primRepToSize pk) opsrc (OpAddr dst__a)
2059                 | otherwise
2060                 = codea `snocOL` 
2061                   LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
2062                   codesrc `snocOL`
2063                   MOV (primRepToSize pk) opsrc 
2064                       (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
2065     in
2066     returnNat code
2067   where
2068     get_op_RI
2069         :: StixExpr
2070         -> NatM (InstrBlock,Operand)    -- code, operator
2071
2072     get_op_RI op
2073       | Just x <- maybeImm op
2074       = returnNat (nilOL, OpImm x)
2075
2076     get_op_RI op
2077       = getRegister op                  `thenNat` \ register ->
2078         getNewRegNCG (registerRep register)
2079                                         `thenNat` \ tmp ->
2080         let code = registerCode register tmp
2081             reg  = registerName register tmp
2082         in
2083         returnNat (code, OpReg reg)
2084
2085 -- Assign; dst is a reg, rhs is mem
2086 assignReg_IntCode pk reg (StInd pks src)
2087   = getNewRegNCG PtrRep             `thenNat` \ tmp ->
2088     getAmode src                    `thenNat` \ amode ->
2089     getRegisterReg reg              `thenNat` \ reg_dst ->
2090     let
2091         c_addr  = amodeCode amode
2092         am_addr = amodeAddr amode
2093         r_dst = registerName reg_dst tmp
2094         szs   = primRepToSize pks
2095         opc   = case szs of
2096             B  -> MOVSxL B
2097             Bu -> MOVZxL Bu
2098             W  -> MOVSxL W
2099             Wu -> MOVZxL Wu
2100             L  -> MOV L
2101             Lu -> MOV L
2102
2103         code  = c_addr `snocOL`
2104                 opc (OpAddr am_addr) (OpReg r_dst)
2105     in
2106     returnNat code
2107
2108 -- dst is a reg, but src could be anything
2109 assignReg_IntCode pk reg src
2110   = getRegisterReg reg              `thenNat` \ registerd ->
2111     getRegister src                 `thenNat` \ registers ->
2112     getNewRegNCG IntRep             `thenNat` \ tmp ->
2113     let 
2114         r_dst = registerName registerd tmp
2115         r_src = registerName registers r_dst
2116         c_src = registerCode registers r_dst
2117         
2118         code = c_src `snocOL` 
2119                MOV L (OpReg r_src) (OpReg r_dst)
2120     in
2121     returnNat code
2122
2123 #endif {- i386_TARGET_ARCH -}
2124
2125 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2126
2127 #if sparc_TARGET_ARCH
2128
2129 assignMem_IntCode pk addr src
2130   = getNewRegNCG IntRep                     `thenNat` \ tmp ->
2131     getAmode addr                           `thenNat` \ amode ->
2132     getRegister src                         `thenNat` \ register ->
2133     let
2134         code1   = amodeCode amode
2135         dst__2  = amodeAddr amode
2136         code2   = registerCode register tmp
2137         src__2  = registerName register tmp
2138         sz      = primRepToSize pk
2139         code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2140     in
2141     returnNat code__2
2142
2143 assignReg_IntCode pk reg src
2144   = getRegister src                         `thenNat` \ register2 ->
2145     getRegisterReg reg                      `thenNat` \ register1 ->
2146     let
2147         dst__2  = registerName register1 g0
2148         code    = registerCode register2 dst__2
2149         src__2  = registerName register2 dst__2
2150         code__2 = if isFixed register2
2151                   then code `snocOL` OR False g0 (RIReg src__2) dst__2
2152                   else code
2153     in
2154     returnNat code__2
2155
2156 #endif {- sparc_TARGET_ARCH -}
2157
2158 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2159 \end{code}
2160
2161 % --------------------------------
2162 Floating-point assignments:
2163 % --------------------------------
2164
2165 \begin{code}
2166 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2167 #if alpha_TARGET_ARCH
2168
2169 assignFltCode pk (StInd _ dst) src
2170   = getNewRegNCG pk                 `thenNat` \ tmp ->
2171     getAmode dst                    `thenNat` \ amode ->
2172     getRegister src                         `thenNat` \ register ->
2173     let
2174         code1   = amodeCode amode []
2175         dst__2  = amodeAddr amode
2176         code2   = registerCode register tmp []
2177         src__2  = registerName register tmp
2178         sz      = primRepToSize pk
2179         code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2180     in
2181     returnNat code__2
2182
2183 assignFltCode pk dst src
2184   = getRegister dst                         `thenNat` \ register1 ->
2185     getRegister src                         `thenNat` \ register2 ->
2186     let
2187         dst__2  = registerName register1 zeroh
2188         code    = registerCode register2 dst__2
2189         src__2  = registerName register2 dst__2
2190         code__2 = if isFixed register2
2191                   then code . mkSeqInstr (FMOV src__2 dst__2)
2192                   else code
2193     in
2194     returnNat code__2
2195
2196 #endif {- alpha_TARGET_ARCH -}
2197
2198 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2199
2200 #if i386_TARGET_ARCH
2201
2202 -- Floating point assignment to memory
2203 assignMem_FltCode pk addr src
2204    = getRegister src      `thenNat`  \ reg_src  ->
2205      getRegister addr     `thenNat`  \ reg_addr ->
2206      getNewRegNCG pk      `thenNat`  \ tmp_src  ->
2207      getNewRegNCG PtrRep  `thenNat`  \ tmp_addr ->
2208      let r_src  = registerName reg_src tmp_src
2209          c_src  = registerCode reg_src tmp_src
2210          r_addr = registerName reg_addr tmp_addr
2211          c_addr = registerCode reg_addr tmp_addr
2212          sz     = primRepToSize pk
2213
2214          code = c_src  `appOL`
2215                 -- no need to preserve r_src across the addr computation,
2216                 -- since r_src must be a float reg 
2217                 -- whilst r_addr is an int reg
2218                 c_addr `snocOL`
2219                 GST sz r_src 
2220                        (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
2221      in
2222      returnNat code
2223
2224 -- Floating point assignment to a register/temporary
2225 assignReg_FltCode pk reg src
2226   = getRegisterReg reg              `thenNat` \ reg_dst ->
2227     getRegister src                 `thenNat` \ reg_src ->
2228     getNewRegNCG pk                 `thenNat` \ tmp ->
2229     let
2230         r_dst = registerName reg_dst tmp
2231         r_src = registerName reg_src r_dst
2232         c_src = registerCode reg_src r_dst
2233
2234         code = if   isFixed reg_src
2235                then c_src `snocOL` GMOV r_src r_dst
2236                else c_src
2237     in
2238     returnNat code
2239
2240
2241 #endif {- i386_TARGET_ARCH -}
2242
2243 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2244
2245 #if sparc_TARGET_ARCH
2246
2247 -- Floating point assignment to memory
2248 assignMem_FltCode pk addr src
2249   = getNewRegNCG pk                 `thenNat` \ tmp1 ->
2250     getAmode addr                   `thenNat` \ amode ->
2251     getRegister src                 `thenNat` \ register ->
2252     let
2253         sz      = primRepToSize pk
2254         dst__2  = amodeAddr amode
2255
2256         code1   = amodeCode amode
2257         code2   = registerCode register tmp1
2258
2259         src__2  = registerName register tmp1
2260         pk__2   = registerRep register
2261         sz__2   = primRepToSize pk__2
2262
2263         code__2 = code1 `appOL` code2 `appOL`
2264             if   pk == pk__2 
2265             then unitOL (ST sz src__2 dst__2)
2266             else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
2267     in
2268     returnNat code__2
2269
2270 -- Floating point assignment to a register/temporary
2271 -- Why is this so bizarrely ugly?
2272 assignReg_FltCode pk reg src
2273   = getRegisterReg reg                      `thenNat` \ register1 ->
2274     getRegister src                         `thenNat` \ register2 ->
2275     let 
2276         pk__2   = registerRep register2 
2277         sz__2   = primRepToSize pk__2
2278     in
2279     getNewRegNCG pk__2                      `thenNat` \ tmp ->
2280     let
2281         sz      = primRepToSize pk
2282         dst__2  = registerName register1 g0    -- must be Fixed
2283         reg__2  = if pk /= pk__2 then tmp else dst__2
2284         code    = registerCode register2 reg__2
2285         src__2  = registerName register2 reg__2
2286         code__2 = 
2287                 if pk /= pk__2 then
2288                      code `snocOL` FxTOy sz__2 sz src__2 dst__2
2289                 else if isFixed register2 then
2290                      code `snocOL` FMOV sz src__2 dst__2
2291                 else
2292                      code
2293     in
2294     returnNat code__2
2295
2296 #endif {- sparc_TARGET_ARCH -}
2297
2298 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2299 \end{code}
2300
2301 %************************************************************************
2302 %*                                                                      *
2303 \subsection{Generating an unconditional branch}
2304 %*                                                                      *
2305 %************************************************************************
2306
2307 We accept two types of targets: an immediate CLabel or a tree that
2308 gets evaluated into a register.  Any CLabels which are AsmTemporaries
2309 are assumed to be in the local block of code, close enough for a
2310 branch instruction.  Other CLabels are assumed to be far away.
2311
2312 (If applicable) Do not fill the delay slots here; you will confuse the
2313 register allocator.
2314
2315 \begin{code}
2316 genJump :: DestInfo -> StixExpr{-the branch target-} -> NatM InstrBlock
2317
2318 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2319
2320 #if alpha_TARGET_ARCH
2321
2322 genJump (StCLbl lbl)
2323   | isAsmTemp lbl = returnInstr (BR target)
2324   | otherwise     = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
2325   where
2326     target = ImmCLbl lbl
2327
2328 genJump tree
2329   = getRegister tree                `thenNat` \ register ->
2330     getNewRegNCG PtrRep             `thenNat` \ tmp ->
2331     let
2332         dst    = registerName register pv
2333         code   = registerCode register pv
2334         target = registerName register pv
2335     in
2336     if isFixed register then
2337         returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
2338     else
2339     returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
2340
2341 #endif {- alpha_TARGET_ARCH -}
2342
2343 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2344
2345 #if i386_TARGET_ARCH
2346
2347 genJump dsts (StInd pk mem)
2348   = getAmode mem                    `thenNat` \ amode ->
2349     let
2350         code   = amodeCode amode
2351         target = amodeAddr amode
2352     in
2353     returnNat (code `snocOL` JMP dsts (OpAddr target))
2354
2355 genJump dsts tree
2356   | maybeToBool imm
2357   = returnNat (unitOL (JMP dsts (OpImm target)))
2358
2359   | otherwise
2360   = getRegister tree                `thenNat` \ register ->
2361     getNewRegNCG PtrRep             `thenNat` \ tmp ->
2362     let
2363         code   = registerCode register tmp
2364         target = registerName register tmp
2365     in
2366     returnNat (code `snocOL` JMP dsts (OpReg target))
2367   where
2368     imm    = maybeImm tree
2369     target = case imm of Just x -> x
2370
2371 #endif {- i386_TARGET_ARCH -}
2372
2373 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2374
2375 #if sparc_TARGET_ARCH
2376
2377 genJump dsts (StCLbl lbl)
2378   | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
2379   | isAsmTemp lbl    = returnNat (toOL [BI ALWAYS False target, NOP])
2380   | otherwise        = returnNat (toOL [CALL (Left target) 0 True, NOP])
2381   where
2382     target = ImmCLbl lbl
2383
2384 genJump dsts tree
2385   = getRegister tree                        `thenNat` \ register ->
2386     getNewRegNCG PtrRep             `thenNat` \ tmp ->
2387     let
2388         code   = registerCode register tmp
2389         target = registerName register tmp
2390     in
2391     returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
2392
2393 #endif {- sparc_TARGET_ARCH -}
2394
2395 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2396 \end{code}
2397
2398 %************************************************************************
2399 %*                                                                      *
2400 \subsection{Conditional jumps}
2401 %*                                                                      *
2402 %************************************************************************
2403
2404 Conditional jumps are always to local labels, so we can use branch
2405 instructions.  We peek at the arguments to decide what kind of
2406 comparison to do.
2407
2408 ALPHA: For comparisons with 0, we're laughing, because we can just do
2409 the desired conditional branch.
2410
2411 I386: First, we have to ensure that the condition
2412 codes are set according to the supplied comparison operation.
2413
2414 SPARC: First, we have to ensure that the condition codes are set
2415 according to the supplied comparison operation.  We generate slightly
2416 different code for floating point comparisons, because a floating
2417 point operation cannot directly precede a @BF@.  We assume the worst
2418 and fill that slot with a @NOP@.
2419
2420 SPARC: Do not fill the delay slots here; you will confuse the register
2421 allocator.
2422
2423 \begin{code}
2424 genCondJump
2425     :: CLabel       -- the branch target
2426     -> StixExpr     -- the condition on which to branch
2427     -> NatM InstrBlock
2428
2429 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2430
2431 #if alpha_TARGET_ARCH
2432
2433 genCondJump lbl (StPrim op [x, StInt 0])
2434   = getRegister x                           `thenNat` \ register ->
2435     getNewRegNCG (registerRep register)
2436                                     `thenNat` \ tmp ->
2437     let
2438         code   = registerCode register tmp
2439         value  = registerName register tmp
2440         pk     = registerRep register
2441         target = ImmCLbl lbl
2442     in
2443     returnSeq code [BI (cmpOp op) value target]
2444   where
2445     cmpOp CharGtOp = GTT
2446     cmpOp CharGeOp = GE
2447     cmpOp CharEqOp = EQQ
2448     cmpOp CharNeOp = NE
2449     cmpOp CharLtOp = LTT
2450     cmpOp CharLeOp = LE
2451     cmpOp IntGtOp = GTT
2452     cmpOp IntGeOp = GE
2453     cmpOp IntEqOp = EQQ
2454     cmpOp IntNeOp = NE
2455     cmpOp IntLtOp = LTT
2456     cmpOp IntLeOp = LE
2457     cmpOp WordGtOp = NE
2458     cmpOp WordGeOp = ALWAYS
2459     cmpOp WordEqOp = EQQ
2460     cmpOp WordNeOp = NE
2461     cmpOp WordLtOp = NEVER
2462     cmpOp WordLeOp = EQQ
2463     cmpOp AddrGtOp = NE
2464     cmpOp AddrGeOp = ALWAYS
2465     cmpOp AddrEqOp = EQQ
2466     cmpOp AddrNeOp = NE
2467     cmpOp AddrLtOp = NEVER
2468     cmpOp AddrLeOp = EQQ
2469
2470 genCondJump lbl (StPrim op [x, StDouble 0.0])
2471   = getRegister x                           `thenNat` \ register ->
2472     getNewRegNCG (registerRep register)
2473                                     `thenNat` \ tmp ->
2474     let
2475         code   = registerCode register tmp
2476         value  = registerName register tmp
2477         pk     = registerRep register
2478         target = ImmCLbl lbl
2479     in
2480     returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2481   where
2482     cmpOp FloatGtOp = GTT
2483     cmpOp FloatGeOp = GE
2484     cmpOp FloatEqOp = EQQ
2485     cmpOp FloatNeOp = NE
2486     cmpOp FloatLtOp = LTT
2487     cmpOp FloatLeOp = LE
2488     cmpOp DoubleGtOp = GTT
2489     cmpOp DoubleGeOp = GE
2490     cmpOp DoubleEqOp = EQQ
2491     cmpOp DoubleNeOp = NE
2492     cmpOp DoubleLtOp = LTT
2493     cmpOp DoubleLeOp = LE
2494
2495 genCondJump lbl (StPrim op [x, y])
2496   | fltCmpOp op
2497   = trivialFCode pr instr x y       `thenNat` \ register ->
2498     getNewRegNCG DoubleRep          `thenNat` \ tmp ->
2499     let
2500         code   = registerCode register tmp
2501         result = registerName register tmp
2502         target = ImmCLbl lbl
2503     in
2504     returnNat (code . mkSeqInstr (BF cond result target))
2505   where
2506     pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2507
2508     fltCmpOp op = case op of
2509         FloatGtOp -> True
2510         FloatGeOp -> True
2511         FloatEqOp -> True
2512         FloatNeOp -> True
2513         FloatLtOp -> True
2514         FloatLeOp -> True
2515         DoubleGtOp -> True
2516         DoubleGeOp -> True
2517         DoubleEqOp -> True
2518         DoubleNeOp -> True
2519         DoubleLtOp -> True
2520         DoubleLeOp -> True
2521         _ -> False
2522     (instr, cond) = case op of
2523         FloatGtOp -> (FCMP TF LE, EQQ)
2524         FloatGeOp -> (FCMP TF LTT, EQQ)
2525         FloatEqOp -> (FCMP TF EQQ, NE)
2526         FloatNeOp -> (FCMP TF EQQ, EQQ)
2527         FloatLtOp -> (FCMP TF LTT, NE)
2528         FloatLeOp -> (FCMP TF LE, NE)
2529         DoubleGtOp -> (FCMP TF LE, EQQ)
2530         DoubleGeOp -> (FCMP TF LTT, EQQ)
2531         DoubleEqOp -> (FCMP TF EQQ, NE)
2532         DoubleNeOp -> (FCMP TF EQQ, EQQ)
2533         DoubleLtOp -> (FCMP TF LTT, NE)
2534         DoubleLeOp -> (FCMP TF LE, NE)
2535
2536 genCondJump lbl (StPrim op [x, y])
2537   = trivialCode instr x y           `thenNat` \ register ->
2538     getNewRegNCG IntRep             `thenNat` \ tmp ->
2539     let
2540         code   = registerCode register tmp
2541         result = registerName register tmp
2542         target = ImmCLbl lbl
2543     in
2544     returnNat (code . mkSeqInstr (BI cond result target))
2545   where
2546     (instr, cond) = case op of
2547         CharGtOp -> (CMP LE, EQQ)
2548         CharGeOp -> (CMP LTT, EQQ)
2549         CharEqOp -> (CMP EQQ, NE)
2550         CharNeOp -> (CMP EQQ, EQQ)
2551         CharLtOp -> (CMP LTT, NE)
2552         CharLeOp -> (CMP LE, NE)
2553         IntGtOp -> (CMP LE, EQQ)
2554         IntGeOp -> (CMP LTT, EQQ)
2555         IntEqOp -> (CMP EQQ, NE)
2556         IntNeOp -> (CMP EQQ, EQQ)
2557         IntLtOp -> (CMP LTT, NE)
2558         IntLeOp -> (CMP LE, NE)
2559         WordGtOp -> (CMP ULE, EQQ)
2560         WordGeOp -> (CMP ULT, EQQ)
2561         WordEqOp -> (CMP EQQ, NE)
2562         WordNeOp -> (CMP EQQ, EQQ)
2563         WordLtOp -> (CMP ULT, NE)
2564         WordLeOp -> (CMP ULE, NE)
2565         AddrGtOp -> (CMP ULE, EQQ)
2566         AddrGeOp -> (CMP ULT, EQQ)
2567         AddrEqOp -> (CMP EQQ, NE)
2568         AddrNeOp -> (CMP EQQ, EQQ)
2569         AddrLtOp -> (CMP ULT, NE)
2570         AddrLeOp -> (CMP ULE, NE)
2571
2572 #endif {- alpha_TARGET_ARCH -}
2573
2574 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2575
2576 #if i386_TARGET_ARCH
2577
2578 genCondJump lbl bool
2579   = getCondCode bool                `thenNat` \ condition ->
2580     let
2581         code   = condCode condition
2582         cond   = condName condition
2583     in
2584     returnNat (code `snocOL` JXX cond lbl)
2585
2586 #endif {- i386_TARGET_ARCH -}
2587
2588 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2589
2590 #if sparc_TARGET_ARCH
2591
2592 genCondJump lbl bool
2593   = getCondCode bool                `thenNat` \ condition ->
2594     let
2595         code   = condCode condition
2596         cond   = condName condition
2597         target = ImmCLbl lbl
2598     in
2599     returnNat (
2600        code `appOL` 
2601        toOL (
2602          if   condFloat condition 
2603          then [NOP, BF cond False target, NOP]
2604          else [BI cond False target, NOP]
2605        )
2606     )
2607
2608 #endif {- sparc_TARGET_ARCH -}
2609
2610 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2611 \end{code}
2612
2613 %************************************************************************
2614 %*                                                                      *
2615 \subsection{Generating C calls}
2616 %*                                                                      *
2617 %************************************************************************
2618
2619 Now the biggest nightmare---calls.  Most of the nastiness is buried in
2620 @get_arg@, which moves the arguments to the correct registers/stack
2621 locations.  Apart from that, the code is easy.
2622
2623 (If applicable) Do not fill the delay slots here; you will confuse the
2624 register allocator.
2625
2626 \begin{code}
2627 genCCall
2628     :: (Either FAST_STRING StixExpr)    -- function to call
2629     -> CCallConv
2630     -> PrimRep          -- type of the result
2631     -> [StixExpr]       -- arguments (of mixed type)
2632     -> NatM InstrBlock
2633
2634 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2635
2636 #if alpha_TARGET_ARCH
2637
2638 genCCall fn cconv kind args
2639   = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2640                           `thenNat` \ ((unused,_), argCode) ->
2641     let
2642         nRegs = length allArgRegs - length unused
2643         code = asmSeqThen (map ($ []) argCode)
2644     in
2645         returnSeq code [
2646             LDA pv (AddrImm (ImmLab (ptext fn))),
2647             JSR ra (AddrReg pv) nRegs,
2648             LDGP gp (AddrReg ra)]
2649   where
2650     ------------------------
2651     {-  Try to get a value into a specific register (or registers) for
2652         a call.  The first 6 arguments go into the appropriate
2653         argument register (separate registers for integer and floating
2654         point arguments, but used in lock-step), and the remaining
2655         arguments are dumped to the stack, beginning at 0(sp).  Our
2656         first argument is a pair of the list of remaining argument
2657         registers to be assigned for this call and the next stack
2658         offset to use for overflowing arguments.  This way,
2659         @get_Arg@ can be applied to all of a call's arguments using
2660         @mapAccumLNat@.
2661     -}
2662     get_arg
2663         :: ([(Reg,Reg)], Int)   -- Argument registers and stack offset (accumulator)
2664         -> StixTree             -- Current argument
2665         -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2666
2667     -- We have to use up all of our argument registers first...
2668
2669     get_arg ((iDst,fDst):dsts, offset) arg
2670       = getRegister arg                     `thenNat` \ register ->
2671         let
2672             reg  = if isFloatingRep pk then fDst else iDst
2673             code = registerCode register reg
2674             src  = registerName register reg
2675             pk   = registerRep register
2676         in
2677         returnNat (
2678             if isFloatingRep pk then
2679                 ((dsts, offset), if isFixed register then
2680                     code . mkSeqInstr (FMOV src fDst)
2681                     else code)
2682             else
2683                 ((dsts, offset), if isFixed register then
2684                     code . mkSeqInstr (OR src (RIReg src) iDst)
2685                     else code))
2686
2687     -- Once we have run out of argument registers, we move to the
2688     -- stack...
2689
2690     get_arg ([], offset) arg
2691       = getRegister arg                 `thenNat` \ register ->
2692         getNewRegNCG (registerRep register)
2693                                         `thenNat` \ tmp ->
2694         let
2695             code = registerCode register tmp
2696             src  = registerName register tmp
2697             pk   = registerRep register
2698             sz   = primRepToSize pk
2699         in
2700         returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2701
2702 #endif {- alpha_TARGET_ARCH -}
2703
2704 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2705
2706 #if i386_TARGET_ARCH
2707
2708 genCCall fn cconv ret_rep args
2709   = mapNat push_arg
2710            (reverse args)       `thenNat` \ sizes_n_codes ->
2711     getDeltaNat                 `thenNat` \ delta ->
2712     let (sizes, push_codes) = unzip sizes_n_codes
2713         tot_arg_size        = sum sizes
2714     in
2715     -- deal with static vs dynamic call targets
2716     (case fn of
2717         Left t_static 
2718            -> returnNat (unitOL (CALL (Left (fn__2 tot_arg_size))))
2719         Right dyn 
2720            -> get_op dyn `thenNat` \ (dyn_c, dyn_r, dyn_rep) ->
2721               ASSERT(case dyn_rep of { L -> True; _ -> False})
2722               returnNat (dyn_c `snocOL` CALL (Right dyn_r))
2723     ) 
2724                                 `thenNat` \ callinsns ->
2725     let push_code = concatOL push_codes
2726         call = callinsns `appOL`
2727                toOL (
2728                         -- Deallocate parameters after call for ccall;
2729                         -- but not for stdcall (callee does it)
2730                   (if cconv == StdCallConv then [] else 
2731                    [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
2732                   ++
2733                   [DELTA (delta + tot_arg_size)]
2734                )
2735     in
2736     setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
2737     returnNat (push_code `appOL` call)
2738
2739   where
2740     -- function names that begin with '.' are assumed to be special
2741     -- internally generated names like '.mul,' which don't get an
2742     -- underscore prefix
2743     -- ToDo:needed (WDP 96/03) ???
2744     fn_u  = _UNPK_ (unLeft fn)
2745     fn__2 tot_arg_size
2746        | head fn_u == '.'
2747        = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
2748        | otherwise      -- General case
2749        = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
2750
2751     stdcallsize tot_arg_size
2752        | cconv == StdCallConv = '@':show tot_arg_size
2753        | otherwise            = ""
2754
2755     -- floats are always promoted to doubles when passed to a ccall
2756     promote_size F  = DF
2757     promote_size sz = sz
2758
2759     arg_size DF = 8
2760     arg_size F  = 4
2761     arg_size _  = 4
2762
2763     ------------
2764     push_arg :: StixExpr{-current argument-}
2765                     -> NatM (Int, InstrBlock)  -- argsz, code
2766
2767     push_arg arg
2768       | is64BitRep arg_rep
2769       = iselExpr64 arg                  `thenNat` \ (ChildCode64 code vr_lo) ->
2770         getDeltaNat                     `thenNat` \ delta ->
2771         setDeltaNat (delta - 8)         `thenNat` \ _ ->
2772         let r_lo = VirtualRegI vr_lo
2773             r_hi = getHiVRegFromLo r_lo
2774         in  returnNat (8,
2775                        code `appOL`
2776                        toOL [PUSH L (OpReg r_hi), DELTA (delta - 4),
2777                              PUSH L (OpReg r_lo), DELTA (delta - 8)]
2778             )
2779       | otherwise
2780       = get_op arg                      `thenNat` \ (code, reg, sz) ->
2781         getDeltaNat                     `thenNat` \ delta ->
2782         let 
2783                 real_sz = promote_size sz
2784                 size    = arg_size real_sz
2785         in
2786         setDeltaNat (delta-size)        `thenNat` \ _ ->
2787         if   (case real_sz of DF -> True; _ -> False)
2788         then returnNat (size,
2789                         code `appOL`
2790                         toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
2791                               DELTA (delta-size),
2792                               GST DF reg (AddrBaseIndex (Just esp) 
2793                                                         Nothing 
2794                                                         (ImmInt 0))]
2795                        )
2796         else returnNat (size,
2797                         code `snocOL`
2798                         PUSH L (OpReg reg) `snocOL`
2799                         DELTA (delta-size)
2800                        )
2801       where
2802          arg_rep = repOfStixExpr arg
2803
2804     ------------
2805     get_op
2806         :: StixExpr
2807         -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2808
2809     get_op op
2810       = getRegister op          `thenNat` \ register ->
2811         getNewRegNCG (registerRep register)
2812                                 `thenNat` \ tmp ->
2813         let
2814             code = registerCode register tmp
2815             reg  = registerName register tmp
2816             pk   = registerRep  register
2817             sz   = primRepToSize pk
2818         in
2819         returnNat (code, reg, sz)
2820
2821 #endif {- i386_TARGET_ARCH -}
2822
2823 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2824
2825 #if sparc_TARGET_ARCH
2826 {- 
2827    The SPARC calling convention is an absolute
2828    nightmare.  The first 6x32 bits of arguments are mapped into
2829    %o0 through %o5, and the remaining arguments are dumped to the
2830    stack, beginning at [%sp+92].  (Note that %o6 == %sp.)
2831
2832    If we have to put args on the stack, move %o6==%sp down by
2833    the number of words to go on the stack, to ensure there's enough space.
2834
2835    According to Fraser and Hanson's lcc book, page 478, fig 17.2,
2836    16 words above the stack pointer is a word for the address of
2837    a structure return value.  I use this as a temporary location
2838    for moving values from float to int regs.  Certainly it isn't
2839    safe to put anything in the 16 words starting at %sp, since
2840    this area can get trashed at any time due to window overflows
2841    caused by signal handlers.
2842
2843    A final complication (if the above isn't enough) is that 
2844    we can't blithely calculate the arguments one by one into
2845    %o0 .. %o5.  Consider the following nested calls:
2846
2847        fff a (fff b c)
2848
2849    Naive code moves a into %o0, and (fff b c) into %o1.  Unfortunately
2850    the inner call will itself use %o0, which trashes the value put there
2851    in preparation for the outer call.  Upshot: we need to calculate the
2852    args into temporary regs, and move those to arg regs or onto the
2853    stack only immediately prior to the call proper.  Sigh.
2854 -}
2855
2856 genCCall fn cconv kind args
2857   = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
2858     let 
2859         (argcodes, vregss) = unzip argcode_and_vregs
2860         n_argRegs          = length allArgRegs
2861         n_argRegs_used     = min (length vregs) n_argRegs
2862         vregs              = concat vregss
2863     in
2864     -- deal with static vs dynamic call targets
2865     (case fn of
2866         Left t_static
2867            -> returnNat (unitOL (CALL (Left fn__2) n_argRegs_used False))
2868         Right dyn
2869            -> arg_to_int_vregs dyn `thenNat` \ (dyn_c, [dyn_r]) ->
2870               returnNat (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
2871     )
2872                                 `thenNat` \ callinsns ->
2873     let
2874         argcode = concatOL argcodes
2875         (move_sp_down, move_sp_up)
2876            = let nn = length vregs - n_argRegs 
2877                                    + 1 -- (for the road)
2878              in  if   nn <= 0
2879                  then (nilOL, nilOL)
2880                  else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
2881         transfer_code
2882            = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
2883     in
2884         returnNat (argcode       `appOL`
2885                    move_sp_down  `appOL`
2886                    transfer_code `appOL`
2887                    callinsns     `appOL`
2888                    unitOL NOP    `appOL`
2889                    move_sp_up)
2890   where
2891      -- function names that begin with '.' are assumed to be special
2892      -- internally generated names like '.mul,' which don't get an
2893      -- underscore prefix
2894      -- ToDo:needed (WDP 96/03) ???
2895      fn_static = unLeft fn
2896      fn__2 = case (_HEAD_ fn_static) of
2897                 '.' -> ImmLit (ptext fn_static)
2898                 _   -> ImmLab False (ptext fn_static)
2899
2900      -- move args from the integer vregs into which they have been 
2901      -- marshalled, into %o0 .. %o5, and the rest onto the stack.
2902      move_final :: [Reg] -> [Reg] -> Int -> [Instr]
2903
2904      move_final [] _ offset          -- all args done
2905         = []
2906
2907      move_final (v:vs) [] offset     -- out of aregs; move to stack
2908         = ST W v (spRel offset)
2909           : move_final vs [] (offset+1)
2910
2911      move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
2912         = OR False g0 (RIReg v) a
2913           : move_final vs az offset
2914
2915      -- generate code to calculate an argument, and move it into one
2916      -- or two integer vregs.
2917      arg_to_int_vregs :: StixExpr -> NatM (OrdList Instr, [Reg])
2918      arg_to_int_vregs arg
2919         | is64BitRep (repOfStixExpr arg)
2920         = iselExpr64 arg                `thenNat` \ (ChildCode64 code vr_lo) ->
2921           let r_lo = VirtualRegI vr_lo
2922               r_hi = getHiVRegFromLo r_lo
2923           in  returnNat (code, [r_hi, r_lo])
2924         | otherwise
2925         = getRegister arg                     `thenNat` \ register ->
2926           getNewRegNCG (registerRep register) `thenNat` \ tmp ->
2927           let code = registerCode register tmp
2928               src  = registerName register tmp
2929               pk   = registerRep register
2930           in
2931           -- the value is in src.  Get it into 1 or 2 int vregs.
2932           case pk of
2933              DoubleRep -> 
2934                 getNewRegNCG WordRep  `thenNat` \ v1 ->
2935                 getNewRegNCG WordRep  `thenNat` \ v2 ->
2936                 returnNat (
2937                    code                          `snocOL`
2938                    FMOV DF src f0                `snocOL`
2939                    ST   F  f0 (spRel 16)         `snocOL`
2940                    LD   W  (spRel 16) v1         `snocOL`
2941                    ST   F  (fPair f0) (spRel 16) `snocOL`
2942                    LD   W  (spRel 16) v2
2943                    ,
2944                    [v1,v2]
2945                 )
2946              FloatRep -> 
2947                 getNewRegNCG WordRep  `thenNat` \ v1 ->
2948                 returnNat (
2949                    code                    `snocOL`
2950                    ST   F  src (spRel 16)  `snocOL`
2951                    LD   W  (spRel 16) v1
2952                    ,
2953                    [v1]
2954                 )
2955              other ->
2956                 getNewRegNCG WordRep  `thenNat` \ v1 ->
2957                 returnNat (
2958                    code `snocOL` OR False g0 (RIReg src) v1
2959                    , 
2960                    [v1]
2961                 )
2962 #endif {- sparc_TARGET_ARCH -}
2963
2964 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2965 \end{code}
2966
2967 %************************************************************************
2968 %*                                                                      *
2969 \subsection{Support bits}
2970 %*                                                                      *
2971 %************************************************************************
2972
2973 %************************************************************************
2974 %*                                                                      *
2975 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2976 %*                                                                      *
2977 %************************************************************************
2978
2979 Turn those condition codes into integers now (when they appear on
2980 the right hand side of an assignment).
2981
2982 (If applicable) Do not fill the delay slots here; you will confuse the
2983 register allocator.
2984
2985 \begin{code}
2986 condIntReg, condFltReg :: Cond -> StixExpr -> StixExpr -> NatM Register
2987
2988 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2989
2990 #if alpha_TARGET_ARCH
2991 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2992 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2993 #endif {- alpha_TARGET_ARCH -}
2994
2995 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2996
2997 #if i386_TARGET_ARCH
2998
2999 condIntReg cond x y
3000   = condIntCode cond x y        `thenNat` \ condition ->
3001     getNewRegNCG IntRep         `thenNat` \ tmp ->
3002     let
3003         code = condCode condition
3004         cond = condName condition
3005         code__2 dst = code `appOL` toOL [
3006             SETCC cond (OpReg tmp),
3007             AND L (OpImm (ImmInt 1)) (OpReg tmp),
3008             MOV L (OpReg tmp) (OpReg dst)]
3009     in
3010     returnNat (Any IntRep code__2)
3011
3012 condFltReg cond x y
3013   = getNatLabelNCG              `thenNat` \ lbl1 ->
3014     getNatLabelNCG              `thenNat` \ lbl2 ->
3015     condFltCode cond x y        `thenNat` \ condition ->
3016     let
3017         code = condCode condition
3018         cond = condName condition
3019         code__2 dst = code `appOL` toOL [
3020             JXX cond lbl1,
3021             MOV L (OpImm (ImmInt 0)) (OpReg dst),
3022             JXX ALWAYS lbl2,
3023             LABEL lbl1,
3024             MOV L (OpImm (ImmInt 1)) (OpReg dst),
3025             LABEL lbl2]
3026     in
3027     returnNat (Any IntRep code__2)
3028
3029 #endif {- i386_TARGET_ARCH -}
3030
3031 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3032
3033 #if sparc_TARGET_ARCH
3034
3035 condIntReg EQQ x (StInt 0)
3036   = getRegister x               `thenNat` \ register ->
3037     getNewRegNCG IntRep         `thenNat` \ tmp ->
3038     let
3039         code = registerCode register tmp
3040         src  = registerName register tmp
3041         code__2 dst = code `appOL` toOL [
3042             SUB False True g0 (RIReg src) g0,
3043             SUB True False g0 (RIImm (ImmInt (-1))) dst]
3044     in
3045     returnNat (Any IntRep code__2)
3046
3047 condIntReg EQQ x y
3048   = getRegister x               `thenNat` \ register1 ->
3049     getRegister y               `thenNat` \ register2 ->
3050     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
3051     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
3052     let
3053         code1 = registerCode register1 tmp1
3054         src1  = registerName register1 tmp1
3055         code2 = registerCode register2 tmp2
3056         src2  = registerName register2 tmp2
3057         code__2 dst = code1 `appOL` code2 `appOL` toOL [
3058             XOR False src1 (RIReg src2) dst,
3059             SUB False True g0 (RIReg dst) g0,
3060             SUB True False g0 (RIImm (ImmInt (-1))) dst]
3061     in
3062     returnNat (Any IntRep code__2)
3063
3064 condIntReg NE x (StInt 0)
3065   = getRegister x               `thenNat` \ register ->
3066     getNewRegNCG IntRep         `thenNat` \ tmp ->
3067     let
3068         code = registerCode register tmp
3069         src  = registerName register tmp
3070         code__2 dst = code `appOL` toOL [
3071             SUB False True g0 (RIReg src) g0,
3072             ADD True False g0 (RIImm (ImmInt 0)) dst]
3073     in
3074     returnNat (Any IntRep code__2)
3075
3076 condIntReg NE x y
3077   = getRegister x               `thenNat` \ register1 ->
3078     getRegister y               `thenNat` \ register2 ->
3079     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
3080     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
3081     let
3082         code1 = registerCode register1 tmp1
3083         src1  = registerName register1 tmp1
3084         code2 = registerCode register2 tmp2
3085         src2  = registerName register2 tmp2
3086         code__2 dst = code1 `appOL` code2 `appOL` toOL [
3087             XOR False src1 (RIReg src2) dst,
3088             SUB False True g0 (RIReg dst) g0,
3089             ADD True False g0 (RIImm (ImmInt 0)) dst]
3090     in
3091     returnNat (Any IntRep code__2)
3092
3093 condIntReg cond x y
3094   = getNatLabelNCG              `thenNat` \ lbl1 ->
3095     getNatLabelNCG              `thenNat` \ lbl2 ->
3096     condIntCode cond x y        `thenNat` \ condition ->
3097     let
3098         code = condCode condition
3099         cond = condName condition
3100         code__2 dst = code `appOL` toOL [
3101             BI cond False (ImmCLbl lbl1), NOP,
3102             OR False g0 (RIImm (ImmInt 0)) dst,
3103             BI ALWAYS False (ImmCLbl lbl2), NOP,
3104             LABEL lbl1,
3105             OR False g0 (RIImm (ImmInt 1)) dst,
3106             LABEL lbl2]
3107     in
3108     returnNat (Any IntRep code__2)
3109
3110 condFltReg cond x y
3111   = getNatLabelNCG              `thenNat` \ lbl1 ->
3112     getNatLabelNCG              `thenNat` \ lbl2 ->
3113     condFltCode cond x y        `thenNat` \ condition ->
3114     let
3115         code = condCode condition
3116         cond = condName condition
3117         code__2 dst = code `appOL` toOL [
3118             NOP,
3119             BF cond False (ImmCLbl lbl1), NOP,
3120             OR False g0 (RIImm (ImmInt 0)) dst,
3121             BI ALWAYS False (ImmCLbl lbl2), NOP,
3122             LABEL lbl1,
3123             OR False g0 (RIImm (ImmInt 1)) dst,
3124             LABEL lbl2]
3125     in
3126     returnNat (Any IntRep code__2)
3127
3128 #endif {- sparc_TARGET_ARCH -}
3129
3130 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3131 \end{code}
3132
3133 %************************************************************************
3134 %*                                                                      *
3135 \subsubsection{@trivial*Code@: deal with trivial instructions}
3136 %*                                                                      *
3137 %************************************************************************
3138
3139 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
3140 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions.  Only look
3141 for constants on the right hand side, because that's where the generic
3142 optimizer will have put them.
3143
3144 Similarly, for unary instructions, we don't have to worry about
3145 matching an StInt as the argument, because genericOpt will already
3146 have handled the constant-folding.
3147
3148 \begin{code}
3149 trivialCode
3150     :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
3151       ,IF_ARCH_i386 ((Operand -> Operand -> Instr) 
3152                      -> Maybe (Operand -> Operand -> Instr)
3153       ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
3154       ,)))
3155     -> StixExpr -> StixExpr -- the two arguments
3156     -> NatM Register
3157
3158 trivialFCode
3159     :: PrimRep
3160     -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
3161       ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
3162       ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
3163       ,)))
3164     -> StixExpr -> StixExpr -- the two arguments
3165     -> NatM Register
3166
3167 trivialUCode
3168     :: IF_ARCH_alpha((RI -> Reg -> Instr)
3169       ,IF_ARCH_i386 ((Operand -> Instr)
3170       ,IF_ARCH_sparc((RI -> Reg -> Instr)
3171       ,)))
3172     -> StixExpr -- the one argument
3173     -> NatM Register
3174
3175 trivialUFCode
3176     :: PrimRep
3177     -> IF_ARCH_alpha((Reg -> Reg -> Instr)
3178       ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
3179       ,IF_ARCH_sparc((Reg -> Reg -> Instr)
3180       ,)))
3181     -> StixExpr -- the one argument
3182     -> NatM Register
3183
3184 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3185
3186 #if alpha_TARGET_ARCH
3187
3188 trivialCode instr x (StInt y)
3189   | fits8Bits y
3190   = getRegister x               `thenNat` \ register ->
3191     getNewRegNCG IntRep         `thenNat` \ tmp ->
3192     let
3193         code = registerCode register tmp
3194         src1 = registerName register tmp
3195         src2 = ImmInt (fromInteger y)
3196         code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
3197     in
3198     returnNat (Any IntRep code__2)
3199
3200 trivialCode instr x y
3201   = getRegister x               `thenNat` \ register1 ->
3202     getRegister y               `thenNat` \ register2 ->
3203     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
3204     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
3205     let
3206         code1 = registerCode register1 tmp1 []
3207         src1  = registerName register1 tmp1
3208         code2 = registerCode register2 tmp2 []
3209         src2  = registerName register2 tmp2
3210         code__2 dst = asmSeqThen [code1, code2] .
3211                      mkSeqInstr (instr src1 (RIReg src2) dst)
3212     in
3213     returnNat (Any IntRep code__2)
3214
3215 ------------
3216 trivialUCode instr x
3217   = getRegister x               `thenNat` \ register ->
3218     getNewRegNCG IntRep         `thenNat` \ tmp ->
3219     let
3220         code = registerCode register tmp
3221         src  = registerName register tmp
3222         code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
3223     in
3224     returnNat (Any IntRep code__2)
3225
3226 ------------
3227 trivialFCode _ instr x y
3228   = getRegister x               `thenNat` \ register1 ->
3229     getRegister y               `thenNat` \ register2 ->
3230     getNewRegNCG DoubleRep      `thenNat` \ tmp1 ->
3231     getNewRegNCG DoubleRep      `thenNat` \ tmp2 ->
3232     let
3233         code1 = registerCode register1 tmp1
3234         src1  = registerName register1 tmp1
3235
3236         code2 = registerCode register2 tmp2
3237         src2  = registerName register2 tmp2
3238
3239         code__2 dst = asmSeqThen [code1 [], code2 []] .
3240                       mkSeqInstr (instr src1 src2 dst)
3241     in
3242     returnNat (Any DoubleRep code__2)
3243
3244 trivialUFCode _ instr x
3245   = getRegister x               `thenNat` \ register ->
3246     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
3247     let
3248         code = registerCode register tmp
3249         src  = registerName register tmp
3250         code__2 dst = code . mkSeqInstr (instr src dst)
3251     in
3252     returnNat (Any DoubleRep code__2)
3253
3254 #endif {- alpha_TARGET_ARCH -}
3255
3256 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3257
3258 #if i386_TARGET_ARCH
3259 \end{code}
3260 The Rules of the Game are:
3261
3262 * You cannot assume anything about the destination register dst;
3263   it may be anything, including a fixed reg.
3264
3265 * You may compute an operand into a fixed reg, but you may not 
3266   subsequently change the contents of that fixed reg.  If you
3267   want to do so, first copy the value either to a temporary
3268   or into dst.  You are free to modify dst even if it happens
3269   to be a fixed reg -- that's not your problem.
3270
3271 * You cannot assume that a fixed reg will stay live over an
3272   arbitrary computation.  The same applies to the dst reg.
3273
3274 * Temporary regs obtained from getNewRegNCG are distinct from 
3275   each other and from all other regs, and stay live over 
3276   arbitrary computations.
3277
3278 \begin{code}
3279
3280 trivialCode instr maybe_revinstr a b
3281
3282   | is_imm_b
3283   = getRegister a                         `thenNat` \ rega ->
3284     let mkcode dst
3285           = if   isAny rega 
3286             then registerCode rega dst      `bind` \ code_a ->
3287                  code_a `snocOL`
3288                  instr (OpImm imm_b) (OpReg dst)
3289             else registerCodeF rega         `bind` \ code_a ->
3290                  registerNameF rega         `bind` \ r_a ->
3291                  code_a `snocOL`
3292                  MOV L (OpReg r_a) (OpReg dst) `snocOL`
3293                  instr (OpImm imm_b) (OpReg dst)
3294     in
3295     returnNat (Any IntRep mkcode)
3296               
3297   | is_imm_a
3298   = getRegister b                         `thenNat` \ regb ->
3299     getNewRegNCG IntRep                   `thenNat` \ tmp ->
3300     let revinstr_avail = maybeToBool maybe_revinstr
3301         revinstr       = case maybe_revinstr of Just ri -> ri
3302         mkcode dst
3303           | revinstr_avail
3304           = if   isAny regb
3305             then registerCode regb dst      `bind` \ code_b ->
3306                  code_b `snocOL`
3307                  revinstr (OpImm imm_a) (OpReg dst)
3308             else registerCodeF regb         `bind` \ code_b ->
3309                  registerNameF regb         `bind` \ r_b ->
3310                  code_b `snocOL`
3311                  MOV L (OpReg r_b) (OpReg dst) `snocOL`
3312                  revinstr (OpImm imm_a) (OpReg dst)
3313           
3314           | otherwise
3315           = if   isAny regb
3316             then registerCode regb tmp      `bind` \ code_b ->
3317                  code_b `snocOL`
3318                  MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3319                  instr (OpReg tmp) (OpReg dst)
3320             else registerCodeF regb         `bind` \ code_b ->
3321                  registerNameF regb         `bind` \ r_b ->
3322                  code_b `snocOL`
3323                  MOV L (OpReg r_b) (OpReg tmp) `snocOL`
3324                  MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3325                  instr (OpReg tmp) (OpReg dst)
3326     in
3327     returnNat (Any IntRep mkcode)
3328
3329   | otherwise
3330   = getRegister a                         `thenNat` \ rega ->
3331     getRegister b                         `thenNat` \ regb ->
3332     getNewRegNCG IntRep                   `thenNat` \ tmp ->
3333     let mkcode dst
3334           = case (isAny rega, isAny regb) of
3335               (True, True) 
3336                  -> registerCode regb tmp   `bind` \ code_b ->
3337                     registerCode rega dst   `bind` \ code_a ->
3338                     code_b `appOL`
3339                     code_a `snocOL`
3340                     instr (OpReg tmp) (OpReg dst)
3341               (True, False)
3342                  -> registerCode  rega tmp  `bind` \ code_a ->
3343                     registerCodeF regb      `bind` \ code_b ->
3344                     registerNameF regb      `bind` \ r_b ->
3345                     code_a `appOL`
3346                     code_b `snocOL`
3347                     instr (OpReg r_b) (OpReg tmp) `snocOL`
3348                     MOV L (OpReg tmp) (OpReg dst)
3349               (False, True)
3350                  -> registerCode  regb tmp  `bind` \ code_b ->
3351                     registerCodeF rega      `bind` \ code_a ->
3352                     registerNameF rega      `bind` \ r_a ->
3353                     code_b `appOL`
3354                     code_a `snocOL`
3355                     MOV L (OpReg r_a) (OpReg dst) `snocOL`
3356                     instr (OpReg tmp) (OpReg dst)
3357               (False, False)
3358                  -> registerCodeF  rega     `bind` \ code_a ->
3359                     registerNameF  rega     `bind` \ r_a ->
3360                     registerCodeF  regb     `bind` \ code_b ->
3361                     registerNameF  regb     `bind` \ r_b ->
3362                     code_a `snocOL`
3363                     MOV L (OpReg r_a) (OpReg tmp) `appOL`
3364                     code_b `snocOL`
3365                     instr (OpReg r_b) (OpReg tmp) `snocOL`
3366                     MOV L (OpReg tmp) (OpReg dst)
3367     in
3368     returnNat (Any IntRep mkcode)
3369
3370     where
3371        maybe_imm_a = maybeImm a
3372        is_imm_a    = maybeToBool maybe_imm_a
3373        imm_a       = case maybe_imm_a of Just imm -> imm
3374
3375        maybe_imm_b = maybeImm b
3376        is_imm_b    = maybeToBool maybe_imm_b
3377        imm_b       = case maybe_imm_b of Just imm -> imm
3378
3379
3380 -----------
3381 trivialUCode instr x
3382   = getRegister x               `thenNat` \ register ->
3383     let
3384         code__2 dst = let code = registerCode register dst
3385                           src  = registerName register dst
3386                       in code `appOL`
3387                          if   isFixed register && dst /= src
3388                          then toOL [MOV L (OpReg src) (OpReg dst),
3389                                     instr (OpReg dst)]
3390                          else unitOL (instr (OpReg src))
3391     in
3392     returnNat (Any IntRep code__2)
3393
3394 -----------
3395 trivialFCode pk instr x y
3396   = getRegister x               `thenNat` \ register1 ->
3397     getRegister y               `thenNat` \ register2 ->
3398     getNewRegNCG DoubleRep      `thenNat` \ tmp1 ->
3399     getNewRegNCG DoubleRep      `thenNat` \ tmp2 ->
3400     let
3401         code1 = registerCode register1 tmp1
3402         src1  = registerName register1 tmp1
3403
3404         code2 = registerCode register2 tmp2
3405         src2  = registerName register2 tmp2
3406
3407         code__2 dst
3408            -- treat the common case specially: both operands in
3409            -- non-fixed regs.
3410            | isAny register1 && isAny register2
3411            = code1 `appOL` 
3412              code2 `snocOL`
3413              instr (primRepToSize pk) src1 src2 dst
3414
3415            -- be paranoid (and inefficient)
3416            | otherwise
3417            = code1 `snocOL` GMOV src1 tmp1  `appOL`
3418              code2 `snocOL`
3419              instr (primRepToSize pk) tmp1 src2 dst
3420     in
3421     returnNat (Any pk code__2)
3422
3423
3424 -------------
3425 trivialUFCode pk instr x
3426   = getRegister x               `thenNat` \ register ->
3427     getNewRegNCG pk             `thenNat` \ tmp ->
3428     let
3429         code = registerCode register tmp
3430         src  = registerName register tmp
3431         code__2 dst = code `snocOL` instr src dst
3432     in
3433     returnNat (Any pk code__2)
3434
3435 #endif {- i386_TARGET_ARCH -}
3436
3437 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3438
3439 #if sparc_TARGET_ARCH
3440
3441 trivialCode instr x (StInt y)
3442   | fits13Bits y
3443   = getRegister x               `thenNat` \ register ->
3444     getNewRegNCG IntRep         `thenNat` \ tmp ->
3445     let
3446         code = registerCode register tmp
3447         src1 = registerName register tmp
3448         src2 = ImmInt (fromInteger y)
3449         code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
3450     in
3451     returnNat (Any IntRep code__2)
3452
3453 trivialCode instr x y
3454   = getRegister x               `thenNat` \ register1 ->
3455     getRegister y               `thenNat` \ register2 ->
3456     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
3457     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
3458     let
3459         code1 = registerCode register1 tmp1
3460         src1  = registerName register1 tmp1
3461         code2 = registerCode register2 tmp2
3462         src2  = registerName register2 tmp2
3463         code__2 dst = code1 `appOL` code2 `snocOL`
3464                       instr src1 (RIReg src2) dst
3465     in
3466     returnNat (Any IntRep code__2)
3467
3468 ------------
3469 trivialFCode pk instr x y
3470   = getRegister x               `thenNat` \ register1 ->
3471     getRegister y               `thenNat` \ register2 ->
3472     getNewRegNCG (registerRep register1)
3473                                 `thenNat` \ tmp1 ->
3474     getNewRegNCG (registerRep register2)
3475                                 `thenNat` \ tmp2 ->
3476     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
3477     let
3478         promote x = FxTOy F DF x tmp
3479
3480         pk1   = registerRep register1
3481         code1 = registerCode register1 tmp1
3482         src1  = registerName register1 tmp1
3483
3484         pk2   = registerRep register2
3485         code2 = registerCode register2 tmp2
3486         src2  = registerName register2 tmp2
3487
3488         code__2 dst =
3489                 if pk1 == pk2 then
3490                     code1 `appOL` code2 `snocOL`
3491                     instr (primRepToSize pk) src1 src2 dst
3492                 else if pk1 == FloatRep then
3493                     code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3494                     instr DF tmp src2 dst
3495                 else
3496                     code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3497                     instr DF src1 tmp dst
3498     in
3499     returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3500
3501 ------------
3502 trivialUCode instr x
3503   = getRegister x               `thenNat` \ register ->
3504     getNewRegNCG IntRep         `thenNat` \ tmp ->
3505     let
3506         code = registerCode register tmp
3507         src  = registerName register tmp
3508         code__2 dst = code `snocOL` instr (RIReg src) dst
3509     in
3510     returnNat (Any IntRep code__2)
3511
3512 -------------
3513 trivialUFCode pk instr x
3514   = getRegister x               `thenNat` \ register ->
3515     getNewRegNCG pk             `thenNat` \ tmp ->
3516     let
3517         code = registerCode register tmp
3518         src  = registerName register tmp
3519         code__2 dst = code `snocOL` instr src dst
3520     in
3521     returnNat (Any pk code__2)
3522
3523 #endif {- sparc_TARGET_ARCH -}
3524
3525 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3526 \end{code}
3527
3528 %************************************************************************
3529 %*                                                                      *
3530 \subsubsection{Coercing to/from integer/floating-point...}
3531 %*                                                                      *
3532 %************************************************************************
3533
3534 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3535 conversions.  We have to store temporaries in memory to move
3536 between the integer and the floating point register sets.
3537
3538 @coerceDbl2Flt@ and @coerceFlt2Dbl@ are done this way because we
3539 pretend, on sparc at least, that double and float regs are seperate
3540 kinds, so the value has to be computed into one kind before being
3541 explicitly "converted" to live in the other kind.
3542
3543 \begin{code}
3544 coerceInt2FP :: PrimRep -> StixExpr -> NatM Register
3545 coerceFP2Int :: PrimRep -> StixExpr -> NatM Register
3546
3547 coerceDbl2Flt :: StixExpr -> NatM Register
3548 coerceFlt2Dbl :: StixExpr -> NatM Register
3549 \end{code}
3550
3551 \begin{code}
3552 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3553
3554 #if alpha_TARGET_ARCH
3555
3556 coerceInt2FP _ x
3557   = getRegister x               `thenNat` \ register ->
3558     getNewRegNCG IntRep         `thenNat` \ reg ->
3559     let
3560         code = registerCode register reg
3561         src  = registerName register reg
3562
3563         code__2 dst = code . mkSeqInstrs [
3564             ST Q src (spRel 0),
3565             LD TF dst (spRel 0),
3566             CVTxy Q TF dst dst]
3567     in
3568     returnNat (Any DoubleRep code__2)
3569
3570 -------------
3571 coerceFP2Int x
3572   = getRegister x               `thenNat` \ register ->
3573     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
3574     let
3575         code = registerCode register tmp
3576         src  = registerName register tmp
3577
3578         code__2 dst = code . mkSeqInstrs [
3579             CVTxy TF Q src tmp,
3580             ST TF tmp (spRel 0),
3581             LD Q dst (spRel 0)]
3582     in
3583     returnNat (Any IntRep code__2)
3584
3585 #endif {- alpha_TARGET_ARCH -}
3586
3587 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3588
3589 #if i386_TARGET_ARCH
3590
3591 coerceInt2FP pk x
3592   = getRegister x               `thenNat` \ register ->
3593     getNewRegNCG IntRep         `thenNat` \ reg ->
3594     let
3595         code = registerCode register reg
3596         src  = registerName register reg
3597         opc  = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3598         code__2 dst = code `snocOL` opc src dst
3599     in
3600     returnNat (Any pk code__2)
3601
3602 ------------
3603 coerceFP2Int fprep x
3604   = getRegister x               `thenNat` \ register ->
3605     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
3606     let
3607         code = registerCode register tmp
3608         src  = registerName register tmp
3609         pk   = registerRep register
3610
3611         opc  = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3612         code__2 dst = code `snocOL` opc src dst
3613     in
3614     returnNat (Any IntRep code__2)
3615
3616 ------------
3617 coerceDbl2Flt x = panic "MachCode.coerceDbl2Flt: unused on x86"
3618 coerceFlt2Dbl x = panic "MachCode.coerceFlt2Dbl: unused on x86"
3619
3620 #endif {- i386_TARGET_ARCH -}
3621
3622 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3623
3624 #if sparc_TARGET_ARCH
3625
3626 coerceInt2FP pk x
3627   = getRegister x               `thenNat` \ register ->
3628     getNewRegNCG IntRep         `thenNat` \ reg ->
3629     let
3630         code = registerCode register reg
3631         src  = registerName register reg
3632
3633         code__2 dst = code `appOL` toOL [
3634             ST W src (spRel (-2)),
3635             LD W (spRel (-2)) dst,
3636             FxTOy W (primRepToSize pk) dst dst]
3637     in
3638     returnNat (Any pk code__2)
3639
3640 ------------
3641 coerceFP2Int fprep x
3642   = ASSERT(fprep == DoubleRep || fprep == FloatRep)
3643     getRegister x               `thenNat` \ register ->
3644     getNewRegNCG fprep          `thenNat` \ reg ->
3645     getNewRegNCG FloatRep       `thenNat` \ tmp ->
3646     let
3647         code = registerCode register reg
3648         src  = registerName register reg
3649         code__2 dst = code `appOL` toOL [
3650             FxTOy (primRepToSize fprep) W src tmp,
3651             ST W tmp (spRel (-2)),
3652             LD W (spRel (-2)) dst]
3653     in
3654     returnNat (Any IntRep code__2)
3655
3656 ------------
3657 coerceDbl2Flt x
3658   = getRegister x               `thenNat` \ register ->
3659     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
3660     let code = registerCode register tmp
3661         src  = registerName register tmp
3662     in
3663         returnNat (Any FloatRep 
3664                        (\dst -> code `snocOL` FxTOy DF F src dst)) 
3665
3666 ------------
3667 coerceFlt2Dbl x
3668   = getRegister x               `thenNat` \ register ->
3669     getNewRegNCG FloatRep       `thenNat` \ tmp ->
3670     let code = registerCode register tmp
3671         src  = registerName register tmp
3672     in
3673         returnNat (Any DoubleRep
3674                        (\dst -> code `snocOL` FxTOy F DF src dst)) 
3675
3676 #endif {- sparc_TARGET_ARCH -}
3677
3678 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3679 \end{code}