X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FMachCode.lhs;h=1c00641da7820e547f20146749bf75b1a4f146c5;hb=5248496621bd23d3d42f8e0929278e110797d1c1;hp=a45f7dbc5f5cf42036091e8e4db261121fad9fa3;hpb=77a8c0dbd5c5ad90fe483cb9ddc2b6ef36d3f4d8;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index a45f7db..1c00641 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -9,34 +9,50 @@ This is a big module, but, if you pay attention to structure should not be too overwhelming. \begin{code} -module MachCode ( stmt2Instrs, InstrBlock ) where +module MachCode ( stmtsToInstrs, InstrBlock ) where #include "HsVersions.h" #include "nativeGen/NCG.h" +import Unique ( Unique ) import MachMisc -- may differ per-platform import MachRegs import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL, snocOL, consOL, concatOL ) +import MachOp ( MachOp(..), pprMachOp ) import AbsCUtils ( magicIdPrimRep ) -import CallConv ( CallConv ) -import CLabel ( isAsmTemp, CLabel, pprCLabel_asm, labelDynamic ) -import Maybes ( maybeToBool, expectJust ) -import PrimRep ( isFloatingRep, PrimRep(..) ) -import PrimOp ( PrimOp(..) ) -import CallConv ( cCallConv ) -import Stix ( getNatLabelNCG, StixTree(..), - StixReg(..), CodeSegment(..), - pprStixTree, ppStixReg, +import PprAbsC ( pprMagicId ) +import ForeignCall ( CCallConv(..) ) +import CLabel ( CLabel, labelDynamic ) +#if sparc_TARGET_ARCH || alpha_TARGET_ARCH +import CLabel ( isAsmTemp ) +#endif +import Maybes ( maybeToBool ) +import PrimRep ( isFloatingRep, is64BitRep, PrimRep(..), + getPrimRepArrayElemSize ) +import Stix ( getNatLabelNCG, StixStmt(..), StixExpr(..), + StixReg(..), pprStixReg, StixVReg(..), CodeSegment(..), + DestInfo, hasDestInfo, + pprStixExpr, repOfStixExpr, + liftStrings, NatM, thenNat, returnNat, mapNat, mapAndUnzipNat, mapAccumLNat, - getDeltaNat, setDeltaNat + getDeltaNat, setDeltaNat, getUniqueNat, + ncgPrimopMoan, + ncg_target_is_32bit ) -import Outputable +import Pretty +import Outputable ( panic, pprPanic, showSDoc ) +import qualified Outputable import CmdLineOpts ( opt_Static ) +import Stix ( pprStixStmt ) -infixr 3 `bind` +-- DEBUGGING ONLY +import IOExts ( trace ) +import Outputable ( assertPanic ) +import FastString +infixr 3 `bind` \end{code} @InstrBlock@s are the insn sequences generated by the insn selectors. @@ -45,19 +61,27 @@ left-to-right traversal (pre-order?) yields the insns in the correct order. \begin{code} - type InstrBlock = OrdList Instr x `bind` f = f x +isLeft (Left _) = True +isLeft (Right _) = False + +unLeft (Left x) = x \end{code} Code extractor for an entire stix tree---stix statement level. \begin{code} -stmt2Instrs :: StixTree {- a stix statement -} -> NatM InstrBlock +stmtsToInstrs :: [StixStmt] -> NatM InstrBlock +stmtsToInstrs stmts + = mapNat stmtToInstrs stmts `thenNat` \ instrss -> + returnNat (concatOL instrss) + -stmt2Instrs stmt = case stmt of +stmtToInstrs :: StixStmt -> NatM InstrBlock +stmtToInstrs stmt = case stmt of StComment s -> returnNat (unitOL (COMMENT s)) StSegment seg -> returnNat (unitOL (SEGMENT seg)) @@ -68,16 +92,24 @@ stmt2Instrs stmt = case stmt of StLabel lab -> returnNat (unitOL (LABEL lab)) - StJump arg -> genJump (derefDLL arg) + StJump dsts arg -> genJump dsts (derefDLL arg) StCondJump lab arg -> genCondJump lab (derefDLL arg) - -- A call returning void, ie one done for its side-effects - StCall fn cconv VoidRep args -> genCCall fn - cconv VoidRep (map derefDLL args) - - StAssign pk dst src - | isFloatingRep pk -> assignFltCode pk (derefDLL dst) (derefDLL src) - | otherwise -> assignIntCode pk (derefDLL dst) (derefDLL src) + -- A call returning void, ie one done for its side-effects. Note + -- that this is the only StVoidable we handle. + StVoidable (StCall fn cconv VoidRep args) + -> genCCall fn cconv VoidRep (map derefDLL args) + + StAssignMem pk addr src + | isFloatingRep pk -> assignMem_FltCode pk (derefDLL addr) (derefDLL src) + | ncg_target_is_32bit + && is64BitRep pk -> assignMem_I64Code (derefDLL addr) (derefDLL src) + | otherwise -> assignMem_IntCode pk (derefDLL addr) (derefDLL src) + StAssignReg pk reg src + | isFloatingRep pk -> assignReg_FltCode pk reg (derefDLL src) + | ncg_target_is_32bit + && is64BitRep pk -> assignReg_I64Code reg (derefDLL src) + | otherwise -> assignReg_IntCode pk reg (derefDLL src) StFallThrough lbl -- When falling through on the Alpha, we still have to load pv @@ -90,27 +122,31 @@ stmt2Instrs stmt = case stmt of returnNat (DATA (primRepToSize kind) imms `consOL` concatOL codes) where - getData :: StixTree -> NatM (InstrBlock, Imm) - + getData :: StixExpr -> NatM (InstrBlock, Imm) getData (StInt i) = returnNat (nilOL, ImmInteger i) getData (StDouble d) = returnNat (nilOL, ImmDouble d) getData (StFloat d) = returnNat (nilOL, ImmFloat d) getData (StCLbl l) = returnNat (nilOL, ImmCLbl l) - getData (StString s) = - getNatLabelNCG `thenNat` \ lbl -> - returnNat (toOL [LABEL lbl, - ASCII True (_UNPK_ s)], - ImmCLbl lbl) + getData (StString s) = panic "MachCode.stmtToInstrs: unlifted StString" -- the linker can handle simple arithmetic... getData (StIndex rep (StCLbl lbl) (StInt off)) = - returnNat (nilOL, - ImmIndex lbl (fromInteger (off * sizeOf rep))) + returnNat (nilOL, + ImmIndex lbl (fromInteger off * getPrimRepArrayElemSize rep)) + + -- Top-level lifted-out string. The segment will already have been set + -- (see Stix.liftStrings). + StDataString str + -> returnNat (unitOL (ASCII True (unpackFS str))) + +#ifdef DEBUG + other -> pprPanic "stmtToInstrs" (pprStixStmt other) +#endif -- Walk a Stix tree, and insert dereferences to CLabels which are marked -- as labelDynamic. stmt2Instrs calls derefDLL selectively, because -- not all such CLabel occurrences need this dereferencing -- SRTs don't -- for one. -derefDLL :: StixTree -> StixTree +derefDLL :: StixExpr -> StixExpr derefDLL tree | opt_Static -- short out the entire deal if not doing DLLs = tree @@ -124,17 +160,17 @@ derefDLL tree else t -- all the rest are boring StIndex pk base offset -> StIndex pk (qq base) (qq offset) - StPrim pk args -> StPrim pk (map qq args) + StMachOp mop args -> StMachOp mop (map qq args) StInd pk addr -> StInd pk (qq addr) - StCall who cc pk args -> StCall who cc pk (map qq args) + StCall (Left nm) cc pk args -> StCall (Left nm) cc pk (map qq args) + StCall (Right f) cc pk args -> StCall (Right (qq f)) cc pk (map qq args) StInt _ -> t StFloat _ -> t StDouble _ -> t StString _ -> t StReg _ -> t - StScratchWord _ -> t _ -> pprPanic "derefDLL: unhandled case" - (pprStixTree t) + (pprStixExpr t) \end{code} %************************************************************************ @@ -144,35 +180,40 @@ derefDLL tree %************************************************************************ \begin{code} -mangleIndexTree :: StixTree -> StixTree +mangleIndexTree :: StixExpr -> StixExpr mangleIndexTree (StIndex pk base (StInt i)) - = StPrim IntAddOp [base, off] + = StMachOp MO_Nat_Add [base, off] where - off = StInt (i * sizeOf pk) + off = StInt (i * toInteger (getPrimRepArrayElemSize pk)) mangleIndexTree (StIndex pk base off) - = StPrim IntAddOp [ + = StMachOp MO_Nat_Add [ base, let s = shift pk - in ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk))) - if s == 0 then off else StPrim SllOp [off, StInt s] - ] + in if s == 0 then off + else StMachOp MO_Nat_Shl [off, StInt (toInteger s)] + ] where - shift DoubleRep = 3::Integer - shift CharRep = 0::Integer - shift _ = IF_ARCH_alpha(3,2) + shift :: PrimRep -> Int + shift rep = case getPrimRepArrayElemSize rep of + 1 -> 0 + 2 -> 1 + 4 -> 2 + 8 -> 3 + other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size" + (Outputable.int other) \end{code} \begin{code} -maybeImm :: StixTree -> Maybe Imm +maybeImm :: StixExpr -> Maybe Imm maybeImm (StCLbl l) = Just (ImmCLbl l) maybeImm (StIndex rep (StCLbl l) (StInt off)) - = Just (ImmIndex l (fromInteger (off * sizeOf rep))) + = Just (ImmIndex l (fromInteger off * getPrimRepArrayElemSize rep)) maybeImm (StInt i) - | i >= toInteger minInt && i <= toInteger maxInt + | i >= toInteger (minBound::Int) && i <= toInteger (maxBound::Int) = Just (ImmInt (fromInteger i)) | otherwise = Just (ImmInteger i) @@ -182,6 +223,223 @@ maybeImm _ = Nothing %************************************************************************ %* * +\subsection{The @Register64@ type} +%* * +%************************************************************************ + +Simple support for generating 64-bit code (ie, 64 bit values and 64 +bit assignments) on 32-bit platforms. Unlike the main code generator +we merely shoot for generating working code as simply as possible, and +pay little attention to code quality. Specifically, there is no +attempt to deal cleverly with the fixed-vs-floating register +distinction; all values are generated into (pairs of) floating +registers, even if this would mean some redundant reg-reg moves as a +result. Only one of the VRegUniques is returned, since it will be +of the VRegUniqueLo form, and the upper-half VReg can be determined +by applying getHiVRegFromLo to it. + +\begin{code} + +data ChildCode64 -- a.k.a "Register64" + = ChildCode64 + InstrBlock -- code + VRegUnique -- unique for the lower 32-bit temporary + -- which contains the result; use getHiVRegFromLo to find + -- the other VRegUnique. + -- Rules of this simplified insn selection game are + -- therefore that the returned VRegUnique may be modified + +assignMem_I64Code :: StixExpr -> StixExpr -> NatM InstrBlock +assignReg_I64Code :: StixReg -> StixExpr -> NatM InstrBlock +iselExpr64 :: StixExpr -> NatM ChildCode64 + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +#if i386_TARGET_ARCH + +assignMem_I64Code addrTree valueTree + = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) -> + getRegister addrTree `thenNat` \ register_addr -> + getNewRegNCG IntRep `thenNat` \ t_addr -> + let rlo = VirtualRegI vrlo + rhi = getHiVRegFromLo rlo + code_addr = registerCode register_addr t_addr + reg_addr = registerName register_addr t_addr + -- Little-endian store + mov_lo = MOV L (OpReg rlo) + (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0))) + mov_hi = MOV L (OpReg rhi) + (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4))) + in + returnNat (vcode `appOL` code_addr `snocOL` mov_lo `snocOL` mov_hi) + +assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree + = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) -> + let + r_dst_lo = mkVReg u_dst IntRep + r_src_lo = VirtualRegI vr_src_lo + r_dst_hi = getHiVRegFromLo r_dst_lo + r_src_hi = getHiVRegFromLo r_src_lo + mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo) + mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi) + in + returnNat ( + vcode `snocOL` mov_lo `snocOL` mov_hi + ) + +assignReg_I64Code lvalue valueTree + = pprPanic "assignReg_I64Code(i386): invalid lvalue" + (pprStixReg lvalue) + + + +iselExpr64 (StInd pk addrTree) + | is64BitRep pk + = getRegister addrTree `thenNat` \ register_addr -> + getNewRegNCG IntRep `thenNat` \ t_addr -> + getNewRegNCG IntRep `thenNat` \ rlo -> + let rhi = getHiVRegFromLo rlo + code_addr = registerCode register_addr t_addr + reg_addr = registerName register_addr t_addr + mov_lo = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0))) + (OpReg rlo) + mov_hi = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4))) + (OpReg rhi) + in + returnNat ( + ChildCode64 (code_addr `snocOL` mov_lo `snocOL` mov_hi) + (getVRegUnique rlo) + ) + +iselExpr64 (StReg (StixTemp (StixVReg vu pk))) + | is64BitRep pk + = getNewRegNCG IntRep `thenNat` \ r_dst_lo -> + let r_dst_hi = getHiVRegFromLo r_dst_lo + r_src_lo = mkVReg vu IntRep + r_src_hi = getHiVRegFromLo r_src_lo + mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo) + mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi) + in + returnNat ( + ChildCode64 (toOL [mov_lo, mov_hi]) (getVRegUnique r_dst_lo) + ) + +iselExpr64 (StCall fn cconv kind args) + | is64BitRep kind + = genCCall fn cconv kind args `thenNat` \ call -> + getNewRegNCG IntRep `thenNat` \ r_dst_lo -> + let r_dst_hi = getHiVRegFromLo r_dst_lo + mov_lo = MOV L (OpReg eax) (OpReg r_dst_lo) + mov_hi = MOV L (OpReg edx) (OpReg r_dst_hi) + in + returnNat ( + ChildCode64 (call `snocOL` mov_lo `snocOL` mov_hi) + (getVRegUnique r_dst_lo) + ) + +iselExpr64 expr + = pprPanic "iselExpr64(i386)" (pprStixExpr expr) + +#endif {- i386_TARGET_ARCH -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +#if sparc_TARGET_ARCH + +assignMem_I64Code addrTree valueTree + = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) -> + getRegister addrTree `thenNat` \ register_addr -> + getNewRegNCG IntRep `thenNat` \ t_addr -> + let rlo = VirtualRegI vrlo + rhi = getHiVRegFromLo rlo + code_addr = registerCode register_addr t_addr + reg_addr = registerName register_addr t_addr + -- Big-endian store + mov_hi = ST W rhi (AddrRegImm reg_addr (ImmInt 0)) + mov_lo = ST W rlo (AddrRegImm reg_addr (ImmInt 4)) + in + returnNat (vcode `appOL` code_addr `snocOL` mov_hi `snocOL` mov_lo) + + +assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree + = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) -> + let + r_dst_lo = mkVReg u_dst IntRep + r_src_lo = VirtualRegI vr_src_lo + r_dst_hi = getHiVRegFromLo r_dst_lo + r_src_hi = getHiVRegFromLo r_src_lo + mov_lo = mkMOV r_src_lo r_dst_lo + mov_hi = mkMOV r_src_hi r_dst_hi + mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg + in + returnNat ( + vcode `snocOL` mov_hi `snocOL` mov_lo + ) +assignReg_I64Code lvalue valueTree + = pprPanic "assignReg_I64Code(sparc): invalid lvalue" + (pprStixReg lvalue) + + +-- Don't delete this -- it's very handy for debugging. +--iselExpr64 expr +-- | trace ("iselExpr64: " ++ showSDoc (pprStixExpr expr)) False +-- = panic "iselExpr64(???)" + +iselExpr64 (StInd pk addrTree) + | is64BitRep pk + = getRegister addrTree `thenNat` \ register_addr -> + getNewRegNCG IntRep `thenNat` \ t_addr -> + getNewRegNCG IntRep `thenNat` \ rlo -> + let rhi = getHiVRegFromLo rlo + code_addr = registerCode register_addr t_addr + reg_addr = registerName register_addr t_addr + mov_hi = LD W (AddrRegImm reg_addr (ImmInt 0)) rhi + mov_lo = LD W (AddrRegImm reg_addr (ImmInt 4)) rlo + in + returnNat ( + ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo) + (getVRegUnique rlo) + ) + +iselExpr64 (StReg (StixTemp (StixVReg vu pk))) + | is64BitRep pk + = getNewRegNCG IntRep `thenNat` \ r_dst_lo -> + let r_dst_hi = getHiVRegFromLo r_dst_lo + r_src_lo = mkVReg vu IntRep + r_src_hi = getHiVRegFromLo r_src_lo + mov_lo = mkMOV r_src_lo r_dst_lo + mov_hi = mkMOV r_src_hi r_dst_hi + mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg + in + returnNat ( + ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo) + ) + +iselExpr64 (StCall fn cconv kind args) + | is64BitRep kind + = genCCall fn cconv kind args `thenNat` \ call -> + getNewRegNCG IntRep `thenNat` \ r_dst_lo -> + let r_dst_hi = getHiVRegFromLo r_dst_lo + mov_lo = mkMOV o0 r_dst_lo + mov_hi = mkMOV o1 r_dst_hi + mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg + in + returnNat ( + ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo) + (getVRegUnique r_dst_lo) + ) + +iselExpr64 expr + = pprPanic "iselExpr64(sparc)" (pprStixExpr expr) + +#endif {- sparc_TARGET_ARCH -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +\end{code} + +%************************************************************************ +%* * \subsection{The @Register@ type} %* * %************************************************************************ @@ -201,22 +459,26 @@ registerCode (Fixed _ _ code) reg = code registerCode (Any _ code) reg = code reg registerCodeF (Fixed _ _ code) = code -registerCodeF (Any _ _) = pprPanic "registerCodeF" empty +registerCodeF (Any _ _) = panic "registerCodeF" registerCodeA (Any _ code) = code -registerCodeA (Fixed _ _ _) = pprPanic "registerCodeA" empty +registerCodeA (Fixed _ _ _) = panic "registerCodeA" registerName :: Register -> Reg -> Reg registerName (Fixed _ reg _) _ = reg registerName (Any _ _) reg = reg registerNameF (Fixed _ reg _) = reg -registerNameF (Any _ _) = pprPanic "registerNameF" empty +registerNameF (Any _ _) = panic "registerNameF" registerRep :: Register -> PrimRep registerRep (Fixed pk _ _) = pk registerRep (Any pk _) = pk +swizzleRegisterRep :: Register -> PrimRep -> Register +swizzleRegisterRep (Fixed _ reg code) rep = Fixed rep reg code +swizzleRegisterRep (Any _ codefn) rep = Any rep codefn + {-# INLINE registerCode #-} {-# INLINE registerCodeF #-} {-# INLINE registerName #-} @@ -234,19 +496,39 @@ isAny = not . isFixed Generate code to get a subtree into a @Register@: \begin{code} -getRegister :: StixTree -> NatM Register -getRegister (StReg (StixMagicId stgreg)) - = case (magicIdRegMaybe stgreg) of - Just reg -> returnNat (Fixed (magicIdPrimRep stgreg) reg nilOL) - -- cannae be Nothing +getRegisterReg :: StixReg -> NatM Register +getRegister :: StixExpr -> NatM Register + + +getRegisterReg (StixMagicId mid) + = case get_MagicId_reg_or_addr mid of + Left (RealReg rrno) + -> let pk = magicIdPrimRep mid + in returnNat (Fixed pk (RealReg rrno) nilOL) + Right baseRegAddr + -- By this stage, the only MagicIds remaining should be the + -- ones which map to a real machine register on this platform. Hence ... + -> pprPanic "getRegisterReg-memory" (pprMagicId mid) -getRegister (StReg (StixTemp u pk)) +getRegisterReg (StixTemp (StixVReg u pk)) = returnNat (Fixed pk (mkVReg u pk) nilOL) -getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree) +------------- + +-- Don't delete this -- it's very handy for debugging. +--getRegister expr +-- | trace ("getRegiste: " ++ showSDoc (pprStixExpr expr)) False +-- = panic "getRegister(???)" + +getRegister (StReg reg) + = getRegisterReg reg + +getRegister tree@(StIndex _ _ _) + = getRegister (mangleIndexTree tree) getRegister (StCall fn cconv kind args) + | not (ncg_target_is_32bit && is64BitRep kind) = genCCall fn cconv kind args `thenNat` \ call -> returnNat (Fixed kind reg call) where @@ -260,9 +542,9 @@ getRegister (StString s) imm_lbl = ImmCLbl lbl code dst = toOL [ - SEGMENT DataSegment, + SEGMENT RoDataSegment, LABEL lbl, - ASCII True (_UNPK_ s), + ASCII True (unpackFS s), SEGMENT TextSegment, #if alpha_TARGET_ARCH LDA dst (AddrImm imm_lbl) @@ -278,8 +560,7 @@ getRegister (StString s) in returnNat (Any PtrRep code) - - +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- end of machine-"independent" bit; here we go on the rest... #if alpha_TARGET_ARCH @@ -317,33 +598,33 @@ getRegister (StPrim primop [x]) -- unary PrimOps Double2FloatOp -> coerceFltCode x Float2DoubleOp -> coerceFltCode x - other_op -> getRegister (StCall fn cCallConv DoubleRep [x]) + other_op -> getRegister (StCall fn CCallConv DoubleRep [x]) where fn = case other_op of - FloatExpOp -> SLIT("exp") - FloatLogOp -> SLIT("log") - FloatSqrtOp -> SLIT("sqrt") - FloatSinOp -> SLIT("sin") - FloatCosOp -> SLIT("cos") - FloatTanOp -> SLIT("tan") - FloatAsinOp -> SLIT("asin") - FloatAcosOp -> SLIT("acos") - FloatAtanOp -> SLIT("atan") - FloatSinhOp -> SLIT("sinh") - FloatCoshOp -> SLIT("cosh") - FloatTanhOp -> SLIT("tanh") - DoubleExpOp -> SLIT("exp") - DoubleLogOp -> SLIT("log") - DoubleSqrtOp -> SLIT("sqrt") - DoubleSinOp -> SLIT("sin") - DoubleCosOp -> SLIT("cos") - DoubleTanOp -> SLIT("tan") - DoubleAsinOp -> SLIT("asin") - DoubleAcosOp -> SLIT("acos") - DoubleAtanOp -> SLIT("atan") - DoubleSinhOp -> SLIT("sinh") - DoubleCoshOp -> SLIT("cosh") - DoubleTanhOp -> SLIT("tanh") + FloatExpOp -> FSLIT("exp") + FloatLogOp -> FSLIT("log") + FloatSqrtOp -> FSLIT("sqrt") + FloatSinOp -> FSLIT("sin") + FloatCosOp -> FSLIT("cos") + FloatTanOp -> FSLIT("tan") + FloatAsinOp -> FSLIT("asin") + FloatAcosOp -> FSLIT("acos") + FloatAtanOp -> FSLIT("atan") + FloatSinhOp -> FSLIT("sinh") + FloatCoshOp -> FSLIT("cosh") + FloatTanhOp -> FSLIT("tanh") + DoubleExpOp -> FSLIT("exp") + DoubleLogOp -> FSLIT("log") + DoubleSqrtOp -> FSLIT("sqrt") + DoubleSinOp -> FSLIT("sin") + DoubleCosOp -> FSLIT("cos") + DoubleTanOp -> FSLIT("tan") + DoubleAsinOp -> FSLIT("asin") + DoubleAcosOp -> FSLIT("acos") + DoubleAtanOp -> FSLIT("atan") + DoubleSinhOp -> FSLIT("sinh") + DoubleCoshOp -> FSLIT("cosh") + DoubleTanhOp -> FSLIT("tanh") where pr = panic "MachCode.getRegister: no primrep needed for Alpha" @@ -376,7 +657,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps AddrNeOp -> int_NE_code x y AddrLtOp -> trivialCode (CMP ULT) x y AddrLeOp -> trivialCode (CMP ULE) x y - + FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y @@ -397,6 +678,9 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps IntQuotOp -> trivialCode (DIV Q False) x y IntRemOp -> trivialCode (REM Q False) x y + WordAddOp -> trivialCode (ADD Q False) x y + WordSubOp -> trivialCode (SUB Q False) x y + WordMulOp -> trivialCode (MUL Q False) x y WordQuotOp -> trivialCode (DIV Q True) x y WordRemOp -> trivialCode (REM Q True) x y @@ -410,6 +694,10 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y + AddrAddOp -> trivialCode (ADD Q False) x y + AddrSubOp -> trivialCode (SUB Q False) x y + AddrRemOp -> trivialCode (REM Q True) x y + AndOp -> trivialCode AND x y OrOp -> trivialCode OR x y XorOp -> trivialCode XOR x y @@ -420,8 +708,8 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra" ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl" - FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y]) - DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y]) + FloatPowerOp -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y]) + DoublePowerOp -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y]) where {- ------------------------------------------------------------ Some bizarre special code for getting condition codes into @@ -506,7 +794,9 @@ getRegister leaf imm__2 = case imm of Just x -> x #endif {- alpha_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if i386_TARGET_ARCH getRegister (StFloat f) @@ -544,168 +834,210 @@ getRegister (StDouble d) in returnNat (Any DoubleRep code) --- Calculate the offset for (i+1) words above the _initial_ --- %esp value by first determining the current offset of it. -getRegister (StScratchWord i) - | i >= 0 && i < 6 - = getDeltaNat `thenNat` \ current_stack_offset -> - let j = i+1 - (current_stack_offset `div` 4) - code dst - = unitOL (LEA L (OpAddr (spRel (j+1))) (OpReg dst)) - in - returnNat (Any PtrRep code) -getRegister (StPrim primop [x]) -- unary PrimOps - = case primop of - IntNegOp -> trivialUCode (NEGI L) x - NotOp -> trivialUCode (NOT L) x - - FloatNegOp -> trivialUFCode FloatRep (GNEG F) x - DoubleNegOp -> trivialUFCode DoubleRep (GNEG DF) x - - FloatSqrtOp -> trivialUFCode FloatRep (GSQRT F) x - DoubleSqrtOp -> trivialUFCode DoubleRep (GSQRT DF) x - - FloatSinOp -> trivialUFCode FloatRep (GSIN F) x - DoubleSinOp -> trivialUFCode DoubleRep (GSIN DF) x - - FloatCosOp -> trivialUFCode FloatRep (GCOS F) x - DoubleCosOp -> trivialUFCode DoubleRep (GCOS DF) x +getRegister (StMachOp mop [x]) -- unary MachOps + = case mop of + MO_NatS_Neg -> trivialUCode (NEGI L) x + MO_Nat_Not -> trivialUCode (NOT L) x + MO_32U_to_8U -> trivialUCode (AND L (OpImm (ImmInt 255))) x - FloatTanOp -> trivialUFCode FloatRep (GTAN F) x - DoubleTanOp -> trivialUFCode DoubleRep (GTAN DF) x + MO_Flt_Neg -> trivialUFCode FloatRep (GNEG F) x + MO_Dbl_Neg -> trivialUFCode DoubleRep (GNEG DF) x - Double2FloatOp -> trivialUFCode FloatRep GDTOF x - Float2DoubleOp -> trivialUFCode DoubleRep GFTOD x + MO_Flt_Sqrt -> trivialUFCode FloatRep (GSQRT F) x + MO_Dbl_Sqrt -> trivialUFCode DoubleRep (GSQRT DF) x - OrdOp -> coerceIntCode IntRep x - ChrOp -> chrCode x - - Float2IntOp -> coerceFP2Int x - Int2FloatOp -> coerceInt2FP FloatRep x - Double2IntOp -> coerceFP2Int x - Int2DoubleOp -> coerceInt2FP DoubleRep x + MO_Flt_Sin -> trivialUFCode FloatRep (GSIN F) x + MO_Dbl_Sin -> trivialUFCode DoubleRep (GSIN DF) x - other_op -> - getRegister (StCall fn cCallConv DoubleRep [x]) - where - (is_float_op, fn) - = case primop of - FloatExpOp -> (True, SLIT("exp")) - FloatLogOp -> (True, SLIT("log")) + MO_Flt_Cos -> trivialUFCode FloatRep (GCOS F) x + MO_Dbl_Cos -> trivialUFCode DoubleRep (GCOS DF) x - FloatAsinOp -> (True, SLIT("asin")) - FloatAcosOp -> (True, SLIT("acos")) - FloatAtanOp -> (True, SLIT("atan")) + MO_Flt_Tan -> trivialUFCode FloatRep (GTAN F) x + MO_Dbl_Tan -> trivialUFCode DoubleRep (GTAN DF) x - FloatSinhOp -> (True, SLIT("sinh")) - FloatCoshOp -> (True, SLIT("cosh")) - FloatTanhOp -> (True, SLIT("tanh")) + MO_Flt_to_NatS -> coerceFP2Int FloatRep x + MO_NatS_to_Flt -> coerceInt2FP FloatRep x + MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x + MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x - DoubleExpOp -> (False, SLIT("exp")) - DoubleLogOp -> (False, SLIT("log")) + -- Conversions which are a nop on x86 + MO_NatS_to_32U -> conversionNop WordRep x + MO_32U_to_NatS -> conversionNop IntRep x - DoubleAsinOp -> (False, SLIT("asin")) - DoubleAcosOp -> (False, SLIT("acos")) - DoubleAtanOp -> (False, SLIT("atan")) + MO_NatU_to_NatS -> conversionNop IntRep x + MO_NatS_to_NatU -> conversionNop WordRep x + MO_NatP_to_NatU -> conversionNop WordRep x + MO_NatU_to_NatP -> conversionNop PtrRep x + MO_NatS_to_NatP -> conversionNop PtrRep x + MO_NatP_to_NatS -> conversionNop IntRep x - DoubleSinhOp -> (False, SLIT("sinh")) - DoubleCoshOp -> (False, SLIT("cosh")) - DoubleTanhOp -> (False, SLIT("tanh")) + MO_Dbl_to_Flt -> conversionNop FloatRep x + MO_Flt_to_Dbl -> conversionNop DoubleRep x - other - -> pprPanic "getRegister(x86,unary primop)" - (pprStixTree (StPrim primop [x])) + -- sign-extending widenings + MO_8U_to_NatU -> integerExtend False 24 x + MO_8S_to_NatS -> integerExtend True 24 x + MO_16U_to_NatU -> integerExtend False 16 x + MO_16S_to_NatS -> integerExtend True 16 x + MO_8U_to_32U -> integerExtend False 24 x -getRegister (StPrim primop [x, y]) -- dyadic PrimOps - = case primop of - CharGtOp -> condIntReg GTT x y - CharGeOp -> condIntReg GE x y - CharEqOp -> condIntReg EQQ x y - CharNeOp -> condIntReg NE x y - CharLtOp -> condIntReg LTT x y - CharLeOp -> condIntReg LE x y - - IntGtOp -> condIntReg GTT x y - IntGeOp -> condIntReg GE x y - IntEqOp -> condIntReg EQQ x y - IntNeOp -> condIntReg NE x y - IntLtOp -> condIntReg LTT x y - IntLeOp -> condIntReg LE x y - - WordGtOp -> condIntReg GU x y - WordGeOp -> condIntReg GEU x y - WordEqOp -> condIntReg EQQ x y - WordNeOp -> condIntReg NE x y - WordLtOp -> condIntReg LU x y - WordLeOp -> condIntReg LEU x y - - AddrGtOp -> condIntReg GU x y - AddrGeOp -> condIntReg GEU x y - AddrEqOp -> condIntReg EQQ x y - AddrNeOp -> condIntReg NE x y - AddrLtOp -> condIntReg LU x y - AddrLeOp -> condIntReg LEU x y - - FloatGtOp -> condFltReg GTT x y - FloatGeOp -> condFltReg GE x y - FloatEqOp -> condFltReg EQQ x y - FloatNeOp -> condFltReg NE x y - FloatLtOp -> condFltReg LTT x y - FloatLeOp -> condFltReg LE x y - - DoubleGtOp -> condFltReg GTT x y - DoubleGeOp -> condFltReg GE x y - DoubleEqOp -> condFltReg EQQ x y - DoubleNeOp -> condFltReg NE x y - DoubleLtOp -> condFltReg LTT x y - DoubleLeOp -> condFltReg LE x y - - IntAddOp -> add_code L x y - IntSubOp -> sub_code L x y - IntQuotOp -> quot_code L x y True{-division-} - IntRemOp -> quot_code L x y False{-remainder-} - IntMulOp -> let op = IMUL L in trivialCode op (Just op) x y - - FloatAddOp -> trivialFCode FloatRep GADD x y - FloatSubOp -> trivialFCode FloatRep GSUB x y - FloatMulOp -> trivialFCode FloatRep GMUL x y - FloatDivOp -> trivialFCode FloatRep GDIV x y - - DoubleAddOp -> trivialFCode DoubleRep GADD x y - DoubleSubOp -> trivialFCode DoubleRep GSUB x y - DoubleMulOp -> trivialFCode DoubleRep GMUL x y - DoubleDivOp -> trivialFCode DoubleRep GDIV x y - - AndOp -> let op = AND L in trivialCode op (Just op) x y - OrOp -> let op = OR L in trivialCode op (Just op) x y - XorOp -> let op = XOR L in trivialCode op (Just op) x y + other_op + -> getRegister ( + (if is_float_op then demote else id) + (StCall (Left fn) CCallConv DoubleRep + [(if is_float_op then promote else id) x]) + ) + where + integerExtend signed nBits x + = getRegister ( + StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr) + [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits] + ) + + conversionNop new_rep expr + = getRegister expr `thenNat` \ e_code -> + returnNat (swizzleRegisterRep e_code new_rep) + + promote x = StMachOp MO_Flt_to_Dbl [x] + demote x = StMachOp MO_Dbl_to_Flt [x] + (is_float_op, fn) + = case mop of + MO_Flt_Exp -> (True, FSLIT("exp")) + MO_Flt_Log -> (True, FSLIT("log")) + + MO_Flt_Asin -> (True, FSLIT("asin")) + MO_Flt_Acos -> (True, FSLIT("acos")) + MO_Flt_Atan -> (True, FSLIT("atan")) + + MO_Flt_Sinh -> (True, FSLIT("sinh")) + MO_Flt_Cosh -> (True, FSLIT("cosh")) + MO_Flt_Tanh -> (True, FSLIT("tanh")) + + MO_Dbl_Exp -> (False, FSLIT("exp")) + MO_Dbl_Log -> (False, FSLIT("log")) + + MO_Dbl_Asin -> (False, FSLIT("asin")) + MO_Dbl_Acos -> (False, FSLIT("acos")) + MO_Dbl_Atan -> (False, FSLIT("atan")) + + MO_Dbl_Sinh -> (False, FSLIT("sinh")) + MO_Dbl_Cosh -> (False, FSLIT("cosh")) + MO_Dbl_Tanh -> (False, FSLIT("tanh")) + + other -> pprPanic "getRegister(x86) - binary StMachOp (2)" + (pprMachOp mop) + + +getRegister (StMachOp mop [x, y]) -- dyadic MachOps + = case mop of + MO_32U_Gt -> condIntReg GTT x y + MO_32U_Ge -> condIntReg GE x y + MO_32U_Eq -> condIntReg EQQ x y + MO_32U_Ne -> condIntReg NE x y + MO_32U_Lt -> condIntReg LTT x y + MO_32U_Le -> condIntReg LE x y + + MO_Nat_Eq -> condIntReg EQQ x y + MO_Nat_Ne -> condIntReg NE x y + + MO_NatS_Gt -> condIntReg GTT x y + MO_NatS_Ge -> condIntReg GE x y + MO_NatS_Lt -> condIntReg LTT x y + MO_NatS_Le -> condIntReg LE x y + + MO_NatU_Gt -> condIntReg GU x y + MO_NatU_Ge -> condIntReg GEU x y + MO_NatU_Lt -> condIntReg LU x y + MO_NatU_Le -> condIntReg LEU x y + + MO_Flt_Gt -> condFltReg GTT x y + MO_Flt_Ge -> condFltReg GE x y + MO_Flt_Eq -> condFltReg EQQ x y + MO_Flt_Ne -> condFltReg NE x y + MO_Flt_Lt -> condFltReg LTT x y + MO_Flt_Le -> condFltReg LE x y + + MO_Dbl_Gt -> condFltReg GTT x y + MO_Dbl_Ge -> condFltReg GE x y + MO_Dbl_Eq -> condFltReg EQQ x y + MO_Dbl_Ne -> condFltReg NE x y + MO_Dbl_Lt -> condFltReg LTT x y + MO_Dbl_Le -> condFltReg LE x y + + MO_Nat_Add -> add_code L x y + MO_Nat_Sub -> sub_code L x y + MO_NatS_Quot -> trivialCode (IQUOT L) Nothing x y + MO_NatS_Rem -> trivialCode (IREM L) Nothing x y + MO_NatU_Quot -> trivialCode (QUOT L) Nothing x y + MO_NatU_Rem -> trivialCode (REM L) Nothing x y + MO_NatS_Mul -> let op = IMUL L in trivialCode op (Just op) x y + MO_NatU_Mul -> let op = MUL L in trivialCode op (Just op) x y + MO_NatS_MulMayOflo -> imulMayOflo x y + + MO_Flt_Add -> trivialFCode FloatRep GADD x y + MO_Flt_Sub -> trivialFCode FloatRep GSUB x y + MO_Flt_Mul -> trivialFCode FloatRep GMUL x y + MO_Flt_Div -> trivialFCode FloatRep GDIV x y + + MO_Dbl_Add -> trivialFCode DoubleRep GADD x y + MO_Dbl_Sub -> trivialFCode DoubleRep GSUB x y + MO_Dbl_Mul -> trivialFCode DoubleRep GMUL x y + MO_Dbl_Div -> trivialFCode DoubleRep GDIV x y + + MO_Nat_And -> let op = AND L in trivialCode op (Just op) x y + MO_Nat_Or -> let op = OR L in trivialCode op (Just op) x y + MO_Nat_Xor -> let op = XOR L in trivialCode op (Just op) x y {- Shift ops on x86s have constraints on their source, it either has to be Imm, CL or 1 => trivialCode's is not restrictive enough (sigh.) - -} - - SllOp -> shift_code (SHL L) x y {-False-} - SrlOp -> shift_code (SHR L) x y {-False-} - ISllOp -> shift_code (SHL L) x y {-False-} - ISraOp -> shift_code (SAR L) x y {-False-} - ISrlOp -> shift_code (SHR L) x y {-False-} - - FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep - [promote x, promote y]) - where promote x = StPrim Float2DoubleOp [x] - DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep - [x, y]) - other - -> pprPanic "getRegister(x86,dyadic primop)" - (pprStixTree (StPrim primop [x, y])) + -} + MO_Nat_Shl -> shift_code (SHL L) x y {-False-} + MO_Nat_Shr -> shift_code (SHR L) x y {-False-} + MO_Nat_Sar -> shift_code (SAR L) x y {-False-} + + MO_Flt_Pwr -> getRegister (demote + (StCall (Left FSLIT("pow")) CCallConv DoubleRep + [promote x, promote y]) + ) + MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep + [x, y]) + other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop) where + promote x = StMachOp MO_Flt_to_Dbl [x] + demote x = StMachOp MO_Dbl_to_Flt [x] + + -------------------- + imulMayOflo :: StixExpr -> StixExpr -> NatM Register + imulMayOflo a1 a2 + = getNewRegNCG IntRep `thenNat` \ t1 -> + getNewRegNCG IntRep `thenNat` \ t2 -> + getNewRegNCG IntRep `thenNat` \ res_lo -> + getNewRegNCG IntRep `thenNat` \ res_hi -> + getRegister a1 `thenNat` \ reg1 -> + getRegister a2 `thenNat` \ reg2 -> + let code1 = registerCode reg1 t1 + code2 = registerCode reg2 t2 + src1 = registerName reg1 t1 + src2 = registerName reg2 t2 + code dst = code1 `appOL` code2 `appOL` + toOL [ + MOV L (OpReg src1) (OpReg res_hi), + MOV L (OpReg src2) (OpReg res_lo), + IMUL64 res_hi res_lo, -- result in res_hi:res_lo + SAR L (ImmInt 31) (OpReg res_lo), -- sign extend lower part + SUB L (OpReg res_hi) (OpReg res_lo), -- compare against upper + MOV L (OpReg res_lo) (OpReg dst) + -- dst==0 if high part == sign extended low part + ] + in + returnNat (Any IntRep code) -------------------- shift_code :: (Imm -> Operand -> Instr) - -> StixTree - -> StixTree + -> StixExpr + -> StixExpr -> NatM Register {- Case1: shift length as immediate -} @@ -758,7 +1090,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps code_val `snocOL` MOV L (OpReg src_val) r_dst `appOL` toOL [ - COMMENT (_PK_ "begin shift sequence"), + COMMENT (mkFastString "begin shift sequence"), MOV L (OpReg src_val) r_dst, MOV L (OpReg src_amt) r_tmp, @@ -787,13 +1119,13 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps instr (ImmInt 1) r_dst, LABEL lbl_after, - COMMENT (_PK_ "end shift sequence") + COMMENT (mkFastString "end shift sequence") ] in returnNat (Any IntRep code__2) -------------------- - add_code :: Size -> StixTree -> StixTree -> NatM Register + add_code :: Size -> StixExpr -> StixExpr -> NatM Register add_code sz x (StInt y) = getRegister x `thenNat` \ register -> @@ -812,7 +1144,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y -------------------- - sub_code :: Size -> StixTree -> StixTree -> NatM Register + sub_code :: Size -> StixExpr -> StixExpr -> NatM Register sub_code sz x (StInt y) = getRegister x `thenNat` \ register -> @@ -830,43 +1162,8 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps sub_code sz x y = trivialCode (SUB sz) Nothing x y - -------------------- - quot_code - :: Size - -> StixTree -> StixTree - -> Bool -- True => division, False => remainder operation - -> NatM Register - - -- x must go into eax, edx must be a sign-extension of eax, and y - -- should go in some other register (or memory), so that we get - -- edx:eax / reg -> eax (remainder in edx). Currently we choose - -- to put y on the C stack, since that avoids tying up yet another - -- precious register. - - quot_code sz x y is_division - = getRegister x `thenNat` \ register1 -> - getRegister y `thenNat` \ register2 -> - getNewRegNCG IntRep `thenNat` \ tmp -> - getDeltaNat `thenNat` \ delta -> - let - code1 = registerCode register1 tmp - src1 = registerName register1 tmp - code2 = registerCode register2 tmp - src2 = registerName register2 tmp - code__2 = code2 `snocOL` -- src2 := y - PUSH L (OpReg src2) `snocOL` -- -4(%esp) := y - DELTA (delta-4) `appOL` - code1 `snocOL` -- src1 := x - MOV L (OpReg src1) (OpReg eax) `snocOL` -- eax := x - CLTD `snocOL` - IDIV sz (OpAddr (spRel 0)) `snocOL` - ADD L (OpImm (ImmInt 4)) (OpReg esp) `snocOL` - DELTA delta - in - returnNat (Fixed IntRep (if is_division then eax else edx) code__2) - ----------------------- - getRegister (StInd pk mem) + | not (is64BitRep pk) = getAmode mem `thenNat` \ amode -> let code = amodeCode amode @@ -875,9 +1172,14 @@ getRegister (StInd pk mem) code__2 dst = code `snocOL` if pk == DoubleRep || pk == FloatRep then GLD size src dst - else case size of - L -> MOV L (OpAddr src) (OpReg dst) - B -> MOVZxL B (OpAddr src) (OpReg dst) + else (case size of + B -> MOVSxL B + Bu -> MOVZxL Bu + W -> MOVSxL W + Wu -> MOVZxL Wu + L -> MOV L + Lu -> MOV L) + (OpAddr src) (OpReg dst) in returnNat (Any pk code__2) @@ -898,13 +1200,15 @@ getRegister leaf in returnNat (Any PtrRep code) | otherwise - = pprPanic "getRegister(x86)" (pprStixTree leaf) + = ncgPrimopMoan "getRegister(x86)" (pprStixExpr leaf) where imm = maybeImm leaf imm__2 = case imm of Just x -> x #endif {- i386_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if sparc_TARGET_ARCH getRegister (StFloat d) @@ -933,167 +1237,195 @@ getRegister (StDouble d) in returnNat (Any DoubleRep code) --- The 6-word scratch area is immediately below the frame pointer. --- Below that is the spill area. -getRegister (StScratchWord i) - | i >= 0 && i < 6 - = let j = i+1 - code dst = unitOL (fpRelEA j dst) - in - returnNat (Any PtrRep code) +getRegister (StMachOp mop [x]) -- unary PrimOps + = case mop of + MO_NatS_Neg -> trivialUCode (SUB False False g0) x + MO_Nat_Not -> trivialUCode (XNOR False g0) x + MO_32U_to_8U -> trivialCode (AND False) x (StInt 255) -getRegister (StPrim primop [x]) -- unary PrimOps - = case primop of - IntNegOp -> trivialUCode (SUB False False g0) x - NotOp -> trivialUCode (XNOR False g0) x + MO_Flt_Neg -> trivialUFCode FloatRep (FNEG F) x + MO_Dbl_Neg -> trivialUFCode DoubleRep (FNEG DF) x - FloatNegOp -> trivialUFCode FloatRep (FNEG F) x - DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x + MO_Dbl_to_Flt -> coerceDbl2Flt x + MO_Flt_to_Dbl -> coerceFlt2Dbl x - DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x + MO_Flt_to_NatS -> coerceFP2Int FloatRep x + MO_NatS_to_Flt -> coerceInt2FP FloatRep x + MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x + MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x - Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x - Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x + -- Conversions which are a nop on sparc + MO_32U_to_NatS -> conversionNop IntRep x + MO_NatS_to_32U -> conversionNop WordRep x - OrdOp -> coerceIntCode IntRep x - ChrOp -> chrCode x + MO_NatU_to_NatS -> conversionNop IntRep x + MO_NatS_to_NatU -> conversionNop WordRep x + MO_NatP_to_NatU -> conversionNop WordRep x + MO_NatU_to_NatP -> conversionNop PtrRep x + MO_NatS_to_NatP -> conversionNop PtrRep x + MO_NatP_to_NatS -> conversionNop IntRep x - Float2IntOp -> coerceFP2Int x - Int2FloatOp -> coerceInt2FP FloatRep x - Double2IntOp -> coerceFP2Int x - Int2DoubleOp -> coerceInt2FP DoubleRep x + -- sign-extending widenings + MO_8U_to_32U -> integerExtend False 24 x + MO_8U_to_NatU -> integerExtend False 24 x + MO_8S_to_NatS -> integerExtend True 24 x + MO_16U_to_NatU -> integerExtend False 16 x + MO_16S_to_NatS -> integerExtend True 16 x other_op -> - let - fixed_x = if is_float_op -- promote to double - then StPrim Float2DoubleOp [x] - else x + let fixed_x = if is_float_op -- promote to double + then StMachOp MO_Flt_to_Dbl [x] + else x in - getRegister (StCall fn cCallConv DoubleRep [fixed_x]) - where - (is_float_op, fn) - = case primop of - FloatExpOp -> (True, SLIT("exp")) - FloatLogOp -> (True, SLIT("log")) - FloatSqrtOp -> (True, SLIT("sqrt")) - - FloatSinOp -> (True, SLIT("sin")) - FloatCosOp -> (True, SLIT("cos")) - FloatTanOp -> (True, SLIT("tan")) - - FloatAsinOp -> (True, SLIT("asin")) - FloatAcosOp -> (True, SLIT("acos")) - FloatAtanOp -> (True, SLIT("atan")) - - FloatSinhOp -> (True, SLIT("sinh")) - FloatCoshOp -> (True, SLIT("cosh")) - FloatTanhOp -> (True, SLIT("tanh")) - - DoubleExpOp -> (False, SLIT("exp")) - DoubleLogOp -> (False, SLIT("log")) - DoubleSqrtOp -> (False, SLIT("sqrt")) - - DoubleSinOp -> (False, SLIT("sin")) - DoubleCosOp -> (False, SLIT("cos")) - DoubleTanOp -> (False, SLIT("tan")) - - DoubleAsinOp -> (False, SLIT("asin")) - DoubleAcosOp -> (False, SLIT("acos")) - DoubleAtanOp -> (False, SLIT("atan")) - - DoubleSinhOp -> (False, SLIT("sinh")) - DoubleCoshOp -> (False, SLIT("cosh")) - DoubleTanhOp -> (False, SLIT("tanh")) - - other - -> pprPanic "getRegister(sparc,monadicprimop)" - (pprStixTree (StPrim primop [x])) - -getRegister (StPrim primop [x, y]) -- dyadic PrimOps - = case primop of - CharGtOp -> condIntReg GTT x y - CharGeOp -> condIntReg GE x y - CharEqOp -> condIntReg EQQ x y - CharNeOp -> condIntReg NE x y - CharLtOp -> condIntReg LTT x y - CharLeOp -> condIntReg LE x y - - IntGtOp -> condIntReg GTT x y - IntGeOp -> condIntReg GE x y - IntEqOp -> condIntReg EQQ x y - IntNeOp -> condIntReg NE x y - IntLtOp -> condIntReg LTT x y - IntLeOp -> condIntReg LE x y - - WordGtOp -> condIntReg GU x y - WordGeOp -> condIntReg GEU x y - WordEqOp -> condIntReg EQQ x y - WordNeOp -> condIntReg NE x y - WordLtOp -> condIntReg LU x y - WordLeOp -> condIntReg LEU x y - - AddrGtOp -> condIntReg GU x y - AddrGeOp -> condIntReg GEU x y - AddrEqOp -> condIntReg EQQ x y - AddrNeOp -> condIntReg NE x y - AddrLtOp -> condIntReg LU x y - AddrLeOp -> condIntReg LEU x y - - FloatGtOp -> condFltReg GTT x y - FloatGeOp -> condFltReg GE x y - FloatEqOp -> condFltReg EQQ x y - FloatNeOp -> condFltReg NE x y - FloatLtOp -> condFltReg LTT x y - FloatLeOp -> condFltReg LE x y - - DoubleGtOp -> condFltReg GTT x y - DoubleGeOp -> condFltReg GE x y - DoubleEqOp -> condFltReg EQQ x y - DoubleNeOp -> condFltReg NE x y - DoubleLtOp -> condFltReg LTT x y - DoubleLeOp -> condFltReg LE x y - - IntAddOp -> trivialCode (ADD False False) x y - IntSubOp -> trivialCode (SUB False False) x y - - -- ToDo: teach about V8+ SPARC mul/div instructions - IntMulOp -> imul_div SLIT(".umul") x y - IntQuotOp -> imul_div SLIT(".div") x y - IntRemOp -> imul_div SLIT(".rem") x y - - FloatAddOp -> trivialFCode FloatRep FADD x y - FloatSubOp -> trivialFCode FloatRep FSUB x y - FloatMulOp -> trivialFCode FloatRep FMUL x y - FloatDivOp -> trivialFCode FloatRep FDIV x y - - DoubleAddOp -> trivialFCode DoubleRep FADD x y - DoubleSubOp -> trivialFCode DoubleRep FSUB x y - DoubleMulOp -> trivialFCode DoubleRep FMUL x y - DoubleDivOp -> trivialFCode DoubleRep FDIV x y - - AndOp -> trivialCode (AND False) x y - OrOp -> trivialCode (OR False) x y - XorOp -> trivialCode (XOR False) x y - SllOp -> trivialCode SLL x y - SrlOp -> trivialCode SRL x y - - ISllOp -> trivialCode SLL x y --was: panic "SparcGen:isll" - ISraOp -> trivialCode SRA x y --was: panic "SparcGen:isra" - ISrlOp -> trivialCode SRL x y --was: panic "SparcGen:isrl" - - FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep - [promote x, promote y]) - where promote x = StPrim Float2DoubleOp [x] - DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep - [x, y]) - - other - -> pprPanic "getRegister(sparc,dyadic primop)" - (pprStixTree (StPrim primop [x, y])) + getRegister (StCall (Left fn) CCallConv DoubleRep [fixed_x]) + where + integerExtend signed nBits x + = getRegister ( + StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr) + [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits] + ) + conversionNop new_rep expr + = getRegister expr `thenNat` \ e_code -> + returnNat (swizzleRegisterRep e_code new_rep) + (is_float_op, fn) + = case mop of + MO_Flt_Exp -> (True, FSLIT("exp")) + MO_Flt_Log -> (True, FSLIT("log")) + MO_Flt_Sqrt -> (True, FSLIT("sqrt")) + + MO_Flt_Sin -> (True, FSLIT("sin")) + MO_Flt_Cos -> (True, FSLIT("cos")) + MO_Flt_Tan -> (True, FSLIT("tan")) + + MO_Flt_Asin -> (True, FSLIT("asin")) + MO_Flt_Acos -> (True, FSLIT("acos")) + MO_Flt_Atan -> (True, FSLIT("atan")) + + MO_Flt_Sinh -> (True, FSLIT("sinh")) + MO_Flt_Cosh -> (True, FSLIT("cosh")) + MO_Flt_Tanh -> (True, FSLIT("tanh")) + + MO_Dbl_Exp -> (False, FSLIT("exp")) + MO_Dbl_Log -> (False, FSLIT("log")) + MO_Dbl_Sqrt -> (False, FSLIT("sqrt")) + + MO_Dbl_Sin -> (False, FSLIT("sin")) + MO_Dbl_Cos -> (False, FSLIT("cos")) + MO_Dbl_Tan -> (False, FSLIT("tan")) + + MO_Dbl_Asin -> (False, FSLIT("asin")) + MO_Dbl_Acos -> (False, FSLIT("acos")) + MO_Dbl_Atan -> (False, FSLIT("atan")) + + MO_Dbl_Sinh -> (False, FSLIT("sinh")) + MO_Dbl_Cosh -> (False, FSLIT("cosh")) + MO_Dbl_Tanh -> (False, FSLIT("tanh")) + + other -> pprPanic "getRegister(sparc) - binary StMachOp (2)" + (pprMachOp mop) + + +getRegister (StMachOp mop [x, y]) -- dyadic PrimOps + = case mop of + MO_32U_Gt -> condIntReg GTT x y + MO_32U_Ge -> condIntReg GE x y + MO_32U_Eq -> condIntReg EQQ x y + MO_32U_Ne -> condIntReg NE x y + MO_32U_Lt -> condIntReg LTT x y + MO_32U_Le -> condIntReg LE x y + + MO_Nat_Eq -> condIntReg EQQ x y + MO_Nat_Ne -> condIntReg NE x y + + MO_NatS_Gt -> condIntReg GTT x y + MO_NatS_Ge -> condIntReg GE x y + MO_NatS_Lt -> condIntReg LTT x y + MO_NatS_Le -> condIntReg LE x y + + MO_NatU_Gt -> condIntReg GU x y + MO_NatU_Ge -> condIntReg GEU x y + MO_NatU_Lt -> condIntReg LU x y + MO_NatU_Le -> condIntReg LEU x y + + MO_Flt_Gt -> condFltReg GTT x y + MO_Flt_Ge -> condFltReg GE x y + MO_Flt_Eq -> condFltReg EQQ x y + MO_Flt_Ne -> condFltReg NE x y + MO_Flt_Lt -> condFltReg LTT x y + MO_Flt_Le -> condFltReg LE x y + + MO_Dbl_Gt -> condFltReg GTT x y + MO_Dbl_Ge -> condFltReg GE x y + MO_Dbl_Eq -> condFltReg EQQ x y + MO_Dbl_Ne -> condFltReg NE x y + MO_Dbl_Lt -> condFltReg LTT x y + MO_Dbl_Le -> condFltReg LE x y + + MO_Nat_Add -> trivialCode (ADD False False) x y + MO_Nat_Sub -> trivialCode (SUB False False) x y + + MO_NatS_Mul -> trivialCode (SMUL False) x y + MO_NatU_Mul -> trivialCode (UMUL False) x y + MO_NatS_MulMayOflo -> imulMayOflo x y + + -- ToDo: teach about V8+ SPARC div instructions + MO_NatS_Quot -> idiv FSLIT(".div") x y + MO_NatS_Rem -> idiv FSLIT(".rem") x y + MO_NatU_Quot -> idiv FSLIT(".udiv") x y + MO_NatU_Rem -> idiv FSLIT(".urem") x y + + MO_Flt_Add -> trivialFCode FloatRep FADD x y + MO_Flt_Sub -> trivialFCode FloatRep FSUB x y + MO_Flt_Mul -> trivialFCode FloatRep FMUL x y + MO_Flt_Div -> trivialFCode FloatRep FDIV x y + + MO_Dbl_Add -> trivialFCode DoubleRep FADD x y + MO_Dbl_Sub -> trivialFCode DoubleRep FSUB x y + MO_Dbl_Mul -> trivialFCode DoubleRep FMUL x y + MO_Dbl_Div -> trivialFCode DoubleRep FDIV x y + + MO_Nat_And -> trivialCode (AND False) x y + MO_Nat_Or -> trivialCode (OR False) x y + MO_Nat_Xor -> trivialCode (XOR False) x y + + MO_Nat_Shl -> trivialCode SLL x y + MO_Nat_Shr -> trivialCode SRL x y + MO_Nat_Sar -> trivialCode SRA x y + + MO_Flt_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep + [promote x, promote y]) + where promote x = StMachOp MO_Flt_to_Dbl [x] + MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep + [x, y]) + + other -> pprPanic "getRegister(sparc) - binary StMachOp (1)" (pprMachOp mop) where - imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y]) + idiv fn x y = getRegister (StCall (Left fn) CCallConv IntRep [x, y]) + + -------------------- + imulMayOflo :: StixExpr -> StixExpr -> NatM Register + imulMayOflo a1 a2 + = getNewRegNCG IntRep `thenNat` \ t1 -> + getNewRegNCG IntRep `thenNat` \ t2 -> + getNewRegNCG IntRep `thenNat` \ res_lo -> + getNewRegNCG IntRep `thenNat` \ res_hi -> + getRegister a1 `thenNat` \ reg1 -> + getRegister a2 `thenNat` \ reg2 -> + let code1 = registerCode reg1 t1 + code2 = registerCode reg2 t2 + src1 = registerName reg1 t1 + src2 = registerName reg2 t2 + code dst = code1 `appOL` code2 `appOL` + toOL [ + SMUL False src1 (RIReg src2) res_lo, + RDY res_hi, + SRA res_lo (RIImm (ImmInt 31)) res_lo, + SUB False False res_lo (RIReg res_hi) dst + ] + in + returnNat (Any IntRep code) getRegister (StInd pk mem) = getAmode mem `thenNat` \ amode -> @@ -1122,12 +1454,15 @@ getRegister leaf in returnNat (Any PtrRep code) | otherwise - = pprPanic "getRegister(sparc)" (pprStixTree leaf) + = ncgPrimopMoan "getRegister(sparc)" (pprStixExpr leaf) where imm = maybeImm leaf imm__2 = case imm of Just x -> x #endif {- sparc_TARGET_ARCH -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + \end{code} %************************************************************************ @@ -1161,10 +1496,12 @@ temporary, then do the other computation, and then use the temporary: ... (tmp) ... \begin{code} -getAmode :: StixTree -> NatM Amode +getAmode :: StixExpr -> NatM Amode getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree) +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if alpha_TARGET_ARCH getAmode (StPrim IntSubOp [x, StInt i]) @@ -1204,10 +1541,14 @@ getAmode other returnNat (Amode (AddrReg reg) code) #endif {- alpha_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if i386_TARGET_ARCH -getAmode (StPrim IntSubOp [x, StInt i]) +-- This is all just ridiculous, since it carefully undoes +-- what mangleIndexTree has just done. +getAmode (StMachOp MO_Nat_Sub [x, StInt i]) = getNewRegNCG PtrRep `thenNat` \ tmp -> getRegister x `thenNat` \ register -> let @@ -1217,14 +1558,14 @@ getAmode (StPrim IntSubOp [x, StInt i]) in returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code) -getAmode (StPrim IntAddOp [x, StInt i]) +getAmode (StMachOp MO_Nat_Add [x, StInt i]) | maybeToBool imm = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL) where imm = maybeImm x imm__2 = case imm of Just x -> x -getAmode (StPrim IntAddOp [x, StInt i]) +getAmode (StMachOp MO_Nat_Add [x, StInt i]) = getNewRegNCG PtrRep `thenNat` \ tmp -> getRegister x `thenNat` \ register -> let @@ -1234,7 +1575,7 @@ getAmode (StPrim IntAddOp [x, StInt i]) in returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code) -getAmode (StPrim IntAddOp [x, StPrim SllOp [y, StInt shift]]) +getAmode (StMachOp MO_Nat_Add [x, StMachOp MO_Nat_Shl [y, StInt shift]]) | shift == 0 || shift == 1 || shift == 2 || shift == 3 = getNewRegNCG PtrRep `thenNat` \ tmp1 -> getNewRegNCG IntRep `thenNat` \ tmp2 -> @@ -1268,10 +1609,12 @@ getAmode other returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code) #endif {- i386_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if sparc_TARGET_ARCH -getAmode (StPrim IntSubOp [x, StInt i]) +getAmode (StMachOp MO_Nat_Sub [x, StInt i]) | fits13Bits (-i) = getNewRegNCG PtrRep `thenNat` \ tmp -> getRegister x `thenNat` \ register -> @@ -1283,7 +1626,7 @@ getAmode (StPrim IntSubOp [x, StInt i]) returnNat (Amode (AddrRegImm reg off) code) -getAmode (StPrim IntAddOp [x, StInt i]) +getAmode (StMachOp MO_Nat_Add [x, StInt i]) | fits13Bits i = getNewRegNCG PtrRep `thenNat` \ tmp -> getRegister x `thenNat` \ register -> @@ -1294,7 +1637,7 @@ getAmode (StPrim IntAddOp [x, StInt i]) in returnNat (Amode (AddrRegImm reg off) code) -getAmode (StPrim IntAddOp [x, y]) +getAmode (StMachOp MO_Nat_Add [x, y]) = getNewRegNCG PtrRep `thenNat` \ tmp1 -> getNewRegNCG IntRep `thenNat` \ tmp2 -> getRegister x `thenNat` \ register1 -> @@ -1330,6 +1673,8 @@ getAmode other returnNat (Amode (AddrRegImm reg off) code) #endif {- sparc_TARGET_ARCH -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \end{code} %************************************************************************ @@ -1342,69 +1687,70 @@ Condition codes passed up the tree. \begin{code} data CondCode = CondCode Bool Cond InstrBlock -condName (CondCode _ cond _) = cond +condName (CondCode _ cond _) = cond condFloat (CondCode is_float _ _) = is_float -condCode (CondCode _ _ code) = code +condCode (CondCode _ _ code) = code \end{code} Set up a condition code for a conditional branch. \begin{code} -getCondCode :: StixTree -> NatM CondCode +getCondCode :: StixExpr -> NatM CondCode + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if alpha_TARGET_ARCH getCondCode = panic "MachCode.getCondCode: not on Alphas" #endif {- alpha_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH || sparc_TARGET_ARCH -- yes, they really do seem to want exactly the same! -getCondCode (StPrim primop [x, y]) - = case primop of - CharGtOp -> condIntCode GTT x y - CharGeOp -> condIntCode GE x y - CharEqOp -> condIntCode EQQ x y - CharNeOp -> condIntCode NE x y - CharLtOp -> condIntCode LTT x y - CharLeOp -> condIntCode LE x y +getCondCode (StMachOp mop [x, y]) + = case mop of + MO_32U_Gt -> condIntCode GTT x y + MO_32U_Ge -> condIntCode GE x y + MO_32U_Eq -> condIntCode EQQ x y + MO_32U_Ne -> condIntCode NE x y + MO_32U_Lt -> condIntCode LTT x y + MO_32U_Le -> condIntCode LE x y - IntGtOp -> condIntCode GTT x y - IntGeOp -> condIntCode GE x y - IntEqOp -> condIntCode EQQ x y - IntNeOp -> condIntCode NE x y - IntLtOp -> condIntCode LTT x y - IntLeOp -> condIntCode LE x y - - WordGtOp -> condIntCode GU x y - WordGeOp -> condIntCode GEU x y - WordEqOp -> condIntCode EQQ x y - WordNeOp -> condIntCode NE x y - WordLtOp -> condIntCode LU x y - WordLeOp -> condIntCode LEU x y - - AddrGtOp -> condIntCode GU x y - AddrGeOp -> condIntCode GEU x y - AddrEqOp -> condIntCode EQQ x y - AddrNeOp -> condIntCode NE x y - AddrLtOp -> condIntCode LU x y - AddrLeOp -> condIntCode LEU x y - - FloatGtOp -> condFltCode GTT x y - FloatGeOp -> condFltCode GE x y - FloatEqOp -> condFltCode EQQ x y - FloatNeOp -> condFltCode NE x y - FloatLtOp -> condFltCode LTT x y - FloatLeOp -> condFltCode LE x y - - DoubleGtOp -> condFltCode GTT x y - DoubleGeOp -> condFltCode GE x y - DoubleEqOp -> condFltCode EQQ x y - DoubleNeOp -> condFltCode NE x y - DoubleLtOp -> condFltCode LTT x y - DoubleLeOp -> condFltCode LE x y + MO_Nat_Eq -> condIntCode EQQ x y + MO_Nat_Ne -> condIntCode NE x y + + MO_NatS_Gt -> condIntCode GTT x y + MO_NatS_Ge -> condIntCode GE x y + MO_NatS_Lt -> condIntCode LTT x y + MO_NatS_Le -> condIntCode LE x y + + MO_NatU_Gt -> condIntCode GU x y + MO_NatU_Ge -> condIntCode GEU x y + MO_NatU_Lt -> condIntCode LU x y + MO_NatU_Le -> condIntCode LEU x y + + MO_Flt_Gt -> condFltCode GTT x y + MO_Flt_Ge -> condFltCode GE x y + MO_Flt_Eq -> condFltCode EQQ x y + MO_Flt_Ne -> condFltCode NE x y + MO_Flt_Lt -> condFltCode LTT x y + MO_Flt_Le -> condFltCode LE x y + + MO_Dbl_Gt -> condFltCode GTT x y + MO_Dbl_Ge -> condFltCode GE x y + MO_Dbl_Eq -> condFltCode EQQ x y + MO_Dbl_Ne -> condFltCode NE x y + MO_Dbl_Lt -> condFltCode LTT x y + MO_Dbl_Le -> condFltCode LE x y + + other -> pprPanic "getCondCode(x86,sparc)" (pprMachOp mop) + +getCondCode other = pprPanic "getCondCode(2)(x86,sparc)" (pprStixExpr other) #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \end{code} % ----------------- @@ -1413,7 +1759,7 @@ getCondCode (StPrim primop [x, y]) passed back up the tree. \begin{code} -condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> NatM CondCode +condIntCode, condFltCode :: Cond -> StixExpr -> StixExpr -> NatM CondCode #if alpha_TARGET_ARCH condIntCode = panic "MachCode.condIntCode: not on Alphas" @@ -1425,19 +1771,16 @@ condFltCode = panic "MachCode.condFltCode: not on Alphas" -- memory vs immediate condIntCode cond (StInd pk x) y - | maybeToBool imm + | Just i <- maybeImm y = getAmode x `thenNat` \ amode -> let code1 = amodeCode amode x__2 = amodeAddr amode sz = primRepToSize pk code__2 = code1 `snocOL` - CMP sz (OpImm imm__2) (OpAddr x__2) + CMP sz (OpImm i) (OpAddr x__2) in returnNat (CondCode False cond code__2) - where - imm = maybeImm y - imm__2 = case imm of Just x -> x -- anything vs zero condIntCode cond x (StInt 0) @@ -1453,19 +1796,16 @@ condIntCode cond x (StInt 0) -- anything vs immediate condIntCode cond x y - | maybeToBool imm + | Just i <- maybeImm y = getRegister x `thenNat` \ register1 -> getNewRegNCG IntRep `thenNat` \ tmp1 -> let code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 code__2 = code1 `snocOL` - CMP L (OpImm imm__2) (OpReg src1) + CMP L (OpImm i) (OpReg src1) in returnNat (CondCode False cond code__2) - where - imm = maybeImm y - imm__2 = case imm of Just x -> x -- memory vs anything condIntCode cond (StInd pk x) y @@ -1540,7 +1880,8 @@ condIntCode cond x y ----------- condFltCode cond x y - = getRegister x `thenNat` \ register1 -> + = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT])) + getRegister x `thenNat` \ register1 -> getRegister y `thenNat` \ register2 -> getNewRegNCG (registerRep register1) `thenNat` \ tmp1 -> @@ -1548,7 +1889,6 @@ condFltCode cond x y `thenNat` \ tmp2 -> getNewRegNCG DoubleRep `thenNat` \ tmp -> let - pk1 = registerRep register1 code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 @@ -1558,31 +1898,22 @@ condFltCode cond x y code__2 | isAny register1 = code1 `appOL` -- result in tmp1 code2 `snocOL` - GCMP (primRepToSize pk1) tmp1 src2 + GCMP cond tmp1 src2 | otherwise = code1 `snocOL` GMOV src1 tmp1 `appOL` code2 `snocOL` - GCMP (primRepToSize pk1) tmp1 src2 - - {- On the 486, the flags set by FP compare are the unsigned ones! - (This looks like a HACK to me. WDP 96/03) - -} - fix_FP_cond :: Cond -> Cond - - fix_FP_cond GE = GEU - fix_FP_cond GTT = GU - fix_FP_cond LTT = LU - fix_FP_cond LE = LEU - fix_FP_cond any = any + GCMP cond tmp1 src2 in - returnNat (CondCode True (fix_FP_cond cond) code__2) - - + -- The GCMP insn does the test and sets the zero flag if comparable + -- and true. Hence we always supply EQQ as the condition to test. + returnNat (CondCode True EQQ code__2) #endif {- i386_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if sparc_TARGET_ARCH condIntCode cond x (StInt y) @@ -1646,6 +1977,8 @@ condFltCode cond x y returnNat (CondCode True cond code__2) #endif {- sparc_TARGET_ARCH -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \end{code} %************************************************************************ @@ -1663,8 +1996,13 @@ generation for the right hand side. This only fails when the right hand side is forced into a fixed register (e.g. the result of a call). \begin{code} -assignIntCode, assignFltCode - :: PrimRep -> StixTree -> StixTree -> NatM InstrBlock +assignMem_IntCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock +assignReg_IntCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock + +assignMem_FltCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock +assignReg_FltCode :: PrimRep -> StixReg -> StixExpr -> NatM InstrBlock + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if alpha_TARGET_ARCH @@ -1696,13 +2034,14 @@ assignIntCode pk dst src returnNat code__2 #endif {- alpha_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if i386_TARGET_ARCH --- Destination of an assignment can only be reg or mem. --- This is the mem case. -assignIntCode pk (StInd _ dst) src - = getAmode dst `thenNat` \ amode -> +-- non-FP assignment to memory +assignMem_IntCode pk addr src + = getAmode addr `thenNat` \ amode -> get_op_RI src `thenNat` \ (codesrc, opsrc) -> getNewRegNCG PtrRep `thenNat` \ tmp -> let @@ -1719,7 +2058,6 @@ assignIntCode pk (StInd _ dst) src = codesrc `snocOL` MOV (primRepToSize pk) opsrc (OpAddr dst__a) | otherwise - = codea `snocOL` LEA L (OpAddr dst__a) (OpReg tmp) `appOL` codesrc `snocOL` @@ -1729,15 +2067,12 @@ assignIntCode pk (StInd _ dst) src returnNat code where get_op_RI - :: StixTree + :: StixExpr -> NatM (InstrBlock,Operand) -- code, operator get_op_RI op - | maybeToBool imm - = returnNat (nilOL, OpImm imm_op) - where - imm = maybeImm op - imm_op = case imm of Just x -> x + | Just x <- maybeImm op + = returnNat (nilOL, OpImm x) get_op_RI op = getRegister op `thenNat` \ register -> @@ -1749,53 +2084,52 @@ assignIntCode pk (StInd _ dst) src returnNat (code, OpReg reg) -- Assign; dst is a reg, rhs is mem -assignIntCode pk dst (StInd pks src) +assignReg_IntCode pk reg (StInd pks src) = getNewRegNCG PtrRep `thenNat` \ tmp -> getAmode src `thenNat` \ amode -> - getRegister dst `thenNat` \ reg_dst -> + getRegisterReg reg `thenNat` \ reg_dst -> let c_addr = amodeCode amode am_addr = amodeAddr amode - - c_dst = registerCode reg_dst tmp -- should be empty r_dst = registerName reg_dst tmp szs = primRepToSize pks - opc = case szs of L -> MOV L ; B -> MOVZxL B - - code | isNilOL c_dst - = c_addr `snocOL` + opc = case szs of + B -> MOVSxL B + Bu -> MOVZxL Bu + W -> MOVSxL W + Wu -> MOVZxL Wu + L -> MOV L + Lu -> MOV L + + code = c_addr `snocOL` opc (OpAddr am_addr) (OpReg r_dst) - | otherwise - = pprPanic "assignIntCode(x86): bad dst(2)" empty in returnNat code -- dst is a reg, but src could be anything -assignIntCode pk dst src - = getRegister dst `thenNat` \ registerd -> +assignReg_IntCode pk reg src + = getRegisterReg reg `thenNat` \ registerd -> getRegister src `thenNat` \ registers -> getNewRegNCG IntRep `thenNat` \ tmp -> let r_dst = registerName registerd tmp - c_dst = registerCode registerd tmp -- should be empty r_src = registerName registers r_dst c_src = registerCode registers r_dst - code | isNilOL c_dst - = c_src `snocOL` + code = c_src `snocOL` MOV L (OpReg r_src) (OpReg r_dst) - | otherwise - = pprPanic "assignIntCode(x86): bad dst(3)" empty in returnNat code #endif {- i386_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if sparc_TARGET_ARCH -assignIntCode pk (StInd _ dst) src - = getNewRegNCG IntRep `thenNat` \ tmp -> - getAmode dst `thenNat` \ amode -> +assignMem_IntCode pk addr src + = getNewRegNCG IntRep `thenNat` \ tmp -> + getAmode addr `thenNat` \ amode -> getRegister src `thenNat` \ register -> let code1 = amodeCode amode @@ -1807,9 +2141,9 @@ assignIntCode pk (StInd _ dst) src in returnNat code__2 -assignIntCode pk dst src - = getRegister dst `thenNat` \ register1 -> - getRegister src `thenNat` \ register2 -> +assignReg_IntCode pk reg src + = getRegister src `thenNat` \ register2 -> + getRegisterReg reg `thenNat` \ register1 -> let dst__2 = registerName register1 g0 code = registerCode register2 dst__2 @@ -1821,12 +2155,16 @@ assignIntCode pk dst src returnNat code__2 #endif {- sparc_TARGET_ARCH -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \end{code} % -------------------------------- Floating-point assignments: % -------------------------------- + \begin{code} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if alpha_TARGET_ARCH assignFltCode pk (StInd _ dst) src @@ -1857,14 +2195,13 @@ assignFltCode pk dst src returnNat code__2 #endif {- alpha_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if i386_TARGET_ARCH --- dst is memory -assignFltCode pk (StInd pk_dst addr) src - | pk /= pk_dst - = pprPanic "assignFltCode(x86): src/ind sz mismatch" empty - | otherwise +-- Floating point assignment to memory +assignMem_FltCode pk addr src = getRegister src `thenNat` \ reg_src -> getRegister addr `thenNat` \ reg_addr -> getNewRegNCG pk `thenNat` \ tmp_src -> @@ -1885,36 +2222,33 @@ assignFltCode pk (StInd pk_dst addr) src in returnNat code --- dst must be a (FP) register -assignFltCode pk dst src - = getRegister dst `thenNat` \ reg_dst -> +-- Floating point assignment to a register/temporary +assignReg_FltCode pk reg src + = getRegisterReg reg `thenNat` \ reg_dst -> getRegister src `thenNat` \ reg_src -> getNewRegNCG pk `thenNat` \ tmp -> let r_dst = registerName reg_dst tmp - c_dst = registerCode reg_dst tmp -- should be empty - r_src = registerName reg_src r_dst c_src = registerCode reg_src r_dst - code | isNilOL c_dst - = if isFixed reg_src + code = if isFixed reg_src then c_src `snocOL` GMOV r_src r_dst else c_src - | otherwise - = pprPanic "assignFltCode(x86): lhs is not mem or reg" - empty in returnNat code #endif {- i386_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if sparc_TARGET_ARCH -assignFltCode pk (StInd _ dst) src +-- Floating point assignment to memory +assignMem_FltCode pk addr src = getNewRegNCG pk `thenNat` \ tmp1 -> - getAmode dst `thenNat` \ amode -> + getAmode addr `thenNat` \ amode -> getRegister src `thenNat` \ register -> let sz = primRepToSize pk @@ -1934,8 +2268,10 @@ assignFltCode pk (StInd _ dst) src in returnNat code__2 -assignFltCode pk dst src - = getRegister dst `thenNat` \ register1 -> +-- Floating point assignment to a register/temporary +-- Why is this so bizarrely ugly? +assignReg_FltCode pk reg src + = getRegisterReg reg `thenNat` \ register1 -> getRegister src `thenNat` \ register2 -> let pk__2 = registerRep register2 @@ -1945,14 +2281,9 @@ assignFltCode pk dst src let sz = primRepToSize pk dst__2 = registerName register1 g0 -- must be Fixed - - reg__2 = if pk /= pk__2 then tmp else dst__2 - code = registerCode register2 reg__2 - src__2 = registerName register2 reg__2 - code__2 = if pk /= pk__2 then code `snocOL` FxTOy sz__2 sz src__2 dst__2 @@ -1964,6 +2295,8 @@ assignFltCode pk dst src returnNat code__2 #endif {- sparc_TARGET_ARCH -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \end{code} %************************************************************************ @@ -1981,7 +2314,9 @@ branch instruction. Other CLabels are assumed to be far away. register allocator. \begin{code} -genJump :: StixTree{-the branch target-} -> NatM InstrBlock +genJump :: DestInfo -> StixExpr{-the branch target-} -> NatM InstrBlock + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if alpha_TARGET_ARCH @@ -1992,7 +2327,7 @@ genJump (StCLbl lbl) target = ImmCLbl lbl genJump tree - = getRegister tree `thenNat` \ register -> + = getRegister tree `thenNat` \ register -> getNewRegNCG PtrRep `thenNat` \ tmp -> let dst = registerName register pv @@ -2005,20 +2340,22 @@ genJump tree returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0)) #endif {- alpha_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if i386_TARGET_ARCH -genJump (StInd pk mem) +genJump dsts (StInd pk mem) = getAmode mem `thenNat` \ amode -> let code = amodeCode amode target = amodeAddr amode in - returnNat (code `snocOL` JMP (OpAddr target)) + returnNat (code `snocOL` JMP dsts (OpAddr target)) -genJump tree +genJump dsts tree | maybeToBool imm - = returnNat (unitOL (JMP (OpImm target))) + = returnNat (unitOL (JMP dsts (OpImm target))) | otherwise = getRegister tree `thenNat` \ register -> @@ -2027,31 +2364,36 @@ genJump tree code = registerCode register tmp target = registerName register tmp in - returnNat (code `snocOL` JMP (OpReg target)) + returnNat (code `snocOL` JMP dsts (OpReg target)) where imm = maybeImm tree target = case imm of Just x -> x #endif {- i386_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if sparc_TARGET_ARCH -genJump (StCLbl lbl) - | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP]) - | otherwise = returnNat (toOL [CALL target 0 True, NOP]) +genJump dsts (StCLbl lbl) + | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts" + | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP]) + | otherwise = returnNat (toOL [CALL (Left target) 0 True, NOP]) where target = ImmCLbl lbl -genJump tree +genJump dsts tree = getRegister tree `thenNat` \ register -> getNewRegNCG PtrRep `thenNat` \ tmp -> let code = registerCode register tmp target = registerName register tmp in - returnNat (code `snocOL` JMP (AddrRegReg target g0) `snocOL` NOP) + returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP) #endif {- sparc_TARGET_ARCH -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \end{code} %************************************************************************ @@ -2082,9 +2424,11 @@ allocator. \begin{code} genCondJump :: CLabel -- the branch target - -> StixTree -- the condition on which to branch + -> StixExpr -- the condition on which to branch -> NatM InstrBlock +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if alpha_TARGET_ARCH genCondJump lbl (StPrim op [x, StInt 0]) @@ -2227,7 +2571,9 @@ genCondJump lbl (StPrim op [x, y]) AddrLeOp -> (CMP ULE, NE) #endif {- alpha_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if i386_TARGET_ARCH genCondJump lbl bool @@ -2235,12 +2581,13 @@ genCondJump lbl bool let code = condCode condition cond = condName condition - target = ImmCLbl lbl in returnNat (code `snocOL` JXX cond lbl) #endif {- i386_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if sparc_TARGET_ARCH genCondJump lbl bool @@ -2260,6 +2607,8 @@ genCondJump lbl bool ) #endif {- sparc_TARGET_ARCH -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \end{code} %************************************************************************ @@ -2277,12 +2626,14 @@ register allocator. \begin{code} genCCall - :: FAST_STRING -- function to call - -> CallConv + :: (Either FastString StixExpr) -- function to call + -> CCallConv -> PrimRep -- type of the result - -> [StixTree] -- arguments (of mixed type) + -> [StixExpr] -- arguments (of mixed type) -> NatM InstrBlock +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if alpha_TARGET_ARCH genCCall fn cconv kind args @@ -2350,59 +2701,83 @@ genCCall fn cconv kind args returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset))) #endif {- alpha_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if i386_TARGET_ARCH -genCCall fn cconv kind [StInt i] - | fn == SLIT ("PerformGC_wrapper") - = let call = toOL [ - MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax), - CALL (ImmLit (ptext (if underscorePrefix - then (SLIT ("_PerformGC_wrapper")) - else (SLIT ("PerformGC_wrapper"))))) - ] - in - returnNat call - - -genCCall fn cconv kind args - = mapNat get_call_arg - (reverse args) `thenNat` \ sizes_n_codes -> - getDeltaNat `thenNat` \ delta -> - let (sizes, codes) = unzip sizes_n_codes - tot_arg_size = sum sizes - code2 = concatOL codes - call = toOL [ - CALL fn__2, - ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp), - DELTA (delta + tot_arg_size) - ] +genCCall fn cconv ret_rep args + = mapNat push_arg + (reverse args) `thenNat` \ sizes_n_codes -> + getDeltaNat `thenNat` \ delta -> + let (sizes, push_codes) = unzip sizes_n_codes + tot_arg_size = sum sizes + in + -- deal with static vs dynamic call targets + (case fn of + Left t_static + -> returnNat (unitOL (CALL (Left (fn__2 tot_arg_size)))) + Right dyn + -> get_op dyn `thenNat` \ (dyn_c, dyn_r, dyn_rep) -> + ASSERT(case dyn_rep of { L -> True; _ -> False}) + returnNat (dyn_c `snocOL` CALL (Right dyn_r)) + ) + `thenNat` \ callinsns -> + let push_code = concatOL push_codes + call = callinsns `appOL` + toOL ( + -- Deallocate parameters after call for ccall; + -- but not for stdcall (callee does it) + (if cconv == StdCallConv then [] else + [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)]) + ++ + [DELTA (delta + tot_arg_size)] + ) in setDeltaNat (delta + tot_arg_size) `thenNat` \ _ -> - returnNat (code2 `appOL` call) + returnNat (push_code `appOL` call) where -- function names that begin with '.' are assumed to be special -- internally generated names like '.mul,' which don't get an -- underscore prefix -- ToDo:needed (WDP 96/03) ??? - fn__2 = case (_HEAD_ fn) of - '.' -> ImmLit (ptext fn) - _ -> ImmLab False (ptext fn) + fn_u = unpackFS (unLeft fn) + fn__2 tot_arg_size + | head fn_u == '.' + = ImmLit (text (fn_u ++ stdcallsize tot_arg_size)) + | otherwise -- General case + = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size)) + + stdcallsize tot_arg_size + | cconv == StdCallConv = '@':show tot_arg_size + | otherwise = "" arg_size DF = 8 arg_size F = 4 arg_size _ = 4 ------------ - get_call_arg :: StixTree{-current argument-} + push_arg :: StixExpr{-current argument-} -> NatM (Int, InstrBlock) -- argsz, code - get_call_arg arg - = get_op arg `thenNat` \ (code, reg, sz) -> - getDeltaNat `thenNat` \ delta -> - arg_size sz `bind` \ size -> - setDeltaNat (delta-size) `thenNat` \ _ -> + push_arg arg + | is64BitRep arg_rep + = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) -> + getDeltaNat `thenNat` \ delta -> + setDeltaNat (delta - 8) `thenNat` \ _ -> + let r_lo = VirtualRegI vr_lo + r_hi = getHiVRegFromLo r_lo + in returnNat (8, + code `appOL` + toOL [PUSH L (OpReg r_hi), DELTA (delta - 4), + PUSH L (OpReg r_lo), DELTA (delta - 8)] + ) + | otherwise + = get_op arg `thenNat` \ (code, reg, sz) -> + getDeltaNat `thenNat` \ delta -> + arg_size sz `bind` \ size -> + setDeltaNat (delta-size) `thenNat` \ _ -> if (case sz of DF -> True; F -> True; _ -> False) then returnNat (size, code `appOL` @@ -2417,9 +2792,12 @@ genCCall fn cconv kind args PUSH L (OpReg reg) `snocOL` DELTA (delta-size) ) + where + arg_rep = repOfStixExpr arg + ------------ get_op - :: StixTree + :: StixExpr -> NatM (InstrBlock, Reg, Size) -- code, reg, size get_op op @@ -2435,122 +2813,149 @@ genCCall fn cconv kind args returnNat (code, reg, sz) #endif {- i386_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if sparc_TARGET_ARCH +{- + The SPARC calling convention is an absolute + nightmare. The first 6x32 bits of arguments are mapped into + %o0 through %o5, and the remaining arguments are dumped to the + stack, beginning at [%sp+92]. (Note that %o6 == %sp.) + + If we have to put args on the stack, move %o6==%sp down by + the number of words to go on the stack, to ensure there's enough space. + + According to Fraser and Hanson's lcc book, page 478, fig 17.2, + 16 words above the stack pointer is a word for the address of + a structure return value. I use this as a temporary location + for moving values from float to int regs. Certainly it isn't + safe to put anything in the 16 words starting at %sp, since + this area can get trashed at any time due to window overflows + caused by signal handlers. + + A final complication (if the above isn't enough) is that + we can't blithely calculate the arguments one by one into + %o0 .. %o5. Consider the following nested calls: + + fff a (fff b c) + + Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately + the inner call will itself use %o0, which trashes the value put there + in preparation for the outer call. Upshot: we need to calculate the + args into temporary regs, and move those to arg regs or onto the + stack only immediately prior to the call proper. Sigh. +-} + genCCall fn cconv kind args - = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args - `thenNat` \ ((unused,_), argCode) -> + = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs -> + let + (argcodes, vregss) = unzip argcode_and_vregs + n_argRegs = length allArgRegs + n_argRegs_used = min (length vregs) n_argRegs + vregs = concat vregss + in + -- deal with static vs dynamic call targets + (case fn of + Left t_static + -> returnNat (unitOL (CALL (Left fn__2) n_argRegs_used False)) + Right dyn + -> arg_to_int_vregs dyn `thenNat` \ (dyn_c, [dyn_r]) -> + returnNat (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) + ) + `thenNat` \ callinsns -> let - - nRegs = length allArgRegs - length unused - call = unitOL (CALL fn__2 nRegs False) - code = concatOL argCode - - -- 3 because in the worst case, %o0 .. %o5 will only use up 3 args + argcode = concatOL argcodes (move_sp_down, move_sp_up) - = let nn = length args - 3 + = let nn = length vregs - n_argRegs + + 1 -- (for the road) in if nn <= 0 then (nilOL, nilOL) - else (unitOL (moveSp (-(2*nn))), unitOL (moveSp (2*nn))) - in - returnNat (move_sp_down `appOL` - code `appOL` - call `appOL` - unitOL NOP `appOL` + else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn))) + transfer_code + = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE) + in + returnNat (argcode `appOL` + move_sp_down `appOL` + transfer_code `appOL` + callinsns `appOL` + unitOL NOP `appOL` move_sp_up) where - -- function names that begin with '.' are assumed to be special - -- internally generated names like '.mul,' which don't get an - -- underscore prefix - -- ToDo:needed (WDP 96/03) ??? - fn__2 = case (_HEAD_ fn) of - '.' -> ImmLit (ptext fn) - _ -> ImmLab False (ptext fn) - - ------------------------------------ - {- Try to get a value into a specific register (or registers) for - a call. The SPARC calling convention is an absolute - nightmare. The first 6x32 bits of arguments are mapped into - %o0 through %o5, and the remaining arguments are dumped to the - stack, beginning at [%sp+92]. (Note that %o6 == %sp.) Our - first argument is a pair of the list of remaining argument - registers to be assigned for this call and the next stack - offset to use for overflowing arguments. This way, - @get_arg@ can be applied to all of a call's arguments using - @mapAccumL@. - - If we have to put args on the stack, move %o6==%sp down by - 8 x the number of args, to ensure there's enough space. - -} - get_arg - :: ([Reg],Int) -- Argument registers and stack offset (accumulator) - -> StixTree -- Current argument - -> NatM (([Reg],Int), InstrBlock) -- Updated accumulator and code - - -- We have to use up all of our argument registers first... - - get_arg (dst:dsts, offset) arg - = getRegister arg `thenNat` \ register -> - getNewRegNCG (registerRep register) - `thenNat` \ tmp -> - let - reg = if isFloatingRep pk then tmp else dst - code = registerCode register reg - src = registerName register reg - pk = registerRep register - in - returnNat ( - case pk of - DoubleRep -> - case dsts of - [] -> ( ([], offset + 1), - code `snocOL` - -- put the second part in the right stack - -- and load the first part into %o5 - FMOV DF src f0 `snocOL` - ST F f0 (spRel offset) `snocOL` - LD W (spRel offset) dst `snocOL` - ST F (fPair f0) (spRel offset) - ) - (dst__2:dsts__2) - -> ( (dsts__2, offset), - code `snocOL` - FMOV DF src f0 `snocOL` - ST F f0 (spRel 16) `snocOL` - LD W (spRel 16) dst `snocOL` - ST F (fPair f0) (spRel 16) `snocOL` - LD W (spRel 16) dst__2 - ) - FloatRep - -> ( (dsts, offset), - code `snocOL` - ST F src (spRel 16) `snocOL` - LD W (spRel 16) dst - ) - _ -> ( (dsts, offset), - if isFixed register - then code `snocOL` OR False g0 (RIReg src) dst - else code - ) - ) - -- Once we have run out of argument registers, we move to the - -- stack... - - get_arg ([], offset) arg - = getRegister arg `thenNat` \ register -> - getNewRegNCG (registerRep register) - `thenNat` \ tmp -> - let - code = registerCode register tmp - src = registerName register tmp - pk = registerRep register - sz = primRepToSize pk - words = if pk == DoubleRep then 2 else 1 - in - returnNat ( ([], offset + words), - code `snocOL` ST sz src (spRel offset) ) - + -- function names that begin with '.' are assumed to be special + -- internally generated names like '.mul,' which don't get an + -- underscore prefix + -- ToDo:needed (WDP 96/03) ??? + fn_static = unLeft fn + fn__2 = case (headFS fn_static) of + '.' -> ImmLit (ftext fn_static) + _ -> ImmLab False (ftext fn_static) + + -- move args from the integer vregs into which they have been + -- marshalled, into %o0 .. %o5, and the rest onto the stack. + move_final :: [Reg] -> [Reg] -> Int -> [Instr] + + move_final [] _ offset -- all args done + = [] + + move_final (v:vs) [] offset -- out of aregs; move to stack + = ST W v (spRel offset) + : move_final vs [] (offset+1) + + move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg + = OR False g0 (RIReg v) a + : move_final vs az offset + + -- generate code to calculate an argument, and move it into one + -- or two integer vregs. + arg_to_int_vregs :: StixExpr -> NatM (OrdList Instr, [Reg]) + arg_to_int_vregs arg + | is64BitRep (repOfStixExpr arg) + = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) -> + let r_lo = VirtualRegI vr_lo + r_hi = getHiVRegFromLo r_lo + in returnNat (code, [r_hi, r_lo]) + | otherwise + = getRegister arg `thenNat` \ register -> + getNewRegNCG (registerRep register) `thenNat` \ tmp -> + let code = registerCode register tmp + src = registerName register tmp + pk = registerRep register + in + -- the value is in src. Get it into 1 or 2 int vregs. + case pk of + DoubleRep -> + getNewRegNCG WordRep `thenNat` \ v1 -> + getNewRegNCG WordRep `thenNat` \ v2 -> + returnNat ( + code `snocOL` + FMOV DF src f0 `snocOL` + ST F f0 (spRel 16) `snocOL` + LD W (spRel 16) v1 `snocOL` + ST F (fPair f0) (spRel 16) `snocOL` + LD W (spRel 16) v2 + , + [v1,v2] + ) + FloatRep -> + getNewRegNCG WordRep `thenNat` \ v1 -> + returnNat ( + code `snocOL` + ST F src (spRel 16) `snocOL` + LD W (spRel 16) v1 + , + [v1] + ) + other -> + getNewRegNCG WordRep `thenNat` \ v1 -> + returnNat ( + code `snocOL` OR False g0 (RIReg src) v1 + , + [v1] + ) #endif {- sparc_TARGET_ARCH -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \end{code} %************************************************************************ @@ -2572,7 +2977,9 @@ the right hand side of an assignment). register allocator. \begin{code} -condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> NatM Register +condIntReg, condFltReg :: Cond -> StixExpr -> StixExpr -> NatM Register + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if alpha_TARGET_ARCH condIntReg = panic "MachCode.condIntReg (not on Alpha)" @@ -2580,6 +2987,7 @@ condFltReg = panic "MachCode.condFltReg (not on Alpha)" #endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if i386_TARGET_ARCH condIntReg cond x y @@ -2613,7 +3021,9 @@ condFltReg cond x y returnNat (Any IntRep code__2) #endif {- i386_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if sparc_TARGET_ARCH condIntReg EQQ x (StInt 0) @@ -2710,6 +3120,8 @@ condFltReg cond x y returnNat (Any IntRep code__2) #endif {- sparc_TARGET_ARCH -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \end{code} %************************************************************************ @@ -2734,7 +3146,7 @@ trivialCode -> Maybe (Operand -> Operand -> Instr) ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr) ,))) - -> StixTree -> StixTree -- the two arguments + -> StixExpr -> StixExpr -- the two arguments -> NatM Register trivialFCode @@ -2743,7 +3155,7 @@ trivialFCode ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr) ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr) ,))) - -> StixTree -> StixTree -- the two arguments + -> StixExpr -> StixExpr -- the two arguments -> NatM Register trivialUCode @@ -2751,7 +3163,7 @@ trivialUCode ,IF_ARCH_i386 ((Operand -> Instr) ,IF_ARCH_sparc((RI -> Reg -> Instr) ,))) - -> StixTree -- the one argument + -> StixExpr -- the one argument -> NatM Register trivialUFCode @@ -2760,9 +3172,11 @@ trivialUFCode ,IF_ARCH_i386 ((Reg -> Reg -> Instr) ,IF_ARCH_sparc((Reg -> Reg -> Instr) ,))) - -> StixTree -- the one argument + -> StixExpr -- the one argument -> NatM Register +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if alpha_TARGET_ARCH trivialCode instr x (StInt y) @@ -2832,7 +3246,9 @@ trivialUFCode _ instr x returnNat (Any DoubleRep code__2) #endif {- alpha_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if i386_TARGET_ARCH \end{code} The Rules of the Game are: @@ -3011,7 +3427,9 @@ trivialUFCode pk instr x returnNat (Any pk code__2) #endif {- i386_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if sparc_TARGET_ARCH trivialCode instr x (StInt y) @@ -3097,6 +3515,8 @@ trivialUFCode pk instr x returnNat (Any pk code__2) #endif {- sparc_TARGET_ARCH -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \end{code} %************************************************************************ @@ -3105,40 +3525,26 @@ trivialUFCode pk instr x %* * %************************************************************************ -@coerce(Int|Flt)Code@ are simple coercions that don't require any code -to be generated. Here we just change the type on the Register passed -on up. The code is machine-independent. - @coerce(Int2FP|FP2Int)@ are more complicated integer/float conversions. We have to store temporaries in memory to move between the integer and the floating point register sets. -\begin{code} -coerceIntCode :: PrimRep -> StixTree -> NatM Register -coerceFltCode :: StixTree -> NatM Register - -coerceInt2FP :: PrimRep -> StixTree -> NatM Register -coerceFP2Int :: StixTree -> NatM Register +@coerceDbl2Flt@ and @coerceFlt2Dbl@ are done this way because we +pretend, on sparc at least, that double and float regs are seperate +kinds, so the value has to be computed into one kind before being +explicitly "converted" to live in the other kind. -coerceIntCode pk x - = getRegister x `thenNat` \ register -> - returnNat ( - case register of - Fixed _ reg code -> Fixed pk reg code - Any _ code -> Any pk code - ) +\begin{code} +coerceInt2FP :: PrimRep -> StixExpr -> NatM Register +coerceFP2Int :: PrimRep -> StixExpr -> NatM Register -------------- -coerceFltCode x - = getRegister x `thenNat` \ register -> - returnNat ( - case register of - Fixed _ reg code -> Fixed DoubleRep reg code - Any _ code -> Any DoubleRep code - ) +coerceDbl2Flt :: StixExpr -> NatM Register +coerceFlt2Dbl :: StixExpr -> NatM Register \end{code} \begin{code} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if alpha_TARGET_ARCH coerceInt2FP _ x @@ -3171,7 +3577,9 @@ coerceFP2Int x returnNat (Any IntRep code__2) #endif {- alpha_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if i386_TARGET_ARCH coerceInt2FP pk x @@ -3186,7 +3594,7 @@ coerceInt2FP pk x returnNat (Any pk code__2) ------------ -coerceFP2Int x +coerceFP2Int fprep x = getRegister x `thenNat` \ register -> getNewRegNCG DoubleRep `thenNat` \ tmp -> let @@ -3199,8 +3607,14 @@ coerceFP2Int x in returnNat (Any IntRep code__2) +------------ +coerceDbl2Flt x = panic "MachCode.coerceDbl2Flt: unused on x86" +coerceFlt2Dbl x = panic "MachCode.coerceFlt2Dbl: unused on x86" + #endif {- i386_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if sparc_TARGET_ARCH coerceInt2FP pk x @@ -3218,96 +3632,42 @@ coerceInt2FP pk x returnNat (Any pk code__2) ------------ -coerceFP2Int x - = getRegister x `thenNat` \ register -> - getNewRegNCG IntRep `thenNat` \ reg -> +coerceFP2Int fprep x + = ASSERT(fprep == DoubleRep || fprep == FloatRep) + getRegister x `thenNat` \ register -> + getNewRegNCG fprep `thenNat` \ reg -> getNewRegNCG FloatRep `thenNat` \ tmp -> let code = registerCode register reg src = registerName register reg - pk = registerRep register - code__2 dst = code `appOL` toOL [ - FxTOy (primRepToSize pk) W src tmp, + FxTOy (primRepToSize fprep) W src tmp, ST W tmp (spRel (-2)), LD W (spRel (-2)) dst] in returnNat (Any IntRep code__2) -#endif {- sparc_TARGET_ARCH -} -\end{code} - -%************************************************************************ -%* * -\subsubsection{Coercing integer to @Char@...} -%* * -%************************************************************************ - -Integer to character conversion. Where applicable, we try to do this -in one step if the original object is in memory. - -\begin{code} -chrCode :: StixTree -> NatM Register - -#if alpha_TARGET_ARCH - -chrCode x - = getRegister x `thenNat` \ register -> - getNewRegNCG IntRep `thenNat` \ reg -> - let - code = registerCode register reg - src = registerName register reg - code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst) - in - returnNat (Any IntRep code__2) - -#endif {- alpha_TARGET_ARCH -} --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#if i386_TARGET_ARCH - -chrCode x +------------ +coerceDbl2Flt x = getRegister x `thenNat` \ register -> - let - code__2 dst = let - code = registerCode register dst - src = registerName register dst - in code `appOL` - if isFixed register && src /= dst - then toOL [MOV L (OpReg src) (OpReg dst), - AND L (OpImm (ImmInt 255)) (OpReg dst)] - else unitOL (AND L (OpImm (ImmInt 255)) (OpReg src)) - in - returnNat (Any IntRep code__2) - -#endif {- i386_TARGET_ARCH -} --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#if sparc_TARGET_ARCH - -chrCode (StInd pk mem) - = getAmode mem `thenNat` \ amode -> - let - code = amodeCode amode - src = amodeAddr amode - src_off = addrOffset src 3 - src__2 = case src_off of Just x -> x - code__2 dst = if maybeToBool src_off then - code `snocOL` LD BU src__2 dst - else - code `snocOL` - LD (primRepToSize pk) src dst `snocOL` - AND False dst (RIImm (ImmInt 255)) dst + getNewRegNCG DoubleRep `thenNat` \ tmp -> + let code = registerCode register tmp + src = registerName register tmp in - returnNat (Any pk code__2) + returnNat (Any FloatRep + (\dst -> code `snocOL` FxTOy DF F src dst)) -chrCode x +------------ +coerceFlt2Dbl x = getRegister x `thenNat` \ register -> - getNewRegNCG IntRep `thenNat` \ reg -> - let - code = registerCode register reg - src = registerName register reg - code__2 dst = code `snocOL` AND False src (RIImm (ImmInt 255)) dst + getNewRegNCG FloatRep `thenNat` \ tmp -> + let code = registerCode register tmp + src = registerName register tmp in - returnNat (Any IntRep code__2) + returnNat (Any DoubleRep + (\dst -> code `snocOL` FxTOy F DF src dst)) #endif {- sparc_TARGET_ARCH -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \end{code}