X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FMachCode.lhs;h=1c00641da7820e547f20146749bf75b1a4f146c5;hb=5248496621bd23d3d42f8e0929278e110797d1c1;hp=25d9be3f15ad9d9279aac8669b58edf6240325f0;hpb=7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index 25d9be3..1c00641 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -1,5 +1,5 @@ % -% (c) The AQUA Project, Glasgow University, 1996 +% (c) The AQUA Project, Glasgow University, 1996-1998 % \section[MachCode]{Generating machine code} @@ -9,77 +9,168 @@ This is a big module, but, if you pay attention to structure should not be too overwhelming. \begin{code} +module MachCode ( stmtsToInstrs, InstrBlock ) where + #include "HsVersions.h" #include "nativeGen/NCG.h" -module MachCode ( stmt2Instrs, asmVoid, InstrList(..) ) where - -import Ubiq{-uitious-} - +import Unique ( Unique ) import MachMisc -- may differ per-platform import MachRegs - -import AbsCSyn ( MagicId ) +import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL, + snocOL, consOL, concatOL ) +import MachOp ( MachOp(..), pprMachOp ) import AbsCUtils ( magicIdPrimRep ) -import CLabel ( isAsmTemp ) -import Maybes ( maybeToBool, expectJust ) -import OrdList -- quite a bit of it -import Pretty ( prettyToUn, ppRational ) -import PrimRep ( isFloatingRep, PrimRep(..) ) -import PrimOp ( PrimOp(..) ) -import Stix ( getUniqLabelNCG, StixTree(..), - StixReg(..), CodeSegment(..) - ) -import UniqSupply ( returnUs, thenUs, mapUs, mapAndUnzipUs, - mapAccumLUs, UniqSM(..) +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, getUniqueNat, + ncgPrimopMoan, + ncg_target_is_32bit ) -import Unpretty ( uppPStr ) -import Util ( panic, assertPanic ) +import Pretty +import Outputable ( panic, pprPanic, showSDoc ) +import qualified Outputable +import CmdLineOpts ( opt_Static ) +import Stix ( pprStixStmt ) + +-- DEBUGGING ONLY +import IOExts ( trace ) +import Outputable ( assertPanic ) +import FastString + +infixr 3 `bind` \end{code} -Code extractor for an entire stix tree---stix statement level. +@InstrBlock@s are the insn sequences generated by the insn selectors. +They are really trees of insns to facilitate fast appending, where a +left-to-right traversal (pre-order?) yields the insns in the correct +order. \begin{code} -stmt2Instrs :: StixTree {- a stix statement -} -> UniqSM InstrBlock +type InstrBlock = OrdList Instr + +x `bind` f = f x -stmt2Instrs stmt = case stmt of - StComment s -> returnInstr (COMMENT s) - StSegment seg -> returnInstr (SEGMENT seg) - StFunBegin lab -> returnInstr (IF_ARCH_alpha(FUNBEGIN lab,LABEL lab)) - StFunEnd lab -> IF_ARCH_alpha(returnInstr (FUNEND lab),returnUs id) - StLabel lab -> returnInstr (LABEL lab) +isLeft (Left _) = True +isLeft (Right _) = False + +unLeft (Left x) = x +\end{code} - StJump arg -> genJump arg - StCondJump lab arg -> genCondJump lab arg - StCall fn VoidRep args -> genCCall fn VoidRep args +Code extractor for an entire stix tree---stix statement level. - StAssign pk dst src - | isFloatingRep pk -> assignFltCode pk dst src - | otherwise -> assignIntCode pk dst src +\begin{code} +stmtsToInstrs :: [StixStmt] -> NatM InstrBlock +stmtsToInstrs stmts + = mapNat stmtToInstrs stmts `thenNat` \ instrss -> + returnNat (concatOL instrss) + + +stmtToInstrs :: StixStmt -> NatM InstrBlock +stmtToInstrs stmt = case stmt of + StComment s -> returnNat (unitOL (COMMENT s)) + StSegment seg -> returnNat (unitOL (SEGMENT seg)) + + StFunBegin lab -> returnNat (unitOL (IF_ARCH_alpha(FUNBEGIN lab, + LABEL lab))) + StFunEnd lab -> IF_ARCH_alpha(returnNat (unitOL (FUNEND lab)), + returnNat nilOL) + + StLabel lab -> returnNat (unitOL (LABEL lab)) + + 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. 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 -- with the address of the next routine, so that it can load gp. -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl))) - ,returnUs id) + ,returnNat nilOL) StData kind args - -> mapAndUnzipUs getData args `thenUs` \ (codes, imms) -> - returnUs (\xs -> mkSeqList (asmInstr (DATA (primRepToSize kind) imms)) - (foldr1 (.) codes xs)) + -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) -> + returnNat (DATA (primRepToSize kind) imms + `consOL` concatOL codes) where - getData :: StixTree -> UniqSM (InstrBlock, Imm) - - getData (StInt i) = returnUs (id, ImmInteger i) - getData (StDouble d) = returnUs (id, dblImmLit d) - getData (StLitLbl s) = returnUs (id, ImmLab s) - getData (StLitLit s) = returnUs (id, strImmLit (cvtLitLit (_UNPK_ s))) - getData (StCLbl l) = returnUs (id, ImmCLbl l) - getData (StString s) = - getUniqLabelNCG `thenUs` \ lbl -> - returnUs (mkSeqInstrs [LABEL lbl, - ASCII True (_UNPK_ s)], - ImmCLbl lbl) + 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) = panic "MachCode.stmtToInstrs: unlifted StString" + -- the linker can handle simple arithmetic... + getData (StIndex rep (StCLbl lbl) (StInt off)) = + 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 :: StixExpr -> StixExpr +derefDLL tree + | opt_Static -- short out the entire deal if not doing DLLs + = tree + | otherwise + = qq tree + where + qq t + = case t of + StCLbl lbl -> if labelDynamic lbl + then StInd PtrRep (StCLbl lbl) + else t + -- all the rest are boring + StIndex pk base offset -> StIndex pk (qq base) (qq offset) + StMachOp mop args -> StMachOp mop (map qq args) + StInd pk addr -> StInd pk (qq addr) + 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 + _ -> pprPanic "derefDLL: unhandled case" + (pprStixExpr t) \end{code} %************************************************************************ @@ -89,69 +180,40 @@ stmt2Instrs stmt = case stmt of %************************************************************************ \begin{code} -type InstrList = OrdList Instr -type InstrBlock = InstrList -> InstrList - -asmVoid :: InstrList -asmVoid = mkEmptyList - -asmInstr :: Instr -> InstrList -asmInstr i = mkUnitList i - -asmSeq :: [Instr] -> InstrList -asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is - -asmParThen :: [InstrList] -> InstrBlock -asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code - -returnInstr :: Instr -> UniqSM InstrBlock -returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs) - -returnInstrs :: [Instr] -> UniqSM InstrBlock -returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs) - -returnSeq :: InstrBlock -> [Instr] -> UniqSM InstrBlock -returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs)) - -mkSeqInstr :: Instr -> InstrBlock -mkSeqInstr instr code = mkSeqList (asmInstr instr) code - -mkSeqInstrs :: [Instr] -> InstrBlock -mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code -\end{code} - -\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 [base, - case pk of - CharRep -> off - _ -> let - s = shift pk - in - ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk))) - StPrim SllOp [off, StInt s] + = StMachOp MO_Nat_Add [ + base, + let s = shift pk + in if s == 0 then off + else StMachOp MO_Nat_Shl [off, StInt (toInteger s)] ] where - shift DoubleRep = 3 - 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 (StLitLbl s) = Just (ImmLab s) -maybeImm (StLitLit s) = Just (strImmLit (cvtLitLit (_UNPK_ s))) -maybeImm (StCLbl l) = Just (ImmCLbl l) +maybeImm :: StixExpr -> Maybe Imm +maybeImm (StCLbl l) + = Just (ImmCLbl l) +maybeImm (StIndex rep (StCLbl l) (StInt off)) + = 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) @@ -161,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} %* * %************************************************************************ @@ -179,74 +458,93 @@ registerCode :: Register -> Reg -> InstrBlock registerCode (Fixed _ _ code) reg = code registerCode (Any _ code) reg = code reg +registerCodeF (Fixed _ _ code) = code +registerCodeF (Any _ _) = panic "registerCodeF" + +registerCodeA (Any _ code) = code +registerCodeA (Fixed _ _ _) = panic "registerCodeA" + registerName :: Register -> Reg -> Reg registerName (Fixed _ reg _) _ = reg -registerName (Any _ _) reg = reg +registerName (Any _ _) reg = reg + +registerNameF (Fixed _ reg _) = reg +registerNameF (Any _ _) = panic "registerNameF" registerRep :: Register -> PrimRep registerRep (Fixed pk _ _) = pk registerRep (Any pk _) = pk -isFixed :: Register -> Bool +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 #-} +{-# INLINE registerNameF #-} +{-# INLINE registerRep #-} +{-# INLINE isFixed #-} +{-# INLINE isAny #-} + +isFixed, isAny :: Register -> Bool isFixed (Fixed _ _ _) = True isFixed (Any _ _) = False + +isAny = not . isFixed \end{code} Generate code to get a subtree into a @Register@: \begin{code} -getRegister :: StixTree -> UniqSM Register -getRegister (StReg (StixMagicId stgreg)) - = case (magicIdRegMaybe stgreg) of - Just reg -> returnUs (Fixed (magicIdPrimRep stgreg) reg id) - -- 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) + +getRegisterReg (StixTemp (StixVReg u pk)) + = returnNat (Fixed pk (mkVReg u pk) nilOL) + +------------- -getRegister (StReg (StixTemp u pk)) - = returnUs (Fixed pk (UnmappedReg u pk) id) +-- Don't delete this -- it's very handy for debugging. +--getRegister expr +-- | trace ("getRegiste: " ++ showSDoc (pprStixExpr expr)) False +-- = panic "getRegister(???)" -getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree) +getRegister (StReg reg) + = getRegisterReg reg -getRegister (StCall fn kind args) - = genCCall fn kind args `thenUs` \ call -> - returnUs (Fixed kind reg call) +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 reg = if isFloatingRep kind - then IF_ARCH_alpha( f0, IF_ARCH_i386( st0, IF_ARCH_sparc( f0,))) + then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,))) else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,))) getRegister (StString s) - = getUniqLabelNCG `thenUs` \ lbl -> + = getNatLabelNCG `thenNat` \ lbl -> let imm_lbl = ImmCLbl lbl - code dst = mkSeqInstrs [ - SEGMENT DataSegment, - LABEL lbl, - ASCII True (_UNPK_ s), - SEGMENT TextSegment, -#if alpha_TARGET_ARCH - LDA dst (AddrImm imm_lbl) -#endif -#if i386_TARGET_ARCH - MOV L (OpImm imm_lbl) (OpReg dst) -#endif -#if sparc_TARGET_ARCH - SETHI (HI imm_lbl) dst, - OR False dst (RIImm (LO imm_lbl)) dst -#endif - ] - in - returnUs (Any PtrRep code) - -getRegister (StLitLit s) | _HEAD_ s == '"' && last xs == '"' - = getUniqLabelNCG `thenUs` \ lbl -> - let - imm_lbl = ImmCLbl lbl - - code dst = mkSeqInstrs [ - SEGMENT DataSegment, + code dst = toOL [ + SEGMENT RoDataSegment, LABEL lbl, - ASCII False (init xs), + ASCII True (unpackFS s), SEGMENT TextSegment, #if alpha_TARGET_ARCH LDA dst (AddrImm imm_lbl) @@ -260,31 +558,29 @@ getRegister (StLitLit s) | _HEAD_ s == '"' && last xs == '"' #endif ] in - returnUs (Any PtrRep code) - where - xs = _UNPK_ (_TAIL_ s) + returnNat (Any PtrRep code) +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- end of machine-"independent" bit; here we go on the rest... #if alpha_TARGET_ARCH getRegister (StDouble d) - = getUniqLabelNCG `thenUs` \ lbl -> - getNewRegNCG PtrRep `thenUs` \ tmp -> + = getNatLabelNCG `thenNat` \ lbl -> + getNewRegNCG PtrRep `thenNat` \ tmp -> let code dst = mkSeqInstrs [ SEGMENT DataSegment, LABEL lbl, - DATA TF [ImmLab (prettyToUn (ppRational d))], + DATA TF [ImmLab (rational d)], SEGMENT TextSegment, LDA tmp (AddrImm (ImmCLbl lbl)), LD TF dst (AddrReg tmp)] in - returnUs (Any DoubleRep code) + returnNat (Any DoubleRep code) getRegister (StPrim primop [x]) -- unary PrimOps = case primop of IntNegOp -> trivialUCode (NEG Q False) x - IntAbsOp -> trivialUCode (ABS Q) x NotOp -> trivialUCode NOT x @@ -302,78 +598,78 @@ getRegister (StPrim primop [x]) -- unary PrimOps Double2FloatOp -> coerceFltCode x Float2DoubleOp -> coerceFltCode x - other_op -> getRegister (StCall fn 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" getRegister (StPrim primop [x, y]) -- dyadic PrimOps = case primop of - CharGtOp -> trivialCode (CMP LT) y x + CharGtOp -> trivialCode (CMP LTT) y x CharGeOp -> trivialCode (CMP LE) y x - CharEqOp -> trivialCode (CMP EQ) x y + CharEqOp -> trivialCode (CMP EQQ) x y CharNeOp -> int_NE_code x y - CharLtOp -> trivialCode (CMP LT) x y + CharLtOp -> trivialCode (CMP LTT) x y CharLeOp -> trivialCode (CMP LE) x y - IntGtOp -> trivialCode (CMP LT) y x + IntGtOp -> trivialCode (CMP LTT) y x IntGeOp -> trivialCode (CMP LE) y x - IntEqOp -> trivialCode (CMP EQ) x y + IntEqOp -> trivialCode (CMP EQQ) x y IntNeOp -> int_NE_code x y - IntLtOp -> trivialCode (CMP LT) x y + IntLtOp -> trivialCode (CMP LTT) x y IntLeOp -> trivialCode (CMP LE) x y WordGtOp -> trivialCode (CMP ULT) y x WordGeOp -> trivialCode (CMP ULE) x y - WordEqOp -> trivialCode (CMP EQ) x y + WordEqOp -> trivialCode (CMP EQQ) x y WordNeOp -> int_NE_code x y WordLtOp -> trivialCode (CMP ULT) x y WordLeOp -> trivialCode (CMP ULE) x y AddrGtOp -> trivialCode (CMP ULT) y x AddrGeOp -> trivialCode (CMP ULE) y x - AddrEqOp -> trivialCode (CMP EQ) x y + AddrEqOp -> trivialCode (CMP EQQ) x y AddrNeOp -> int_NE_code x y AddrLtOp -> trivialCode (CMP ULT) x y AddrLeOp -> trivialCode (CMP ULE) x y - - FloatGtOp -> cmpF_code (FCMP TF LE) EQ x y - FloatGeOp -> cmpF_code (FCMP TF LT) EQ x y - FloatEqOp -> cmpF_code (FCMP TF EQ) NE x y - FloatNeOp -> cmpF_code (FCMP TF EQ) EQ x y - FloatLtOp -> cmpF_code (FCMP TF LT) NE 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 + FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y + FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y FloatLeOp -> cmpF_code (FCMP TF LE) NE x y - DoubleGtOp -> cmpF_code (FCMP TF LE) EQ x y - DoubleGeOp -> cmpF_code (FCMP TF LT) EQ x y - DoubleEqOp -> cmpF_code (FCMP TF EQ) NE x y - DoubleNeOp -> cmpF_code (FCMP TF EQ) EQ x y - DoubleLtOp -> cmpF_code (FCMP TF LT) NE x y + DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y + DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y + DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y + DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y + DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y IntAddOp -> trivialCode (ADD Q False) x y @@ -382,6 +678,12 @@ 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 + FloatAddOp -> trivialFCode FloatRep (FADD TF) x y FloatSubOp -> trivialFCode FloatRep (FSUB TF) x y FloatMulOp -> trivialFCode FloatRep (FMUL TF) x y @@ -392,18 +694,22 @@ 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 SllOp -> trivialCode SLL x y - SraOp -> trivialCode SRA x y SrlOp -> trivialCode SRL x y - ISllOp -> panic "AlphaGen:isll" - ISraOp -> panic "AlphaGen:isra" - ISrlOp -> panic "AlphaGen:isrl" + ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll" + ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra" + ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl" - FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x,y]) - DoublePowerOp -> getRegister (StCall SLIT("pow") 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 @@ -413,17 +719,17 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps any kind leave the result in a floating point register, so we need to wrangle an integer register out of things. -} - int_NE_code :: StixTree -> StixTree -> UniqSM Register + int_NE_code :: StixTree -> StixTree -> NatM Register int_NE_code x y - = trivialCode (CMP EQ) x y `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = trivialCode (CMP EQQ) x y `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) {- ------------------------------------------------------------ Comments for int_NE_code also apply to cmpF_code @@ -432,48 +738,48 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps :: (Reg -> Reg -> Reg -> Instr) -> Cond -> StixTree -> StixTree - -> UniqSM Register + -> NatM Register cmpF_code instr cond x y - = trivialFCode pr instr x y `thenUs` \ register -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> - getUniqLabelNCG `thenUs` \ lbl -> + = trivialFCode pr instr x y `thenNat` \ register -> + getNewRegNCG DoubleRep `thenNat` \ tmp -> + getNatLabelNCG `thenNat` \ lbl -> let code = registerCode register tmp result = registerName register tmp code__2 dst = code . mkSeqInstrs [ - OR zero (RIImm (ImmInt 1)) dst, - BF cond result (ImmCLbl lbl), - OR zero (RIReg zero) dst, + OR zeroh (RIImm (ImmInt 1)) dst, + BF cond result (ImmCLbl lbl), + OR zeroh (RIReg zeroh) dst, LABEL lbl] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) where pr = panic "trivialU?FCode: does not use PrimRep on Alpha" ------------------------------------------------------------ getRegister (StInd pk mem) - = getAmode mem `thenUs` \ amode -> + = getAmode mem `thenNat` \ amode -> let code = amodeCode amode src = amodeAddr amode size = primRepToSize pk code__2 dst = code . mkSeqInstr (LD size dst src) in - returnUs (Any pk code__2) + returnNat (Any pk code__2) getRegister (StInt i) | fits8Bits i = let - code dst = mkSeqInstr (OR zero (RIImm src) dst) + code dst = mkSeqInstr (OR zeroh (RIImm src) dst) in - returnUs (Any IntRep code) + returnNat (Any IntRep code) | otherwise = let code dst = mkSeqInstr (LDI Q dst src) in - returnUs (Any IntRep code) + returnNat (Any IntRep code) where src = ImmInt (fromInteger i) @@ -482,562 +788,681 @@ getRegister leaf = let code dst = mkSeqInstr (LDA dst (AddrImm imm__2)) in - returnUs (Any PtrRep code) + returnNat (Any PtrRep code) where imm = maybeImm leaf imm__2 = case imm of Just x -> x #endif {- alpha_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#if i386_TARGET_ARCH -getRegister (StReg (StixTemp u pk)) = returnUs (Fixed pk (UnmappedReg u pk) id) +#if i386_TARGET_ARCH -getRegister (StDouble 0.0) - = let - code dst = mkSeqInstrs [FLDZ] +getRegister (StFloat f) + = getNatLabelNCG `thenNat` \ lbl -> + let code dst = toOL [ + SEGMENT DataSegment, + LABEL lbl, + DATA F [ImmFloat f], + SEGMENT TextSegment, + GLD F (ImmAddr (ImmCLbl lbl) 0) dst + ] in - returnUs (Any DoubleRep code) + returnNat (Any FloatRep code) -getRegister (StDouble 1.0) - = let - code dst = mkSeqInstrs [FLD1] - in - returnUs (Any DoubleRep code) getRegister (StDouble d) - = getUniqLabelNCG `thenUs` \ lbl -> - --getNewRegNCG PtrRep `thenUs` \ tmp -> - let code dst = mkSeqInstrs [ + + | d == 0.0 + = let code dst = unitOL (GLDZ dst) + in returnNat (Any DoubleRep code) + + | d == 1.0 + = let code dst = unitOL (GLD1 dst) + in returnNat (Any DoubleRep code) + + | otherwise + = getNatLabelNCG `thenNat` \ lbl -> + let code dst = toOL [ SEGMENT DataSegment, LABEL lbl, - DATA DF [dblImmLit d], + DATA DF [ImmDouble d], SEGMENT TextSegment, - FLD DF (OpImm (ImmCLbl lbl)) + GLD DF (ImmAddr (ImmCLbl lbl) 0) dst ] in - returnUs (Any DoubleRep code) + returnNat (Any DoubleRep code) -getRegister (StPrim primop [x]) -- unary PrimOps - = case primop of - IntNegOp -> trivialUCode (NEGI L) x - IntAbsOp -> absIntCode x - NotOp -> trivialUCode (NOT L) 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 - FloatNegOp -> trivialUFCode FloatRep FCHS x - FloatSqrtOp -> trivialUFCode FloatRep FSQRT x - DoubleNegOp -> trivialUFCode DoubleRep FCHS x + MO_Flt_Neg -> trivialUFCode FloatRep (GNEG F) x + MO_Dbl_Neg -> trivialUFCode DoubleRep (GNEG DF) x - DoubleSqrtOp -> trivialUFCode DoubleRep FSQRT x + MO_Flt_Sqrt -> trivialUFCode FloatRep (GSQRT F) x + MO_Dbl_Sqrt -> trivialUFCode DoubleRep (GSQRT DF) x - OrdOp -> coerceIntCode IntRep x - ChrOp -> chrCode x + MO_Flt_Sin -> trivialUFCode FloatRep (GSIN F) x + MO_Dbl_Sin -> trivialUFCode DoubleRep (GSIN DF) x - Float2IntOp -> coerceFP2Int x - Int2FloatOp -> coerceInt2FP FloatRep x - Double2IntOp -> coerceFP2Int x - Int2DoubleOp -> coerceInt2FP DoubleRep x + MO_Flt_Cos -> trivialUFCode FloatRep (GCOS F) x + MO_Dbl_Cos -> trivialUFCode DoubleRep (GCOS DF) x - Double2FloatOp -> coerceFltCode x - Float2DoubleOp -> coerceFltCode x + MO_Flt_Tan -> trivialUFCode FloatRep (GTAN F) x + MO_Dbl_Tan -> trivialUFCode DoubleRep (GTAN DF) x - other_op -> - let - fixed_x = if is_float_op -- promote to double - then StPrim Float2DoubleOp [x] - else x - in - getRegister (StCall fn DoubleRep [x]) - where - (is_float_op, fn) - = case primop of - FloatExpOp -> (True, SLIT("exp")) - FloatLogOp -> (True, SLIT("log")) + 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 - FloatSinOp -> (True, SLIT("sin")) - FloatCosOp -> (True, SLIT("cos")) - FloatTanOp -> (True, SLIT("tan")) + -- Conversions which are a nop on x86 + MO_NatS_to_32U -> conversionNop WordRep x + MO_32U_to_NatS -> conversionNop IntRep x - FloatAsinOp -> (True, SLIT("asin")) - FloatAcosOp -> (True, SLIT("acos")) - FloatAtanOp -> (True, 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 - FloatSinhOp -> (True, SLIT("sinh")) - FloatCoshOp -> (True, SLIT("cosh")) - FloatTanhOp -> (True, SLIT("tanh")) + MO_Dbl_to_Flt -> conversionNop FloatRep x + MO_Flt_to_Dbl -> conversionNop DoubleRep x - DoubleExpOp -> (False, SLIT("exp")) - DoubleLogOp -> (False, SLIT("log")) + -- 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 - DoubleSinOp -> (False, SLIT("sin")) - DoubleCosOp -> (False, SLIT("cos")) - DoubleTanOp -> (False, SLIT("tan")) + 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.) + -} + 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] - DoubleAsinOp -> (False, SLIT("asin")) - DoubleAcosOp -> (False, SLIT("acos")) - DoubleAtanOp -> (False, SLIT("atan")) + -------------------- + 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) - DoubleSinhOp -> (False, SLIT("sinh")) - DoubleCoshOp -> (False, SLIT("cosh")) - DoubleTanhOp -> (False, SLIT("tanh")) + -------------------- + shift_code :: (Imm -> Operand -> Instr) + -> StixExpr + -> StixExpr + -> NatM Register + + {- Case1: shift length as immediate -} + -- Code is the same as the first eq. for trivialCode -- sigh. + shift_code instr x y{-amount-} + | maybeToBool imm + = getRegister x `thenNat` \ regx -> + let mkcode dst + = if isAny regx + then registerCodeA regx dst `bind` \ code_x -> + code_x `snocOL` + instr imm__2 (OpReg dst) + else registerCodeF regx `bind` \ code_x -> + registerNameF regx `bind` \ r_x -> + code_x `snocOL` + MOV L (OpReg r_x) (OpReg dst) `snocOL` + instr imm__2 (OpReg dst) + in + returnNat (Any IntRep mkcode) + where + imm = maybeImm y + imm__2 = case imm of Just x -> x + + {- Case2: shift length is complex (non-immediate) -} + -- Since ECX is always used as a spill temporary, we can't + -- use it here to do non-immediate shifts. No big deal -- + -- they are only very rare, and we can use an equivalent + -- test-and-jump sequence which doesn't use ECX. + -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE, + -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER + shift_code instr x y{-amount-} + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNatLabelNCG `thenNat` \ lbl_test3 -> + getNatLabelNCG `thenNat` \ lbl_test2 -> + getNatLabelNCG `thenNat` \ lbl_test1 -> + getNatLabelNCG `thenNat` \ lbl_test0 -> + getNatLabelNCG `thenNat` \ lbl_after -> + getNewRegNCG IntRep `thenNat` \ tmp -> + let code__2 dst + = let src_val = registerName register1 dst + code_val = registerCode register1 dst + src_amt = registerName register2 tmp + code_amt = registerCode register2 tmp + r_dst = OpReg dst + r_tmp = OpReg tmp + in + code_amt `snocOL` + MOV L (OpReg src_amt) r_tmp `appOL` + code_val `snocOL` + MOV L (OpReg src_val) r_dst `appOL` + toOL [ + COMMENT (mkFastString "begin shift sequence"), + MOV L (OpReg src_val) r_dst, + MOV L (OpReg src_amt) r_tmp, + + BT L (ImmInt 4) r_tmp, + JXX GEU lbl_test3, + instr (ImmInt 16) r_dst, + + LABEL lbl_test3, + BT L (ImmInt 3) r_tmp, + JXX GEU lbl_test2, + instr (ImmInt 8) r_dst, + + LABEL lbl_test2, + BT L (ImmInt 2) r_tmp, + JXX GEU lbl_test1, + instr (ImmInt 4) r_dst, + + LABEL lbl_test1, + BT L (ImmInt 1) r_tmp, + JXX GEU lbl_test0, + instr (ImmInt 2) r_dst, + + LABEL lbl_test0, + BT L (ImmInt 0) r_tmp, + JXX GEU lbl_after, + instr (ImmInt 1) r_dst, + LABEL lbl_after, + + COMMENT (mkFastString "end shift sequence") + ] + in + returnNat (Any IntRep code__2) -getRegister (StPrim primop [x, y]) -- dyadic PrimOps - = case primop of - CharGtOp -> condIntReg GT x y - CharGeOp -> condIntReg GE x y - CharEqOp -> condIntReg EQ x y - CharNeOp -> condIntReg NE x y - CharLtOp -> condIntReg LT x y - CharLeOp -> condIntReg LE x y - - IntGtOp -> condIntReg GT x y - IntGeOp -> condIntReg GE x y - IntEqOp -> condIntReg EQ x y - IntNeOp -> condIntReg NE x y - IntLtOp -> condIntReg LT x y - IntLeOp -> condIntReg LE x y - - WordGtOp -> condIntReg GU x y - WordGeOp -> condIntReg GEU x y - WordEqOp -> condIntReg EQ 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 EQ x y - AddrNeOp -> condIntReg NE x y - AddrLtOp -> condIntReg LU x y - AddrLeOp -> condIntReg LEU x y - - FloatGtOp -> condFltReg GT x y - FloatGeOp -> condFltReg GE x y - FloatEqOp -> condFltReg EQ x y - FloatNeOp -> condFltReg NE x y - FloatLtOp -> condFltReg LT x y - FloatLeOp -> condFltReg LE x y - - DoubleGtOp -> condFltReg GT x y - DoubleGeOp -> condFltReg GE x y - DoubleEqOp -> condFltReg EQ x y - DoubleNeOp -> condFltReg NE x y - DoubleLtOp -> condFltReg LT x y - DoubleLeOp -> condFltReg LE x y - - IntAddOp -> {- ToDo: fix this, whatever it is (WDP 96/04)... - -- this should be optimised by the generic Opts, - -- I don't know why it is not (sometimes)! - case args of - [x, StInt 0] -> getRegister x - _ -> add_code L x y - -} - 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 -> trivialCode (IMUL L) x y {-True-} - - FloatAddOp -> trivialFCode FloatRep FADD FADD FADDP FADDP x y - FloatSubOp -> trivialFCode FloatRep FSUB FSUBR FSUBP FSUBRP x y - FloatMulOp -> trivialFCode FloatRep FMUL FMUL FMULP FMULP x y - FloatDivOp -> trivialFCode FloatRep FDIV FDIVR FDIVP FDIVRP x y - - DoubleAddOp -> trivialFCode DoubleRep FADD FADD FADDP FADDP x y - DoubleSubOp -> trivialFCode DoubleRep FSUB FSUBR FSUBP FSUBRP x y - DoubleMulOp -> trivialFCode DoubleRep FMUL FMUL FMULP FMULP x y - DoubleDivOp -> trivialFCode DoubleRep FDIV FDIVR FDIVP FDIVRP x y - - AndOp -> trivialCode (AND L) x y {-True-} - OrOp -> trivialCode (OR L) x y {-True-} - SllOp -> trivialCode (SHL L) x y {-False-} - SraOp -> trivialCode (SAR L) x y {-False-} - SrlOp -> trivialCode (SHR L) x y {-False-} - - ISllOp -> panic "I386Gen:isll" - ISraOp -> panic "I386Gen:isra" - ISrlOp -> panic "I386Gen:isrl" - - FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y]) - where promote x = StPrim Float2DoubleOp [x] - DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y]) - where - add_code :: Size -> StixTree -> StixTree -> UniqSM Register + -------------------- + add_code :: Size -> StixExpr -> StixExpr -> NatM Register add_code sz x (StInt y) - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src1 = registerName register tmp src2 = ImmInt (fromInteger y) - code__2 dst = code . - mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst)) + code__2 dst + = code `snocOL` + LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) + (OpReg dst) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) - add_code sz x (StInd _ mem) - = getRegister x `thenUs` \ register1 -> - --getNewRegNCG (registerRep register1) - -- `thenUs` \ tmp1 -> - getAmode mem `thenUs` \ amode -> - let - code2 = amodeCode amode - src2 = amodeAddr amode - - fixedname = registerName register1 eax - code__2 dst = let code1 = registerCode register1 dst - src1 = registerName register1 dst - in asmParThen [code2 asmVoid,code1 asmVoid] . - if isFixed register1 && src1 /= dst - then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst), - ADD sz (OpAddr src2) (OpReg dst)] - else - mkSeqInstrs [ADD sz (OpAddr src2) (OpReg src1)] - in - returnUs (Any IntRep code__2) - - add_code sz (StInd _ mem) y - = getRegister y `thenUs` \ register2 -> - --getNewRegNCG (registerRep register2) - -- `thenUs` \ tmp2 -> - getAmode mem `thenUs` \ amode -> - let - code1 = amodeCode amode - src1 = amodeAddr amode - - fixedname = registerName register2 eax - code__2 dst = let code2 = registerCode register2 dst - src2 = registerName register2 dst - in asmParThen [code1 asmVoid,code2 asmVoid] . - if isFixed register2 && src2 /= dst - then mkSeqInstrs [MOV L (OpReg src2) (OpReg dst), - ADD sz (OpAddr src1) (OpReg dst)] - else - mkSeqInstrs [ADD sz (OpAddr src1) (OpReg src2)] - in - returnUs (Any IntRep code__2) - - add_code sz x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> - let - code1 = registerCode register1 tmp1 asmVoid - src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid - src2 = registerName register2 tmp2 - code__2 dst = asmParThen [code1, code2] . - mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst)) - in - returnUs (Any IntRep code__2) + add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y -------------------- - sub_code :: Size -> StixTree -> StixTree -> UniqSM Register + sub_code :: Size -> StixExpr -> StixExpr -> NatM Register sub_code sz x (StInt y) - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src1 = registerName register tmp src2 = ImmInt (-(fromInteger y)) - code__2 dst = code . - mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst)) + code__2 dst + = code `snocOL` + LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) + (OpReg dst) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) - sub_code sz x y = trivialCode (SUB sz) x y {-False-} - - -------------------- - quot_code - :: Size - -> StixTree -> StixTree - -> Bool -- True => division, False => remainder operation - -> UniqSM 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 chose to - -- put y in memory (if it is not there already) - - quot_code sz x (StInd pk mem) is_division - = getRegister x `thenUs` \ register1 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - getAmode mem `thenUs` \ amode -> - let - code1 = registerCode register1 tmp1 asmVoid - src1 = registerName register1 tmp1 - code2 = amodeCode amode asmVoid - src2 = amodeAddr amode - code__2 = asmParThen [code1, code2] . - mkSeqInstrs [MOV L (OpReg src1) (OpReg eax), - CLTD, - IDIV sz (OpAddr src2)] - in - returnUs (Fixed IntRep (if is_division then eax else edx) code__2) - - quot_code sz x (StInt i) is_division - = getRegister x `thenUs` \ register1 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - let - code1 = registerCode register1 tmp1 asmVoid - src1 = registerName register1 tmp1 - src2 = ImmInt (fromInteger i) - code__2 = asmParThen [code1] . - mkSeqInstrs [-- we put src2 in (ebx) - MOV L (OpImm src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))), - MOV L (OpReg src1) (OpReg eax), - CLTD, - IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))] - in - returnUs (Fixed IntRep (if is_division then eax else edx) code__2) - - quot_code sz x y is_division - = getRegister x `thenUs` \ register1 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> - let - code1 = registerCode register1 tmp1 asmVoid - src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid - src2 = registerName register2 tmp2 - code__2 = asmParThen [code1, code2] . - if src2 == ecx || src2 == esi - then mkSeqInstrs [ MOV L (OpReg src1) (OpReg eax), - CLTD, - IDIV sz (OpReg src2)] - else mkSeqInstrs [ -- we put src2 in (ebx) - MOV L (OpReg src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))), - MOV L (OpReg src1) (OpReg eax), - CLTD, - IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))] - in - returnUs (Fixed IntRep (if is_division then eax else edx) code__2) - ----------------------- + sub_code sz x y = trivialCode (SUB sz) Nothing x y getRegister (StInd pk mem) - = getAmode mem `thenUs` \ amode -> + | not (is64BitRep pk) + = getAmode mem `thenNat` \ amode -> let code = amodeCode amode - src = amodeAddr amode + src = amodeAddr amode size = primRepToSize pk - code__2 dst = code . - if pk == DoubleRep || pk == FloatRep - then mkSeqInstr (FLD {-DF-} size (OpAddr src)) - else mkSeqInstr (MOV size (OpAddr src) (OpReg dst)) - in - returnUs (Any pk code__2) - + code__2 dst = code `snocOL` + if pk == DoubleRep || pk == FloatRep + then GLD size src 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) getRegister (StInt i) = let src = ImmInt (fromInteger i) - code dst = mkSeqInstr (MOV L (OpImm src) (OpReg dst)) + code dst + | i == 0 + = unitOL (XOR L (OpReg dst) (OpReg dst)) + | otherwise + = unitOL (MOV L (OpImm src) (OpReg dst)) in - returnUs (Any IntRep code) + returnNat (Any IntRep code) getRegister leaf | maybeToBool imm - = let - code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst)) + = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst)) in - returnUs (Any PtrRep code) + returnNat (Any PtrRep code) + | otherwise + = 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) + = getNatLabelNCG `thenNat` \ lbl -> + getNewRegNCG PtrRep `thenNat` \ tmp -> + let code dst = toOL [ + SEGMENT DataSegment, + LABEL lbl, + DATA F [ImmFloat d], + SEGMENT TextSegment, + SETHI (HI (ImmCLbl lbl)) tmp, + LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] + in + returnNat (Any FloatRep code) + getRegister (StDouble d) - = getUniqLabelNCG `thenUs` \ lbl -> - getNewRegNCG PtrRep `thenUs` \ tmp -> - let code dst = mkSeqInstrs [ + = getNatLabelNCG `thenNat` \ lbl -> + getNewRegNCG PtrRep `thenNat` \ tmp -> + let code dst = toOL [ SEGMENT DataSegment, LABEL lbl, - DATA DF [dblImmLit d], + DATA DF [ImmDouble d], SEGMENT TextSegment, SETHI (HI (ImmCLbl lbl)) tmp, LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] in - returnUs (Any DoubleRep code) - -getRegister (StPrim primop [x]) -- unary PrimOps - = case primop of - IntNegOp -> trivialUCode (SUB False False g0) x - IntAbsOp -> absIntCode x - - NotOp -> trivialUCode (XNOR False g0) x - - FloatNegOp -> trivialUFCode FloatRep (FNEG F) x - DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x + returnNat (Any DoubleRep code) - Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) x - Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x - OrdOp -> coerceIntCode IntRep x - ChrOp -> chrCode x - - Float2IntOp -> coerceFP2Int x - Int2FloatOp -> coerceInt2FP FloatRep x - Double2IntOp -> coerceFP2Int x - Int2DoubleOp -> coerceInt2FP DoubleRep x - - other_op -> - let - fixed_x = if is_float_op -- promote to double - then StPrim Float2DoubleOp [x] - else x - in - getRegister (StCall fn DoubleRep [x]) - where - (is_float_op, fn) - = case primop of - FloatExpOp -> (True, SLIT("exp")) - FloatLogOp -> (True, SLIT("log")) +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) - FloatSinOp -> (True, SLIT("sin")) - FloatCosOp -> (True, SLIT("cos")) - FloatTanOp -> (True, SLIT("tan")) + MO_Flt_Neg -> trivialUFCode FloatRep (FNEG F) x + MO_Dbl_Neg -> trivialUFCode DoubleRep (FNEG DF) x - FloatAsinOp -> (True, SLIT("asin")) - FloatAcosOp -> (True, SLIT("acos")) - FloatAtanOp -> (True, SLIT("atan")) + MO_Dbl_to_Flt -> coerceDbl2Flt x + MO_Flt_to_Dbl -> coerceFlt2Dbl 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 sparc + MO_32U_to_NatS -> conversionNop IntRep x + MO_NatS_to_32U -> conversionNop WordRep x - DoubleSinOp -> (False, SLIT("sin")) - DoubleCosOp -> (False, SLIT("cos")) - DoubleTanOp -> (False, SLIT("tan")) + 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 - DoubleAsinOp -> (False, SLIT("asin")) - DoubleAcosOp -> (False, SLIT("acos")) - DoubleAtanOp -> (False, SLIT("atan")) + -- 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 - DoubleSinhOp -> (False, SLIT("sinh")) - DoubleCoshOp -> (False, SLIT("cosh")) - DoubleTanhOp -> (False, SLIT("tanh")) + other_op -> + let fixed_x = if is_float_op -- promote to double + then StMachOp MO_Flt_to_Dbl [x] + else x + in + 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) -getRegister (StPrim primop [x, y]) -- dyadic PrimOps - = case primop of - CharGtOp -> condIntReg GT x y - CharGeOp -> condIntReg GE x y - CharEqOp -> condIntReg EQ x y - CharNeOp -> condIntReg NE x y - CharLtOp -> condIntReg LT x y - CharLeOp -> condIntReg LE x y - - IntGtOp -> condIntReg GT x y - IntGeOp -> condIntReg GE x y - IntEqOp -> condIntReg EQ x y - IntNeOp -> condIntReg NE x y - IntLtOp -> condIntReg LT x y - IntLeOp -> condIntReg LE x y - - WordGtOp -> condIntReg GU x y - WordGeOp -> condIntReg GEU x y - WordEqOp -> condIntReg EQ 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 EQ x y - AddrNeOp -> condIntReg NE x y - AddrLtOp -> condIntReg LU x y - AddrLeOp -> condIntReg LEU x y - - FloatGtOp -> condFltReg GT x y - FloatGeOp -> condFltReg GE x y - FloatEqOp -> condFltReg EQ x y - FloatNeOp -> condFltReg NE x y - FloatLtOp -> condFltReg LT x y - FloatLeOp -> condFltReg LE x y - - DoubleGtOp -> condFltReg GT x y - DoubleGeOp -> condFltReg GE x y - DoubleEqOp -> condFltReg EQ x y - DoubleNeOp -> condFltReg NE x y - DoubleLtOp -> condFltReg LT 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 - SllOp -> trivialCode SLL x y - SraOp -> trivialCode SRA x y - SrlOp -> trivialCode SRL x y - - ISllOp -> panic "SparcGen:isll" - ISraOp -> panic "SparcGen:isra" - ISrlOp -> panic "SparcGen:isrl" - - FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y]) - where promote x = StPrim Float2DoubleOp [x] - DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y]) + (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 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 `thenUs` \ amode -> + = getAmode mem `thenNat` \ amode -> let code = amodeCode amode src = amodeAddr amode size = primRepToSize pk - code__2 dst = code . mkSeqInstr (LD size src dst) + code__2 dst = code `snocOL` LD size src dst in - returnUs (Any pk code__2) + returnNat (Any pk code__2) getRegister (StInt i) | fits13Bits i = let src = ImmInt (fromInteger i) - code dst = mkSeqInstr (OR False g0 (RIImm src) dst) + code dst = unitOL (OR False g0 (RIImm src) dst) in - returnUs (Any IntRep code) + returnNat (Any IntRep code) getRegister leaf | maybeToBool imm = let - code dst = mkSeqInstrs [ + code dst = toOL [ SETHI (HI imm__2) dst, OR False dst (RIImm (LO imm__2)) dst] in - returnUs (Any PtrRep code) + returnNat (Any PtrRep code) + | otherwise + = ncgPrimopMoan "getRegister(sparc)" (pprStixExpr leaf) where imm = maybeImm leaf imm__2 = case imm of Just x -> x #endif {- sparc_TARGET_ARCH -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + \end{code} %************************************************************************ @@ -1048,7 +1473,7 @@ getRegister leaf @Amode@s: Memory addressing modes passed up the tree. \begin{code} -data Amode = Amode Addr InstrBlock +data Amode = Amode MachRegsAddr InstrBlock amodeAddr (Amode addr _) = addr amodeCode (Amode _ code) = code @@ -1057,180 +1482,199 @@ amodeCode (Amode _ code) = code Now, given a tree (the argument to an StInd) that references memory, produce a suitable addressing mode. +A Rule of the Game (tm) for Amodes: use of the addr bit must +immediately follow use of the code part, since the code part puts +values in registers which the addr then refers to. So you can't put +anything in between, lest it overwrite some of those registers. If +you need to do some other computation between the code part and use of +the addr bit, first store the effective address from the amode in a +temporary, then do the other computation, and then use the temporary: + + code + LEA amode, tmp + ... other computation ... + ... (tmp) ... + \begin{code} -getAmode :: StixTree -> UniqSM Amode +getAmode :: StixExpr -> NatM Amode getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree) +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if alpha_TARGET_ARCH getAmode (StPrim IntSubOp [x, StInt i]) - = getNewRegNCG PtrRep `thenUs` \ tmp -> - getRegister x `thenUs` \ register -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getRegister x `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp off = ImmInt (-(fromInteger i)) in - returnUs (Amode (AddrRegImm reg off) code) + returnNat (Amode (AddrRegImm reg off) code) getAmode (StPrim IntAddOp [x, StInt i]) - = getNewRegNCG PtrRep `thenUs` \ tmp -> - getRegister x `thenUs` \ register -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getRegister x `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp off = ImmInt (fromInteger i) in - returnUs (Amode (AddrRegImm reg off) code) + returnNat (Amode (AddrRegImm reg off) code) getAmode leaf | maybeToBool imm - = returnUs (Amode (AddrImm imm__2) id) + = returnNat (Amode (AddrImm imm__2) id) where imm = maybeImm leaf imm__2 = case imm of Just x -> x getAmode other - = getNewRegNCG PtrRep `thenUs` \ tmp -> - getRegister other `thenUs` \ register -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getRegister other `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp in - returnUs (Amode (AddrReg reg) code) + returnNat (Amode (AddrReg reg) code) #endif {- alpha_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if i386_TARGET_ARCH -getAmode (StPrim IntSubOp [x, StInt i]) - = getNewRegNCG PtrRep `thenUs` \ tmp -> - getRegister x `thenUs` \ register -> +-- 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 code = registerCode register tmp reg = registerName register tmp off = ImmInt (-(fromInteger i)) in - returnUs (Amode (Addr (Just reg) Nothing off) code) + returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code) -getAmode (StPrim IntAddOp [x, StInt i]) +getAmode (StMachOp MO_Nat_Add [x, StInt i]) | maybeToBool imm - = let - code = mkSeqInstrs [] - in - returnUs (Amode (ImmAddr imm__2 (fromInteger i)) code) + = 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]) - = getNewRegNCG PtrRep `thenUs` \ tmp -> - getRegister x `thenUs` \ register -> +getAmode (StMachOp MO_Nat_Add [x, StInt i]) + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getRegister x `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp off = ImmInt (fromInteger i) in - returnUs (Amode (Addr (Just reg) Nothing off) code) + returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code) -getAmode (StPrim IntAddOp [x, y]) - = getNewRegNCG PtrRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> - getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> +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 -> + getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 reg1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid + code2 = registerCode register2 tmp2 reg2 = registerName register2 tmp2 - code__2 = asmParThen [code1, code2] + code__2 = code1 `appOL` code2 + base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8 in - returnUs (Amode (Addr (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2) + returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0)) + code__2) getAmode leaf | maybeToBool imm - = let - code = mkSeqInstrs [] - in - returnUs (Amode (ImmAddr imm__2 0) code) + = returnNat (Amode (ImmAddr imm__2 0) nilOL) where imm = maybeImm leaf imm__2 = case imm of Just x -> x getAmode other - = getNewRegNCG PtrRep `thenUs` \ tmp -> - getRegister other `thenUs` \ register -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getRegister other `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp - off = Nothing in - returnUs (Amode (Addr (Just reg) Nothing (ImmInt 0)) code) + 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 `thenUs` \ tmp -> - getRegister x `thenUs` \ register -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getRegister x `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp off = ImmInt (-(fromInteger i)) in - returnUs (Amode (AddrRegImm reg off) code) + returnNat (Amode (AddrRegImm reg off) code) -getAmode (StPrim IntAddOp [x, StInt i]) +getAmode (StMachOp MO_Nat_Add [x, StInt i]) | fits13Bits i - = getNewRegNCG PtrRep `thenUs` \ tmp -> - getRegister x `thenUs` \ register -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getRegister x `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp off = ImmInt (fromInteger i) in - returnUs (Amode (AddrRegImm reg off) code) + returnNat (Amode (AddrRegImm reg off) code) -getAmode (StPrim IntAddOp [x, y]) - = getNewRegNCG PtrRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> - getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> +getAmode (StMachOp MO_Nat_Add [x, y]) + = getNewRegNCG PtrRep `thenNat` \ tmp1 -> + getNewRegNCG IntRep `thenNat` \ tmp2 -> + getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 reg1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid + code2 = registerCode register2 tmp2 reg2 = registerName register2 tmp2 - code__2 = asmParThen [code1, code2] + code__2 = code1 `appOL` code2 in - returnUs (Amode (AddrRegReg reg1 reg2) code__2) + returnNat (Amode (AddrRegReg reg1 reg2) code__2) getAmode leaf | maybeToBool imm - = getNewRegNCG PtrRep `thenUs` \ tmp -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> let - code = mkSeqInstr (SETHI (HI imm__2) tmp) + code = unitOL (SETHI (HI imm__2) tmp) in - returnUs (Amode (AddrRegImm tmp (LO imm__2)) code) + returnNat (Amode (AddrRegImm tmp (LO imm__2)) code) where imm = maybeImm leaf imm__2 = case imm of Just x -> x getAmode other - = getNewRegNCG PtrRep `thenUs` \ tmp -> - getRegister other `thenUs` \ register -> + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getRegister other `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp off = ImmInt 0 in - returnUs (Amode (AddrRegImm reg off) code) + returnNat (Amode (AddrRegImm reg off) code) #endif {- sparc_TARGET_ARCH -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \end{code} %************************************************************************ @@ -1243,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 -> UniqSM 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 GT x y - CharGeOp -> condIntCode GE x y - CharEqOp -> condIntCode EQ x y - CharNeOp -> condIntCode NE x y - CharLtOp -> condIntCode LT 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 GT x y - IntGeOp -> condIntCode GE x y - IntEqOp -> condIntCode EQ x y - IntNeOp -> condIntCode NE x y - IntLtOp -> condIntCode LT x y - IntLeOp -> condIntCode LE x y - - WordGtOp -> condIntCode GU x y - WordGeOp -> condIntCode GEU x y - WordEqOp -> condIntCode EQ 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 EQ x y - AddrNeOp -> condIntCode NE x y - AddrLtOp -> condIntCode LU x y - AddrLeOp -> condIntCode LEU x y - - FloatGtOp -> condFltCode GT x y - FloatGeOp -> condFltCode GE x y - FloatEqOp -> condFltCode EQ x y - FloatNeOp -> condFltCode NE x y - FloatLtOp -> condFltCode LT x y - FloatLeOp -> condFltCode LE x y - - DoubleGtOp -> condFltCode GT x y - DoubleGeOp -> condFltCode GE x y - DoubleEqOp -> condFltCode EQ x y - DoubleNeOp -> condFltCode NE x y - DoubleLtOp -> condFltCode LT 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} % ----------------- @@ -1314,7 +1759,7 @@ getCondCode (StPrim primop [x, y]) passed back up the tree. \begin{code} -condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> UniqSM CondCode +condIntCode, condFltCode :: Cond -> StixExpr -> StixExpr -> NatM CondCode #if alpha_TARGET_ARCH condIntCode = panic "MachCode.condIntCode: not on Alphas" @@ -1324,189 +1769,191 @@ condFltCode = panic "MachCode.condFltCode: not on Alphas" -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH -condIntCode cond (StInd _ x) y - | maybeToBool imm - = getAmode x `thenUs` \ amode -> +-- memory vs immediate +condIntCode cond (StInd pk x) y + | Just i <- maybeImm y + = getAmode x `thenNat` \ amode -> let - code1 = amodeCode amode asmVoid - y__2 = amodeAddr amode - code__2 = asmParThen [code1] . - mkSeqInstr (CMP L (OpImm imm__2) (OpAddr y__2)) + code1 = amodeCode amode + x__2 = amodeAddr amode + sz = primRepToSize pk + code__2 = code1 `snocOL` + CMP sz (OpImm i) (OpAddr x__2) in - returnUs (CondCode False cond code__2) - where - imm = maybeImm y - imm__2 = case imm of Just x -> x + returnNat (CondCode False cond code__2) +-- anything vs zero condIntCode cond x (StInt 0) - = getRegister x `thenUs` \ register1 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> + = getRegister x `thenNat` \ register1 -> + getNewRegNCG IntRep `thenNat` \ tmp1 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 - code__2 = asmParThen [code1] . - mkSeqInstr (TEST L (OpReg src1) (OpReg src1)) + code__2 = code1 `snocOL` + TEST L (OpReg src1) (OpReg src1) in - returnUs (CondCode False cond code__2) + returnNat (CondCode False cond code__2) +-- anything vs immediate condIntCode cond x y - | maybeToBool imm - = getRegister x `thenUs` \ register1 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> + | Just i <- maybeImm y + = getRegister x `thenNat` \ register1 -> + getNewRegNCG IntRep `thenNat` \ tmp1 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 - code__2 = asmParThen [code1] . - mkSeqInstr (CMP L (OpImm imm__2) (OpReg src1)) - in - returnUs (CondCode False cond code__2) - where - imm = maybeImm y - imm__2 = case imm of Just x -> x - -condIntCode cond (StInd _ x) y - = getAmode x `thenUs` \ amode -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> - let - code1 = amodeCode amode asmVoid - src1 = amodeAddr amode - code2 = registerCode register2 tmp2 asmVoid - src2 = registerName register2 tmp2 - code__2 = asmParThen [code1, code2] . - mkSeqInstr (CMP L (OpReg src2) (OpAddr src1)) - in - returnUs (CondCode False cond code__2) - -condIntCode cond y (StInd _ x) - = getAmode x `thenUs` \ amode -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> - let - code1 = amodeCode amode asmVoid - src1 = amodeAddr amode - code2 = registerCode register2 tmp2 asmVoid - src2 = registerName register2 tmp2 - code__2 = asmParThen [code1, code2] . - mkSeqInstr (CMP L (OpAddr src1) (OpReg src2)) - in - returnUs (CondCode False cond code__2) - + code__2 = code1 `snocOL` + CMP L (OpImm i) (OpReg src1) + in + returnNat (CondCode False cond code__2) + +-- memory vs anything +condIntCode cond (StInd pk x) y + = getAmode x `thenNat` \ amode_x -> + getRegister y `thenNat` \ reg_y -> + getNewRegNCG IntRep `thenNat` \ tmp -> + let + c_x = amodeCode amode_x + am_x = amodeAddr amode_x + c_y = registerCode reg_y tmp + r_y = registerName reg_y tmp + sz = primRepToSize pk + + -- optimisation: if there's no code for x, just an amode, + -- use whatever reg y winds up in. Assumes that c_y doesn't + -- clobber any regs in the amode am_x, which I'm not sure is + -- justified. The otherwise clause makes the same assumption. + code__2 | isNilOL c_x + = c_y `snocOL` + CMP sz (OpReg r_y) (OpAddr am_x) + + | otherwise + = c_y `snocOL` + MOV L (OpReg r_y) (OpReg tmp) `appOL` + c_x `snocOL` + CMP sz (OpReg tmp) (OpAddr am_x) + in + returnNat (CondCode False cond code__2) + +-- anything vs memory +-- +condIntCode cond y (StInd pk x) + = getAmode x `thenNat` \ amode_x -> + getRegister y `thenNat` \ reg_y -> + getNewRegNCG IntRep `thenNat` \ tmp -> + let + c_x = amodeCode amode_x + am_x = amodeAddr amode_x + c_y = registerCode reg_y tmp + r_y = registerName reg_y tmp + sz = primRepToSize pk + -- same optimisation and nagging doubts as previous clause + code__2 | isNilOL c_x + = c_y `snocOL` + CMP sz (OpAddr am_x) (OpReg r_y) + + | otherwise + = c_y `snocOL` + MOV L (OpReg r_y) (OpReg tmp) `appOL` + c_x `snocOL` + CMP sz (OpAddr am_x) (OpReg tmp) + in + returnNat (CondCode False cond code__2) + +-- anything vs anything condIntCode cond x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNewRegNCG IntRep `thenNat` \ tmp1 -> + getNewRegNCG IntRep `thenNat` \ tmp2 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid + code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 - code__2 = asmParThen [code1, code2] . - mkSeqInstr (CMP L (OpReg src2) (OpReg src1)) + code__2 = code1 `snocOL` + MOV L (OpReg src1) (OpReg tmp1) `appOL` + code2 `snocOL` + CMP L (OpReg src2) (OpReg tmp1) in - returnUs (CondCode False cond code__2) + returnNat (CondCode False cond code__2) ----------- - -condFltCode cond x (StDouble 0.0) - = getRegister x `thenUs` \ register1 -> - getNewRegNCG (registerRep register1) - `thenUs` \ tmp1 -> - let - pk1 = registerRep register1 - code1 = registerCode register1 tmp1 - src1 = registerName register1 tmp1 - - code__2 = asmParThen [code1 asmVoid] . - mkSeqInstrs [FTST, FSTP DF (OpReg st0), -- or FLDZ, FUCOMPP ? - FNSTSW, - --AND HB (OpImm (ImmInt 68)) (OpReg eax), - --XOR HB (OpImm (ImmInt 64)) (OpReg eax) - SAHF - ] - in - returnUs (CondCode True (fix_FP_cond cond) code__2) - condFltCode cond x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> + = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT])) + getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> getNewRegNCG (registerRep register1) - `thenUs` \ tmp1 -> + `thenNat` \ tmp1 -> getNewRegNCG (registerRep register2) - `thenUs` \ tmp2 -> + `thenNat` \ tmp2 -> + getNewRegNCG DoubleRep `thenNat` \ tmp -> let - pk1 = registerRep register1 code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 - code__2 = asmParThen [code2 asmVoid, code1 asmVoid] . - mkSeqInstrs [FUCOMPP, - FNSTSW, - --AND HB (OpImm (ImmInt 68)) (OpReg eax), - --XOR HB (OpImm (ImmInt 64)) (OpReg eax) - SAHF - ] - in - returnUs (CondCode True (fix_FP_cond cond) code__2) - -{- 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 GT = GU -fix_FP_cond LT = LU -fix_FP_cond LE = LEU -fix_FP_cond any = any + code__2 | isAny register1 + = code1 `appOL` -- result in tmp1 + code2 `snocOL` + GCMP cond tmp1 src2 + + | otherwise + = code1 `snocOL` + GMOV src1 tmp1 `appOL` + code2 `snocOL` + GCMP cond tmp1 src2 + in + -- 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) | fits13Bits y - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src1 = registerName register tmp src2 = ImmInt (fromInteger y) - code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0) + code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0 in - returnUs (CondCode False cond code__2) + returnNat (CondCode False cond code__2) condIntCode cond x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNewRegNCG IntRep `thenNat` \ tmp1 -> + getNewRegNCG IntRep `thenNat` \ tmp2 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid + code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 - code__2 = asmParThen [code1, code2] . - mkSeqInstr (SUB False True src1 (RIReg src2) g0) + code__2 = code1 `appOL` code2 `snocOL` + SUB False True src1 (RIReg src2) g0 in - returnUs (CondCode False cond code__2) + returnNat (CondCode False cond code__2) ----------- condFltCode cond x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> getNewRegNCG (registerRep register1) - `thenUs` \ tmp1 -> + `thenNat` \ tmp1 -> getNewRegNCG (registerRep register2) - `thenUs` \ tmp2 -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> + `thenNat` \ tmp2 -> + getNewRegNCG DoubleRep `thenNat` \ tmp -> let - promote x = asmInstr (FxTOy F DF x tmp) + promote x = FxTOy F DF x tmp pk1 = registerRep register1 code1 = registerCode register1 tmp1 @@ -1518,18 +1965,20 @@ condFltCode cond x y code__2 = if pk1 == pk2 then - asmParThen [code1 asmVoid, code2 asmVoid] . - mkSeqInstr (FCMP True (primRepToSize pk1) src1 src2) + code1 `appOL` code2 `snocOL` + FCMP True (primRepToSize pk1) src1 src2 else if pk1 == FloatRep then - asmParThen [code1 (promote src1), code2 asmVoid] . - mkSeqInstr (FCMP True DF tmp src2) + code1 `snocOL` promote src1 `appOL` code2 `snocOL` + FCMP True DF tmp src2 else - asmParThen [code1 asmVoid, code2 (promote src2)] . - mkSeqInstr (FCMP True DF src1 tmp) + code1 `appOL` code2 `snocOL` promote src2 `snocOL` + FCMP True DF src1 tmp in - returnUs (CondCode True cond code__2) + returnNat (CondCode True cond code__2) #endif {- sparc_TARGET_ARCH -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \end{code} %************************************************************************ @@ -1547,289 +1996,307 @@ 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 -> UniqSM 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 assignIntCode pk (StInd _ dst) src - = getNewRegNCG IntRep `thenUs` \ tmp -> - getAmode dst `thenUs` \ amode -> - getRegister src `thenUs` \ register -> + = getNewRegNCG IntRep `thenNat` \ tmp -> + getAmode dst `thenNat` \ amode -> + getRegister src `thenNat` \ register -> let - code1 = amodeCode amode asmVoid + code1 = amodeCode amode [] dst__2 = amodeAddr amode - code2 = registerCode register tmp asmVoid + code2 = registerCode register tmp [] src__2 = registerName register tmp sz = primRepToSize pk - code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) + code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) in - returnUs code__2 + returnNat code__2 assignIntCode pk dst src - = getRegister dst `thenUs` \ register1 -> - getRegister src `thenUs` \ register2 -> + = getRegister dst `thenNat` \ register1 -> + getRegister src `thenNat` \ register2 -> let - dst__2 = registerName register1 zero + dst__2 = registerName register1 zeroh code = registerCode register2 dst__2 src__2 = registerName register2 dst__2 code__2 = if isFixed register2 then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2) else code in - returnUs code__2 + returnNat code__2 #endif {- alpha_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if i386_TARGET_ARCH -assignIntCode pk (StInd _ dst) src - = getAmode dst `thenUs` \ amode -> - get_op_RI src `thenUs` \ (codesrc, opsrc, sz) -> - let - code1 = amodeCode amode asmVoid - dst__2 = amodeAddr amode - code__2 = asmParThen [code1, codesrc asmVoid] . - mkSeqInstr (MOV sz opsrc (OpAddr dst__2)) - in - returnUs code__2 +-- 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 + -- In general, if the address computation for dst may require + -- some insns preceding the addressing mode itself. So there's + -- no guarantee that the code for dst and the code for src won't + -- write the same register. This means either the address or + -- the value needs to be copied into a temporary. We detect the + -- common case where the amode has no code, and elide the copy. + codea = amodeCode amode + dst__a = amodeAddr amode + + code | isNilOL codea + = codesrc `snocOL` + MOV (primRepToSize pk) opsrc (OpAddr dst__a) + | otherwise + = codea `snocOL` + LEA L (OpAddr dst__a) (OpReg tmp) `appOL` + codesrc `snocOL` + MOV (primRepToSize pk) opsrc + (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0))) + in + returnNat code where get_op_RI - :: StixTree - -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size + :: StixExpr + -> NatM (InstrBlock,Operand) -- code, operator get_op_RI op - | maybeToBool imm - = returnUs (asmParThen [], OpImm imm_op, L) - 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 `thenUs` \ register -> + = getRegister op `thenNat` \ register -> getNewRegNCG (registerRep register) - `thenUs` \ tmp -> - let - code = registerCode register tmp + `thenNat` \ tmp -> + let code = registerCode register tmp reg = registerName register tmp - pk = registerRep register - sz = primRepToSize pk in - returnUs (code, OpReg reg, sz) - -assignIntCode pk dst (StInd _ src) - = getNewRegNCG IntRep `thenUs` \ tmp -> - getAmode src `thenUs` \ amode -> - getRegister dst `thenUs` \ register -> - let - code1 = amodeCode amode asmVoid - src__2 = amodeAddr amode - code2 = registerCode register tmp asmVoid - dst__2 = registerName register tmp - sz = primRepToSize pk - code__2 = asmParThen [code1, code2] . - mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2)) - in - returnUs code__2 - -assignIntCode pk dst src - = getRegister dst `thenUs` \ register1 -> - getRegister src `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp -> - let - dst__2 = registerName register1 tmp - code = registerCode register2 dst__2 - src__2 = registerName register2 dst__2 - code__2 = if isFixed register2 && dst__2 /= src__2 - then code . mkSeqInstr (MOV L (OpReg src__2) (OpReg dst__2)) - else code + returnNat (code, OpReg reg) + +-- Assign; dst is a reg, rhs is mem +assignReg_IntCode pk reg (StInd pks src) + = getNewRegNCG PtrRep `thenNat` \ tmp -> + getAmode src `thenNat` \ amode -> + getRegisterReg reg `thenNat` \ reg_dst -> + let + c_addr = amodeCode amode + am_addr = amodeAddr amode + r_dst = registerName reg_dst tmp + szs = primRepToSize pks + 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) + in + returnNat code + +-- dst is a reg, but src could be anything +assignReg_IntCode pk reg src + = getRegisterReg reg `thenNat` \ registerd -> + getRegister src `thenNat` \ registers -> + getNewRegNCG IntRep `thenNat` \ tmp -> + let + r_dst = registerName registerd tmp + r_src = registerName registers r_dst + c_src = registerCode registers r_dst + + code = c_src `snocOL` + MOV L (OpReg r_src) (OpReg r_dst) in - returnUs code__2 + returnNat code #endif {- i386_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if sparc_TARGET_ARCH -assignIntCode pk (StInd _ dst) src - = getNewRegNCG IntRep `thenUs` \ tmp -> - getAmode dst `thenUs` \ amode -> - getRegister src `thenUs` \ register -> +assignMem_IntCode pk addr src + = getNewRegNCG IntRep `thenNat` \ tmp -> + getAmode addr `thenNat` \ amode -> + getRegister src `thenNat` \ register -> let - code1 = amodeCode amode asmVoid + code1 = amodeCode amode dst__2 = amodeAddr amode - code2 = registerCode register tmp asmVoid + code2 = registerCode register tmp src__2 = registerName register tmp sz = primRepToSize pk - code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) + code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2 in - returnUs code__2 + returnNat code__2 -assignIntCode pk dst src - = getRegister dst `thenUs` \ register1 -> - getRegister src `thenUs` \ 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 src__2 = registerName register2 dst__2 code__2 = if isFixed register2 - then code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2) + then code `snocOL` OR False g0 (RIReg src__2) dst__2 else code in - returnUs code__2 + returnNat code__2 #endif {- sparc_TARGET_ARCH -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \end{code} % -------------------------------- Floating-point assignments: % -------------------------------- + \begin{code} +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if alpha_TARGET_ARCH assignFltCode pk (StInd _ dst) src - = getNewRegNCG pk `thenUs` \ tmp -> - getAmode dst `thenUs` \ amode -> - getRegister src `thenUs` \ register -> + = getNewRegNCG pk `thenNat` \ tmp -> + getAmode dst `thenNat` \ amode -> + getRegister src `thenNat` \ register -> let - code1 = amodeCode amode asmVoid + code1 = amodeCode amode [] dst__2 = amodeAddr amode - code2 = registerCode register tmp asmVoid + code2 = registerCode register tmp [] src__2 = registerName register tmp sz = primRepToSize pk - code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) - in - returnUs code__2 - -assignFltCode pk dst src - = getRegister dst `thenUs` \ register1 -> - getRegister src `thenUs` \ register2 -> - let - dst__2 = registerName register1 zero - code = registerCode register2 dst__2 - src__2 = registerName register2 dst__2 - code__2 = if isFixed register2 - then code . mkSeqInstr (FMOV src__2 dst__2) - else code - in - returnUs code__2 - -#endif {- alpha_TARGET_ARCH -} --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#if i386_TARGET_ARCH - -assignFltCode pk (StInd pk_dst dst) (StInd pk_src src) - = getNewRegNCG IntRep `thenUs` \ tmp -> - getAmode src `thenUs` \ amodesrc -> - getAmode dst `thenUs` \ amodedst -> - --getRegister src `thenUs` \ register -> - let - codesrc1 = amodeCode amodesrc asmVoid - addrsrc1 = amodeAddr amodesrc - codedst1 = amodeCode amodedst asmVoid - addrdst1 = amodeAddr amodedst - addrsrc2 = case (addrOffset addrsrc1 4) of Just x -> x - addrdst2 = case (addrOffset addrdst1 4) of Just x -> x - - code__2 = asmParThen [codesrc1, codedst1] . - mkSeqInstrs ([MOV L (OpAddr addrsrc1) (OpReg tmp), - MOV L (OpReg tmp) (OpAddr addrdst1)] - ++ - if pk == DoubleRep - then [MOV L (OpAddr addrsrc2) (OpReg tmp), - MOV L (OpReg tmp) (OpAddr addrdst2)] - else []) - in - returnUs code__2 - -assignFltCode pk (StInd _ dst) src - = --getNewRegNCG pk `thenUs` \ tmp -> - getAmode dst `thenUs` \ amode -> - getRegister src `thenUs` \ register -> - let - sz = primRepToSize pk - dst__2 = amodeAddr amode - - code1 = amodeCode amode asmVoid - code2 = registerCode register {-tmp-}st0 asmVoid - - --src__2= registerName register tmp - pk__2 = registerRep register - sz__2 = primRepToSize pk__2 - - code__2 = asmParThen [code1, code2] . - mkSeqInstr (FSTP sz (OpAddr dst__2)) + code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) in - returnUs code__2 + returnNat code__2 assignFltCode pk dst src - = getRegister dst `thenUs` \ register1 -> - getRegister src `thenUs` \ register2 -> - --getNewRegNCG (registerRep register2) - -- `thenUs` \ tmp -> + = getRegister dst `thenNat` \ register1 -> + getRegister src `thenNat` \ register2 -> let - sz = primRepToSize pk - dst__2 = registerName register1 st0 --tmp - + dst__2 = registerName register1 zeroh code = registerCode register2 dst__2 src__2 = registerName register2 dst__2 - - code__2 = code + code__2 = if isFixed register2 + then code . mkSeqInstr (FMOV src__2 dst__2) + else code in - returnUs code__2 + returnNat code__2 + +#endif {- alpha_TARGET_ARCH -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +#if i386_TARGET_ARCH + +-- 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 -> + getNewRegNCG PtrRep `thenNat` \ tmp_addr -> + let r_src = registerName reg_src tmp_src + c_src = registerCode reg_src tmp_src + r_addr = registerName reg_addr tmp_addr + c_addr = registerCode reg_addr tmp_addr + sz = primRepToSize pk + + code = c_src `appOL` + -- no need to preserve r_src across the addr computation, + -- since r_src must be a float reg + -- whilst r_addr is an int reg + c_addr `snocOL` + GST sz r_src + (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0)) + in + returnNat code + +-- 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 + r_src = registerName reg_src r_dst + c_src = registerCode reg_src r_dst + + code = if isFixed reg_src + then c_src `snocOL` GMOV r_src r_dst + else c_src + in + returnNat code + #endif {- i386_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if sparc_TARGET_ARCH -assignFltCode pk (StInd _ dst) src - = getNewRegNCG pk `thenUs` \ tmp -> - getAmode dst `thenUs` \ amode -> - getRegister src `thenUs` \ register -> +-- Floating point assignment to memory +assignMem_FltCode pk addr src + = getNewRegNCG pk `thenNat` \ tmp1 -> + getAmode addr `thenNat` \ amode -> + getRegister src `thenNat` \ register -> let sz = primRepToSize pk dst__2 = amodeAddr amode - code1 = amodeCode amode asmVoid - code2 = registerCode register tmp asmVoid + code1 = amodeCode amode + code2 = registerCode register tmp1 - src__2 = registerName register tmp + src__2 = registerName register tmp1 pk__2 = registerRep register sz__2 = primRepToSize pk__2 - code__2 = asmParThen [code1, code2] . - if pk == pk__2 then - mkSeqInstr (ST sz src__2 dst__2) - else - mkSeqInstrs [FxTOy sz__2 sz src__2 tmp, ST sz tmp dst__2] + code__2 = code1 `appOL` code2 `appOL` + if pk == pk__2 + then unitOL (ST sz src__2 dst__2) + else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2] in - returnUs code__2 + returnNat code__2 -assignFltCode pk dst src - = getRegister dst `thenUs` \ register1 -> - getRegister src `thenUs` \ register2 -> - getNewRegNCG (registerRep register2) - `thenUs` \ tmp -> +-- 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 + sz__2 = primRepToSize pk__2 + in + getNewRegNCG pk__2 `thenNat` \ tmp -> 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 - pk__2 = registerRep register2 - sz__2 = primRepToSize pk__2 - - code__2 = if pk /= pk__2 then - code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2) + code__2 = + if pk /= pk__2 then + code `snocOL` FxTOy sz__2 sz src__2 dst__2 else if isFixed register2 then - code . mkSeqInstr (FMOV sz src__2 dst__2) + code `snocOL` FMOV sz src__2 dst__2 else code in - returnUs code__2 + returnNat code__2 #endif {- sparc_TARGET_ARCH -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \end{code} %************************************************************************ @@ -1847,85 +2314,86 @@ branch instruction. Other CLabels are assumed to be far away. register allocator. \begin{code} -genJump :: StixTree{-the branch target-} -> UniqSM InstrBlock +genJump :: DestInfo -> StixExpr{-the branch target-} -> NatM InstrBlock + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if alpha_TARGET_ARCH genJump (StCLbl lbl) | isAsmTemp lbl = returnInstr (BR target) - | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zero (AddrReg pv) 0] + | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0] where target = ImmCLbl lbl genJump tree - = getRegister tree `thenUs` \ register -> - getNewRegNCG PtrRep `thenUs` \ tmp -> + = getRegister tree `thenNat` \ register -> + getNewRegNCG PtrRep `thenNat` \ tmp -> let dst = registerName register pv code = registerCode register pv target = registerName register pv in if isFixed register then - returnSeq code [OR dst (RIReg dst) pv, JMP zero (AddrReg pv) 0] + returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0] else - returnUs (code . mkSeqInstr (JMP zero (AddrReg pv) 0)) + returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0)) #endif {- alpha_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#if i386_TARGET_ARCH -{- -genJump (StCLbl lbl) - | isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl] - | otherwise = returnInstrs [JMP (OpImm target)] - where - target = ImmCLbl lbl --} +#if i386_TARGET_ARCH -genJump (StInd pk mem) - = getAmode mem `thenUs` \ amode -> +genJump dsts (StInd pk mem) + = getAmode mem `thenNat` \ amode -> let code = amodeCode amode target = amodeAddr amode in - returnSeq code [JMP (OpAddr target)] + returnNat (code `snocOL` JMP dsts (OpAddr target)) -genJump tree +genJump dsts tree | maybeToBool imm - = returnInstr (JMP (OpImm target)) + = returnNat (unitOL (JMP dsts (OpImm target))) | otherwise - = getRegister tree `thenUs` \ register -> - getNewRegNCG PtrRep `thenUs` \ tmp -> + = getRegister tree `thenNat` \ register -> + getNewRegNCG PtrRep `thenNat` \ tmp -> let code = registerCode register tmp target = registerName register tmp in - returnSeq code [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 = returnInstrs [BI ALWAYS False target, NOP] - | otherwise = returnInstrs [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 - = getRegister tree `thenUs` \ register -> - getNewRegNCG PtrRep `thenUs` \ tmp -> +genJump dsts tree + = getRegister tree `thenNat` \ register -> + getNewRegNCG PtrRep `thenNat` \ tmp -> let code = registerCode register tmp target = registerName register tmp in - returnSeq code [JMP (AddrRegReg target g0), NOP] + returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP) #endif {- sparc_TARGET_ARCH -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \end{code} %************************************************************************ @@ -1956,15 +2424,17 @@ allocator. \begin{code} genCondJump :: CLabel -- the branch target - -> StixTree -- the condition on which to branch - -> UniqSM InstrBlock + -> StixExpr -- the condition on which to branch + -> NatM InstrBlock + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if alpha_TARGET_ARCH genCondJump lbl (StPrim op [x, StInt 0]) - = getRegister x `thenUs` \ register -> + = getRegister x `thenNat` \ register -> getNewRegNCG (registerRep register) - `thenUs` \ tmp -> + `thenNat` \ tmp -> let code = registerCode register tmp value = registerName register tmp @@ -1973,66 +2443,66 @@ genCondJump lbl (StPrim op [x, StInt 0]) in returnSeq code [BI (cmpOp op) value target] where - cmpOp CharGtOp = GT + cmpOp CharGtOp = GTT cmpOp CharGeOp = GE - cmpOp CharEqOp = EQ + cmpOp CharEqOp = EQQ cmpOp CharNeOp = NE - cmpOp CharLtOp = LT + cmpOp CharLtOp = LTT cmpOp CharLeOp = LE - cmpOp IntGtOp = GT + cmpOp IntGtOp = GTT cmpOp IntGeOp = GE - cmpOp IntEqOp = EQ + cmpOp IntEqOp = EQQ cmpOp IntNeOp = NE - cmpOp IntLtOp = LT + cmpOp IntLtOp = LTT cmpOp IntLeOp = LE cmpOp WordGtOp = NE cmpOp WordGeOp = ALWAYS - cmpOp WordEqOp = EQ + cmpOp WordEqOp = EQQ cmpOp WordNeOp = NE cmpOp WordLtOp = NEVER - cmpOp WordLeOp = EQ + cmpOp WordLeOp = EQQ cmpOp AddrGtOp = NE cmpOp AddrGeOp = ALWAYS - cmpOp AddrEqOp = EQ + cmpOp AddrEqOp = EQQ cmpOp AddrNeOp = NE cmpOp AddrLtOp = NEVER - cmpOp AddrLeOp = EQ + cmpOp AddrLeOp = EQQ genCondJump lbl (StPrim op [x, StDouble 0.0]) - = getRegister x `thenUs` \ register -> + = getRegister x `thenNat` \ register -> getNewRegNCG (registerRep register) - `thenUs` \ tmp -> + `thenNat` \ tmp -> let code = registerCode register tmp value = registerName register tmp pk = registerRep register target = ImmCLbl lbl in - returnUs (code . mkSeqInstr (BF (cmpOp op) value target)) + returnNat (code . mkSeqInstr (BF (cmpOp op) value target)) where - cmpOp FloatGtOp = GT + cmpOp FloatGtOp = GTT cmpOp FloatGeOp = GE - cmpOp FloatEqOp = EQ + cmpOp FloatEqOp = EQQ cmpOp FloatNeOp = NE - cmpOp FloatLtOp = LT + cmpOp FloatLtOp = LTT cmpOp FloatLeOp = LE - cmpOp DoubleGtOp = GT + cmpOp DoubleGtOp = GTT cmpOp DoubleGeOp = GE - cmpOp DoubleEqOp = EQ + cmpOp DoubleEqOp = EQQ cmpOp DoubleNeOp = NE - cmpOp DoubleLtOp = LT + cmpOp DoubleLtOp = LTT cmpOp DoubleLeOp = LE genCondJump lbl (StPrim op [x, y]) | fltCmpOp op - = trivialFCode pr instr x y `thenUs` \ register -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> + = trivialFCode pr instr x y `thenNat` \ register -> + getNewRegNCG DoubleRep `thenNat` \ tmp -> let code = registerCode register tmp result = registerName register tmp target = ImmCLbl lbl in - returnUs (code . mkSeqInstr (BF cond result target)) + returnNat (code . mkSeqInstr (BF cond result target)) where pr = panic "trivialU?FCode: does not use PrimRep on Alpha" @@ -2051,87 +2521,94 @@ genCondJump lbl (StPrim op [x, y]) DoubleLeOp -> True _ -> False (instr, cond) = case op of - FloatGtOp -> (FCMP TF LE, EQ) - FloatGeOp -> (FCMP TF LT, EQ) - FloatEqOp -> (FCMP TF EQ, NE) - FloatNeOp -> (FCMP TF EQ, EQ) - FloatLtOp -> (FCMP TF LT, NE) + FloatGtOp -> (FCMP TF LE, EQQ) + FloatGeOp -> (FCMP TF LTT, EQQ) + FloatEqOp -> (FCMP TF EQQ, NE) + FloatNeOp -> (FCMP TF EQQ, EQQ) + FloatLtOp -> (FCMP TF LTT, NE) FloatLeOp -> (FCMP TF LE, NE) - DoubleGtOp -> (FCMP TF LE, EQ) - DoubleGeOp -> (FCMP TF LT, EQ) - DoubleEqOp -> (FCMP TF EQ, NE) - DoubleNeOp -> (FCMP TF EQ, EQ) - DoubleLtOp -> (FCMP TF LT, NE) + DoubleGtOp -> (FCMP TF LE, EQQ) + DoubleGeOp -> (FCMP TF LTT, EQQ) + DoubleEqOp -> (FCMP TF EQQ, NE) + DoubleNeOp -> (FCMP TF EQQ, EQQ) + DoubleLtOp -> (FCMP TF LTT, NE) DoubleLeOp -> (FCMP TF LE, NE) genCondJump lbl (StPrim op [x, y]) - = trivialCode instr x y `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = trivialCode instr x y `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp result = registerName register tmp target = ImmCLbl lbl in - returnUs (code . mkSeqInstr (BI cond result target)) + returnNat (code . mkSeqInstr (BI cond result target)) where (instr, cond) = case op of - CharGtOp -> (CMP LE, EQ) - CharGeOp -> (CMP LT, EQ) - CharEqOp -> (CMP EQ, NE) - CharNeOp -> (CMP EQ, EQ) - CharLtOp -> (CMP LT, NE) + CharGtOp -> (CMP LE, EQQ) + CharGeOp -> (CMP LTT, EQQ) + CharEqOp -> (CMP EQQ, NE) + CharNeOp -> (CMP EQQ, EQQ) + CharLtOp -> (CMP LTT, NE) CharLeOp -> (CMP LE, NE) - IntGtOp -> (CMP LE, EQ) - IntGeOp -> (CMP LT, EQ) - IntEqOp -> (CMP EQ, NE) - IntNeOp -> (CMP EQ, EQ) - IntLtOp -> (CMP LT, NE) + IntGtOp -> (CMP LE, EQQ) + IntGeOp -> (CMP LTT, EQQ) + IntEqOp -> (CMP EQQ, NE) + IntNeOp -> (CMP EQQ, EQQ) + IntLtOp -> (CMP LTT, NE) IntLeOp -> (CMP LE, NE) - WordGtOp -> (CMP ULE, EQ) - WordGeOp -> (CMP ULT, EQ) - WordEqOp -> (CMP EQ, NE) - WordNeOp -> (CMP EQ, EQ) + WordGtOp -> (CMP ULE, EQQ) + WordGeOp -> (CMP ULT, EQQ) + WordEqOp -> (CMP EQQ, NE) + WordNeOp -> (CMP EQQ, EQQ) WordLtOp -> (CMP ULT, NE) WordLeOp -> (CMP ULE, NE) - AddrGtOp -> (CMP ULE, EQ) - AddrGeOp -> (CMP ULT, EQ) - AddrEqOp -> (CMP EQ, NE) - AddrNeOp -> (CMP EQ, EQ) + AddrGtOp -> (CMP ULE, EQQ) + AddrGeOp -> (CMP ULT, EQQ) + AddrEqOp -> (CMP EQQ, NE) + AddrNeOp -> (CMP EQQ, EQQ) AddrLtOp -> (CMP ULT, NE) AddrLeOp -> (CMP ULE, NE) #endif {- alpha_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if i386_TARGET_ARCH genCondJump lbl bool - = getCondCode bool `thenUs` \ condition -> + = getCondCode bool `thenNat` \ condition -> let code = condCode condition cond = condName condition - target = ImmCLbl lbl in - returnSeq code [JXX cond lbl] + returnNat (code `snocOL` JXX cond lbl) #endif {- i386_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if sparc_TARGET_ARCH genCondJump lbl bool - = getCondCode bool `thenUs` \ condition -> + = getCondCode bool `thenNat` \ condition -> let code = condCode condition cond = condName condition target = ImmCLbl lbl in - returnSeq code ( - if condFloat condition then - [NOP, BF cond False target, NOP] - else - [BI cond False target, NOP] + returnNat ( + code `appOL` + toOL ( + if condFloat condition + then [NOP, BF cond False target, NOP] + else [BI cond False target, NOP] + ) ) #endif {- sparc_TARGET_ARCH -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \end{code} %************************************************************************ @@ -2149,22 +2626,25 @@ register allocator. \begin{code} genCCall - :: FAST_STRING -- function to call + :: (Either FastString StixExpr) -- function to call + -> CCallConv -> PrimRep -- type of the result - -> [StixTree] -- arguments (of mixed type) - -> UniqSM InstrBlock + -> [StixExpr] -- arguments (of mixed type) + -> NatM InstrBlock + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if alpha_TARGET_ARCH -genCCall fn kind args - = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args - `thenUs` \ ((unused,_), argCode) -> +genCCall fn cconv kind args + = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args + `thenNat` \ ((unused,_), argCode) -> let nRegs = length allArgRegs - length unused - code = asmParThen (map ($ asmVoid) argCode) + code = asmSeqThen (map ($ []) argCode) in returnSeq code [ - LDA pv (AddrImm (ImmLab (uppPStr fn))), + LDA pv (AddrImm (ImmLab (ptext fn))), JSR ra (AddrReg pv) nRegs, LDGP gp (AddrReg ra)] where @@ -2178,24 +2658,24 @@ genCCall fn kind args 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 - @mapAccumLUs@. + @mapAccumLNat@. -} get_arg :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator) -> StixTree -- Current argument - -> UniqSM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code + -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code -- We have to use up all of our argument registers first... get_arg ((iDst,fDst):dsts, offset) arg - = getRegister arg `thenUs` \ register -> + = getRegister arg `thenNat` \ register -> let reg = if isFloatingRep pk then fDst else iDst code = registerCode register reg src = registerName register reg pk = registerRep register in - returnUs ( + returnNat ( if isFloatingRep pk then ((dsts, offset), if isFixed register then code . mkSeqInstr (FMOV src fDst) @@ -2209,181 +2689,273 @@ genCCall fn kind args -- stack... get_arg ([], offset) arg - = getRegister arg `thenUs` \ register -> + = getRegister arg `thenNat` \ register -> getNewRegNCG (registerRep register) - `thenUs` \ tmp -> + `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp pk = registerRep register sz = primRepToSize pk in - returnUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset))) + returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset))) #endif {- alpha_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if i386_TARGET_ARCH -genCCall fn kind [StInt i] - | fn == SLIT ("PerformGC_wrapper") - = getUniqLabelNCG `thenUs` \ lbl -> - let - call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax), - MOV L (OpImm (ImmCLbl lbl)) - -- this is hardwired - (OpAddr (Addr (Just ebx) Nothing (ImmInt 104))), - JMP (OpImm (ImmLit (uppPStr (SLIT ("_PerformGC_wrapper"))))), - LABEL lbl] - in - returnInstrs call +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 (push_code `appOL` call) -genCCall fn kind args - = mapUs get_call_arg args `thenUs` \ argCode -> - let - nargs = length args - code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))), - MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 100))) (OpReg esp) - ] - ] - code2 = asmParThen (map ($ asmVoid) (reverse argCode)) - call = [CALL fn__2 -- , - -- ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp), - -- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))) (OpReg esp) - ] - in - returnSeq (code1 . code2) 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 (uppPStr fn) - _ -> ImmLab (uppPStr 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)) - ------------ - get_call_arg :: StixTree{-current argument-} -> UniqSM InstrBlock -- code + stdcallsize tot_arg_size + | cconv == StdCallConv = '@':show tot_arg_size + | otherwise = "" - get_call_arg arg - = get_op arg `thenUs` \ (code, op, sz) -> - returnUs (code . mkSeqInstr (PUSH sz op)) + arg_size DF = 8 + arg_size F = 4 + arg_size _ = 4 ------------ - get_op - :: StixTree - -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size - - get_op (StInt i) - = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L) + push_arg :: StixExpr{-current argument-} + -> NatM (Int, InstrBlock) -- argsz, code + + 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` + toOL [SUB L (OpImm (ImmInt size)) (OpReg esp), + DELTA (delta-size), + GST sz reg (AddrBaseIndex (Just esp) + Nothing + (ImmInt 0))] + ) + else returnNat (size, + code `snocOL` + PUSH L (OpReg reg) `snocOL` + DELTA (delta-size) + ) + where + arg_rep = repOfStixExpr arg - get_op (StInd pk mem) - = getAmode mem `thenUs` \ amode -> - let - code = amodeCode amode --asmVoid - addr = amodeAddr amode - sz = primRepToSize pk - in - returnUs (code, OpAddr addr, sz) + ------------ + get_op + :: StixExpr + -> NatM (InstrBlock, Reg, Size) -- code, reg, size get_op op - = getRegister op `thenUs` \ register -> + = getRegister op `thenNat` \ register -> getNewRegNCG (registerRep register) - `thenUs` \ tmp -> + `thenNat` \ tmp -> let code = registerCode register tmp reg = registerName register tmp pk = registerRep register sz = primRepToSize pk in - returnUs (code, OpReg reg, sz) + 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 kind args - = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args - `thenUs` \ ((unused,_), argCode) -> - let - nRegs = length allArgRegs - length unused - call = CALL fn__2 nRegs False - code = asmParThen (map ($ asmVoid) argCode) - in - returnSeq code [call, NOP] +genCCall fn cconv kind args + = 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 + argcode = concatOL argcodes + (move_sp_down, move_sp_up) + = let nn = length vregs - n_argRegs + + 1 -- (for the road) + in if nn <= 0 + then (nilOL, nilOL) + 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 (uppPStr fn) - _ -> ImmLab (uppPStr 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@. - -} - get_arg - :: ([Reg],Int) -- Argument registers and stack offset (accumulator) - -> StixTree -- Current argument - -> UniqSM (([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 `thenUs` \ register -> - getNewRegNCG (registerRep register) - `thenUs` \ tmp -> - let - reg = if isFloatingRep pk then tmp else dst - code = registerCode register reg - src = registerName register reg - pk = registerRep register - in - returnUs (case pk of - DoubleRep -> - case dsts of - [] -> (([], offset + 1), code . mkSeqInstrs [ - -- conveniently put the second part in the right stack - -- location, and load the first part into %o5 - ST DF src (spRel (offset - 1)), - LD W (spRel (offset - 1)) dst]) - (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [ - ST DF src (spRel (-2)), - LD W (spRel (-2)) dst, - LD W (spRel (-1)) dst__2]) - FloatRep -> ((dsts, offset), code . mkSeqInstrs [ - ST F src (spRel (-2)), - LD W (spRel (-2)) dst]) - _ -> ((dsts, offset), if isFixed register then - code . mkSeqInstr (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 `thenUs` \ register -> - getNewRegNCG (registerRep register) - `thenUs` \ 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 - returnUs (([], offset + words), code . mkSeqInstr (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} %************************************************************************ @@ -2405,7 +2977,9 @@ the right hand side of an assignment). register allocator. \begin{code} -condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> UniqSM Register +condIntReg, condFltReg :: Cond -> StixExpr -> StixExpr -> NatM Register + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if alpha_TARGET_ARCH condIntReg = panic "MachCode.condIntReg (not on Alpha)" @@ -2413,33 +2987,30 @@ condFltReg = panic "MachCode.condFltReg (not on Alpha)" #endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if i386_TARGET_ARCH condIntReg cond x y - = condIntCode cond x y `thenUs` \ condition -> - getNewRegNCG IntRep `thenUs` \ tmp -> - --getRegister dst `thenUs` \ register -> + = condIntCode cond x y `thenNat` \ condition -> + getNewRegNCG IntRep `thenNat` \ tmp -> let - --code2 = registerCode register tmp asmVoid - --dst__2 = registerName register tmp code = condCode condition cond = condName condition - -- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move. - code__2 dst = code . mkSeqInstrs [ + code__2 dst = code `appOL` toOL [ SETCC cond (OpReg tmp), AND L (OpImm (ImmInt 1)) (OpReg tmp), MOV L (OpReg tmp) (OpReg dst)] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) condFltReg cond x y - = getUniqLabelNCG `thenUs` \ lbl1 -> - getUniqLabelNCG `thenUs` \ lbl2 -> - condFltCode cond x y `thenUs` \ condition -> + = getNatLabelNCG `thenNat` \ lbl1 -> + getNatLabelNCG `thenNat` \ lbl2 -> + condFltCode cond x y `thenNat` \ condition -> let code = condCode condition cond = condName condition - code__2 dst = code . mkSeqInstrs [ + code__2 dst = code `appOL` toOL [ JXX cond lbl1, MOV L (OpImm (ImmInt 0)) (OpReg dst), JXX ALWAYS lbl2, @@ -2447,78 +3018,80 @@ condFltReg cond x y MOV L (OpImm (ImmInt 1)) (OpReg dst), LABEL lbl2] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) #endif {- i386_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if sparc_TARGET_ARCH -condIntReg EQ x (StInt 0) - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> +condIntReg EQQ x (StInt 0) + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp - code__2 dst = code . mkSeqInstrs [ + code__2 dst = code `appOL` toOL [ SUB False True g0 (RIReg src) g0, SUB True False g0 (RIImm (ImmInt (-1))) dst] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) -condIntReg EQ x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> +condIntReg EQQ x y + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNewRegNCG IntRep `thenNat` \ tmp1 -> + getNewRegNCG IntRep `thenNat` \ tmp2 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid + code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 - code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [ + code__2 dst = code1 `appOL` code2 `appOL` toOL [ XOR False src1 (RIReg src2) dst, SUB False True g0 (RIReg dst) g0, SUB True False g0 (RIImm (ImmInt (-1))) dst] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) condIntReg NE x (StInt 0) - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp - code__2 dst = code . mkSeqInstrs [ + code__2 dst = code `appOL` toOL [ SUB False True g0 (RIReg src) g0, ADD True False g0 (RIImm (ImmInt 0)) dst] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) condIntReg NE x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNewRegNCG IntRep `thenNat` \ tmp1 -> + getNewRegNCG IntRep `thenNat` \ tmp2 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid + code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 - code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [ + code__2 dst = code1 `appOL` code2 `appOL` toOL [ XOR False src1 (RIReg src2) dst, SUB False True g0 (RIReg dst) g0, ADD True False g0 (RIImm (ImmInt 0)) dst] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) condIntReg cond x y - = getUniqLabelNCG `thenUs` \ lbl1 -> - getUniqLabelNCG `thenUs` \ lbl2 -> - condIntCode cond x y `thenUs` \ condition -> + = getNatLabelNCG `thenNat` \ lbl1 -> + getNatLabelNCG `thenNat` \ lbl2 -> + condIntCode cond x y `thenNat` \ condition -> let code = condCode condition cond = condName condition - code__2 dst = code . mkSeqInstrs [ + code__2 dst = code `appOL` toOL [ BI cond False (ImmCLbl lbl1), NOP, OR False g0 (RIImm (ImmInt 0)) dst, BI ALWAYS False (ImmCLbl lbl2), NOP, @@ -2526,16 +3099,16 @@ condIntReg cond x y OR False g0 (RIImm (ImmInt 1)) dst, LABEL lbl2] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) condFltReg cond x y - = getUniqLabelNCG `thenUs` \ lbl1 -> - getUniqLabelNCG `thenUs` \ lbl2 -> - condFltCode cond x y `thenUs` \ condition -> + = getNatLabelNCG `thenNat` \ lbl1 -> + getNatLabelNCG `thenNat` \ lbl2 -> + condFltCode cond x y `thenNat` \ condition -> let code = condCode condition cond = condName condition - code__2 dst = code . mkSeqInstrs [ + code__2 dst = code `appOL` toOL [ NOP, BF cond False (ImmCLbl lbl1), NOP, OR False g0 (RIImm (ImmInt 0)) dst, @@ -2544,9 +3117,11 @@ condFltReg cond x y OR False g0 (RIImm (ImmInt 1)) dst, LABEL lbl2] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) #endif {- sparc_TARGET_ARCH -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \end{code} %************************************************************************ @@ -2567,89 +3142,87 @@ have handled the constant-folding. \begin{code} trivialCode :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr) - ,IF_ARCH_i386 ((Operand -> Operand -> Instr) + ,IF_ARCH_i386 ((Operand -> Operand -> Instr) + -> Maybe (Operand -> Operand -> Instr) ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr) ,))) - -> StixTree -> StixTree -- the two arguments - -> UniqSM Register + -> StixExpr -> StixExpr -- the two arguments + -> NatM Register trivialFCode :: PrimRep -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr) ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr) - ,IF_ARCH_i386 ( - {-this bizarre type for i386 seems a little too weird (WDP 96/03)-} - (Size -> Operand -> Instr) - -> (Size -> Operand -> Instr) {-reversed instr-} - -> Instr {-pop-} - -> Instr {-reversed instr: pop-} + ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr) ,))) - -> StixTree -> StixTree -- the two arguments - -> UniqSM Register + -> StixExpr -> StixExpr -- the two arguments + -> NatM Register trivialUCode :: IF_ARCH_alpha((RI -> Reg -> Instr) ,IF_ARCH_i386 ((Operand -> Instr) ,IF_ARCH_sparc((RI -> Reg -> Instr) ,))) - -> StixTree -- the one argument - -> UniqSM Register + -> StixExpr -- the one argument + -> NatM Register trivialUFCode :: PrimRep -> IF_ARCH_alpha((Reg -> Reg -> Instr) - ,IF_ARCH_i386 (Instr + ,IF_ARCH_i386 ((Reg -> Reg -> Instr) ,IF_ARCH_sparc((Reg -> Reg -> Instr) ,))) - -> StixTree -- the one argument - -> UniqSM Register + -> StixExpr -- the one argument + -> NatM Register + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if alpha_TARGET_ARCH trivialCode instr x (StInt y) | fits8Bits y - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src1 = registerName register tmp src2 = ImmInt (fromInteger y) code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) trivialCode instr x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNewRegNCG IntRep `thenNat` \ tmp1 -> + getNewRegNCG IntRep `thenNat` \ tmp2 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 [] src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid + code2 = registerCode register2 tmp2 [] src2 = registerName register2 tmp2 - code__2 dst = asmParThen [code1, code2] . + code__2 dst = asmSeqThen [code1, code2] . mkSeqInstr (instr src1 (RIReg src2) dst) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) ------------ trivialUCode instr x - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp code__2 dst = code . mkSeqInstr (instr (RIReg src) dst) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) ------------ trivialFCode _ instr x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG DoubleRep `thenUs` \ tmp1 -> - getNewRegNCG DoubleRep `thenUs` \ tmp2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNewRegNCG DoubleRep `thenNat` \ tmp1 -> + getNewRegNCG DoubleRep `thenNat` \ tmp2 -> let code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 @@ -2657,263 +3230,246 @@ trivialFCode _ instr x y code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 - code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] . + code__2 dst = asmSeqThen [code1 [], code2 []] . mkSeqInstr (instr src1 src2 dst) in - returnUs (Any DoubleRep code__2) + returnNat (Any DoubleRep code__2) trivialUFCode _ instr x - = getRegister x `thenUs` \ register -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG DoubleRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp code__2 dst = code . mkSeqInstr (instr src dst) in - returnUs (Any DoubleRep code__2) + returnNat (Any DoubleRep code__2) #endif {- alpha_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if i386_TARGET_ARCH +\end{code} +The Rules of the Game are: -trivialCode instr x y - | maybeToBool imm - = getRegister x `thenUs` \ register1 -> - --getNewRegNCG IntRep `thenUs` \ tmp1 -> - let - fixedname = registerName register1 eax - code__2 dst = let code1 = registerCode register1 dst - src1 = registerName register1 dst - in code1 . - if isFixed register1 && src1 /= dst - then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst), - instr (OpImm imm__2) (OpReg dst)] - else - mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)] - in - returnUs (Any IntRep code__2) - where - imm = maybeImm y - imm__2 = case imm of Just x -> x +* You cannot assume anything about the destination register dst; + it may be anything, including a fixed reg. -trivialCode instr x y - | maybeToBool imm - = getRegister y `thenUs` \ register1 -> - --getNewRegNCG IntRep `thenUs` \ tmp1 -> - let - fixedname = registerName register1 eax - code__2 dst = let code1 = registerCode register1 dst - src1 = registerName register1 dst - in code1 . - if isFixed register1 && src1 /= dst - then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst), - instr (OpImm imm__2) (OpReg dst)] - else - mkSeqInstr (instr (OpImm imm__2) (OpReg src1)) - in - returnUs (Any IntRep code__2) - where - imm = maybeImm x - imm__2 = case imm of Just x -> x +* You may compute an operand into a fixed reg, but you may not + subsequently change the contents of that fixed reg. If you + want to do so, first copy the value either to a temporary + or into dst. You are free to modify dst even if it happens + to be a fixed reg -- that's not your problem. -trivialCode instr x (StInd pk mem) - = getRegister x `thenUs` \ register -> - --getNewRegNCG IntRep `thenUs` \ tmp -> - getAmode mem `thenUs` \ amode -> - let - fixedname = registerName register eax - code2 = amodeCode amode asmVoid - src2 = amodeAddr amode - code__2 dst = let code1 = registerCode register dst asmVoid - src1 = registerName register dst - in asmParThen [code1, code2] . - if isFixed register && src1 /= dst - then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst), - instr (OpAddr src2) (OpReg dst)] - else - mkSeqInstr (instr (OpAddr src2) (OpReg src1)) - in - returnUs (Any pk code__2) - -trivialCode instr (StInd pk mem) y - = getRegister y `thenUs` \ register -> - --getNewRegNCG IntRep `thenUs` \ tmp -> - getAmode mem `thenUs` \ amode -> - let - fixedname = registerName register eax - code2 = amodeCode amode asmVoid - src2 = amodeAddr amode - code__2 dst = let - code1 = registerCode register dst asmVoid - src1 = registerName register dst - in asmParThen [code1, code2] . - if isFixed register && src1 /= dst - then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst), - instr (OpAddr src2) (OpReg dst)] - else - mkSeqInstr (instr (OpAddr src2) (OpReg src1)) - in - returnUs (Any pk code__2) +* You cannot assume that a fixed reg will stay live over an + arbitrary computation. The same applies to the dst reg. + +* Temporary regs obtained from getNewRegNCG are distinct from + each other and from all other regs, and stay live over + arbitrary computations. + +\begin{code} + +trivialCode instr maybe_revinstr a b + + | is_imm_b + = getRegister a `thenNat` \ rega -> + let mkcode dst + = if isAny rega + then registerCode rega dst `bind` \ code_a -> + code_a `snocOL` + instr (OpImm imm_b) (OpReg dst) + else registerCodeF rega `bind` \ code_a -> + registerNameF rega `bind` \ r_a -> + code_a `snocOL` + MOV L (OpReg r_a) (OpReg dst) `snocOL` + instr (OpImm imm_b) (OpReg dst) + in + returnNat (Any IntRep mkcode) + + | is_imm_a + = getRegister b `thenNat` \ regb -> + getNewRegNCG IntRep `thenNat` \ tmp -> + let revinstr_avail = maybeToBool maybe_revinstr + revinstr = case maybe_revinstr of Just ri -> ri + mkcode dst + | revinstr_avail + = if isAny regb + then registerCode regb dst `bind` \ code_b -> + code_b `snocOL` + revinstr (OpImm imm_a) (OpReg dst) + else registerCodeF regb `bind` \ code_b -> + registerNameF regb `bind` \ r_b -> + code_b `snocOL` + MOV L (OpReg r_b) (OpReg dst) `snocOL` + revinstr (OpImm imm_a) (OpReg dst) + + | otherwise + = if isAny regb + then registerCode regb tmp `bind` \ code_b -> + code_b `snocOL` + MOV L (OpImm imm_a) (OpReg dst) `snocOL` + instr (OpReg tmp) (OpReg dst) + else registerCodeF regb `bind` \ code_b -> + registerNameF regb `bind` \ r_b -> + code_b `snocOL` + MOV L (OpReg r_b) (OpReg tmp) `snocOL` + MOV L (OpImm imm_a) (OpReg dst) `snocOL` + instr (OpReg tmp) (OpReg dst) + in + returnNat (Any IntRep mkcode) + + | otherwise + = getRegister a `thenNat` \ rega -> + getRegister b `thenNat` \ regb -> + getNewRegNCG IntRep `thenNat` \ tmp -> + let mkcode dst + = case (isAny rega, isAny regb) of + (True, True) + -> registerCode regb tmp `bind` \ code_b -> + registerCode rega dst `bind` \ code_a -> + code_b `appOL` + code_a `snocOL` + instr (OpReg tmp) (OpReg dst) + (True, False) + -> registerCode rega tmp `bind` \ code_a -> + registerCodeF regb `bind` \ code_b -> + registerNameF regb `bind` \ r_b -> + code_a `appOL` + code_b `snocOL` + instr (OpReg r_b) (OpReg tmp) `snocOL` + MOV L (OpReg tmp) (OpReg dst) + (False, True) + -> registerCode regb tmp `bind` \ code_b -> + registerCodeF rega `bind` \ code_a -> + registerNameF rega `bind` \ r_a -> + code_b `appOL` + code_a `snocOL` + MOV L (OpReg r_a) (OpReg dst) `snocOL` + instr (OpReg tmp) (OpReg dst) + (False, False) + -> registerCodeF rega `bind` \ code_a -> + registerNameF rega `bind` \ r_a -> + registerCodeF regb `bind` \ code_b -> + registerNameF regb `bind` \ r_b -> + code_a `snocOL` + MOV L (OpReg r_a) (OpReg tmp) `appOL` + code_b `snocOL` + instr (OpReg r_b) (OpReg tmp) `snocOL` + MOV L (OpReg tmp) (OpReg dst) + in + returnNat (Any IntRep mkcode) + + where + maybe_imm_a = maybeImm a + is_imm_a = maybeToBool maybe_imm_a + imm_a = case maybe_imm_a of Just imm -> imm + + maybe_imm_b = maybeImm b + is_imm_b = maybeToBool maybe_imm_b + imm_b = case maybe_imm_b of Just imm -> imm -trivialCode instr x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - --getNewRegNCG IntRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> - let - fixedname = registerName register1 eax - code2 = registerCode register2 tmp2 asmVoid - src2 = registerName register2 tmp2 - code__2 dst = let - code1 = registerCode register1 dst asmVoid - src1 = registerName register1 dst - in asmParThen [code1, code2] . - if isFixed register1 && src1 /= dst - then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst), - instr (OpReg src2) (OpReg dst)] - else - mkSeqInstr (instr (OpReg src2) (OpReg src1)) - in - returnUs (Any IntRep code__2) ----------- trivialUCode instr x - = getRegister x `thenUs` \ register -> --- getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> let --- fixedname = registerName register eax - code__2 dst = let - code = registerCode register dst + code__2 dst = let code = registerCode register dst src = registerName register dst - in code . if isFixed register && dst /= src - then mkSeqInstrs [MOV L (OpReg src) (OpReg dst), - instr (OpReg dst)] - else mkSeqInstr (instr (OpReg src)) + in code `appOL` + if isFixed register && dst /= src + then toOL [MOV L (OpReg src) (OpReg dst), + instr (OpReg dst)] + else unitOL (instr (OpReg src)) in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) ----------- -trivialFCode pk _ instrr _ _ (StInd pk' mem) y - = getRegister y `thenUs` \ register2 -> - --getNewRegNCG (registerRep register2) - -- `thenUs` \ tmp2 -> - getAmode mem `thenUs` \ amode -> - let - code1 = amodeCode amode - src1 = amodeAddr amode - - code__2 dst = let - code2 = registerCode register2 dst - src2 = registerName register2 dst - in asmParThen [code1 asmVoid,code2 asmVoid] . - mkSeqInstrs [instrr (primRepToSize pk) (OpAddr src1)] - in - returnUs (Any pk code__2) - -trivialFCode pk instr _ _ _ x (StInd pk' mem) - = getRegister x `thenUs` \ register1 -> - --getNewRegNCG (registerRep register1) - -- `thenUs` \ tmp1 -> - getAmode mem `thenUs` \ amode -> - let - code2 = amodeCode amode - src2 = amodeAddr amode - - code__2 dst = let - code1 = registerCode register1 dst - src1 = registerName register1 dst - in asmParThen [code2 asmVoid,code1 asmVoid] . - mkSeqInstrs [instr (primRepToSize pk) (OpAddr src2)] - in - returnUs (Any pk code__2) - -trivialFCode pk _ _ _ instrpr x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - --getNewRegNCG (registerRep register1) - -- `thenUs` \ tmp1 -> - --getNewRegNCG (registerRep register2) - -- `thenUs` \ tmp2 -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> +trivialFCode pk instr x y + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNewRegNCG DoubleRep `thenNat` \ tmp1 -> + getNewRegNCG DoubleRep `thenNat` \ tmp2 -> let - pk1 = registerRep register1 - code1 = registerCode register1 st0 --tmp1 - src1 = registerName register1 st0 --tmp1 + code1 = registerCode register1 tmp1 + src1 = registerName register1 tmp1 - pk2 = registerRep register2 + code2 = registerCode register2 tmp2 + src2 = registerName register2 tmp2 - code__2 dst = let - code2 = registerCode register2 dst - src2 = registerName register2 dst - in asmParThen [code1 asmVoid, code2 asmVoid] . - mkSeqInstr instrpr - in - returnUs (Any pk1 code__2) + code__2 dst + -- treat the common case specially: both operands in + -- non-fixed regs. + | isAny register1 && isAny register2 + = code1 `appOL` + code2 `snocOL` + instr (primRepToSize pk) src1 src2 dst -------------- -trivialUFCode pk instr (StInd pk' mem) - = getAmode mem `thenUs` \ amode -> - let - code = amodeCode amode - src = amodeAddr amode - code__2 dst = code . mkSeqInstrs [FLD (primRepToSize pk) (OpAddr src), - instr] + -- be paranoid (and inefficient) + | otherwise + = code1 `snocOL` GMOV src1 tmp1 `appOL` + code2 `snocOL` + instr (primRepToSize pk) tmp1 src2 dst in - returnUs (Any pk code__2) + returnNat (Any pk code__2) + +------------- trivialUFCode pk instr x - = getRegister x `thenUs` \ register -> - --getNewRegNCG pk `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG pk `thenNat` \ tmp -> let - code__2 dst = let - code = registerCode register dst - src = registerName register dst - in code . mkSeqInstrs [instr] + code = registerCode register tmp + src = registerName register tmp + code__2 dst = code `snocOL` instr src dst in - returnUs (Any pk code__2) + returnNat (Any pk code__2) #endif {- i386_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if sparc_TARGET_ARCH trivialCode instr x (StInt y) | fits13Bits y - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src1 = registerName register tmp src2 = ImmInt (fromInteger y) - code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst) + code__2 dst = code `snocOL` instr src1 (RIImm src2) dst in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) trivialCode instr x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> - getNewRegNCG IntRep `thenUs` \ tmp1 -> - getNewRegNCG IntRep `thenUs` \ tmp2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> + getNewRegNCG IntRep `thenNat` \ tmp1 -> + getNewRegNCG IntRep `thenNat` \ tmp2 -> let - code1 = registerCode register1 tmp1 asmVoid + code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 asmVoid + code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 - code__2 dst = asmParThen [code1, code2] . - mkSeqInstr (instr src1 (RIReg src2) dst) + code__2 dst = code1 `appOL` code2 `snocOL` + instr src1 (RIReg src2) dst in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) ------------ trivialFCode pk instr x y - = getRegister x `thenUs` \ register1 -> - getRegister y `thenUs` \ register2 -> + = getRegister x `thenNat` \ register1 -> + getRegister y `thenNat` \ register2 -> getNewRegNCG (registerRep register1) - `thenUs` \ tmp1 -> + `thenNat` \ tmp1 -> getNewRegNCG (registerRep register2) - `thenUs` \ tmp2 -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> + `thenNat` \ tmp2 -> + getNewRegNCG DoubleRep `thenNat` \ tmp -> let - promote x = asmInstr (FxTOy F DF x tmp) + promote x = FxTOy F DF x tmp pk1 = registerRep register1 code1 = registerCode register1 tmp1 @@ -2925,40 +3481,42 @@ trivialFCode pk instr x y code__2 dst = if pk1 == pk2 then - asmParThen [code1 asmVoid, code2 asmVoid] . - mkSeqInstr (instr (primRepToSize pk) src1 src2 dst) + code1 `appOL` code2 `snocOL` + instr (primRepToSize pk) src1 src2 dst else if pk1 == FloatRep then - asmParThen [code1 (promote src1), code2 asmVoid] . - mkSeqInstr (instr DF tmp src2 dst) + code1 `snocOL` promote src1 `appOL` code2 `snocOL` + instr DF tmp src2 dst else - asmParThen [code1 asmVoid, code2 (promote src2)] . - mkSeqInstr (instr DF src1 tmp dst) + code1 `appOL` code2 `snocOL` promote src2 `snocOL` + instr DF src1 tmp dst in - returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2) + returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2) ------------ trivialUCode instr x - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp - code__2 dst = code . mkSeqInstr (instr (RIReg src) dst) + code__2 dst = code `snocOL` instr (RIReg src) dst in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) ------------- trivialUFCode pk instr x - = getRegister x `thenUs` \ register -> - getNewRegNCG pk `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG pk `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp - code__2 dst = code . mkSeqInstr (instr src dst) + code__2 dst = code `snocOL` instr src dst in - returnUs (Any pk code__2) + returnNat (Any pk code__2) #endif {- sparc_TARGET_ARCH -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \end{code} %************************************************************************ @@ -2967,45 +3525,31 @@ 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. +@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. + \begin{code} -coerceIntCode :: PrimRep -> StixTree -> UniqSM Register -coerceFltCode :: StixTree -> UniqSM Register - -coerceInt2FP :: PrimRep -> StixTree -> UniqSM Register -coerceFP2Int :: StixTree -> UniqSM Register - -coerceIntCode pk x - = getRegister x `thenUs` \ register -> - returnUs ( - case register of - Fixed _ reg code -> Fixed pk reg code - Any _ code -> Any pk code - ) +coerceInt2FP :: PrimRep -> StixExpr -> NatM Register +coerceFP2Int :: PrimRep -> StixExpr -> NatM Register -------------- -coerceFltCode x - = getRegister x `thenUs` \ register -> - returnUs ( - 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 - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ reg -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ reg -> let code = registerCode register reg src = registerName register reg @@ -3015,12 +3559,12 @@ coerceInt2FP _ x LD TF dst (spRel 0), CVTxy Q TF dst dst] in - returnUs (Any DoubleRep code__2) + returnNat (Any DoubleRep code__2) ------------- coerceFP2Int x - = getRegister x `thenUs` \ register -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> + = getRegister x `thenNat` \ register -> + getNewRegNCG DoubleRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp @@ -3030,219 +3574,100 @@ coerceFP2Int x ST TF tmp (spRel 0), LD Q dst (spRel 0)] in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) #endif {- alpha_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #if i386_TARGET_ARCH coerceInt2FP pk x - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ reg -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ reg -> let code = registerCode register reg src = registerName register reg - - code__2 dst = code . mkSeqInstrs [ - -- to fix: should spill instead of using R1 - MOV L (OpReg src) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))), - FILD (primRepToSize pk) (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)) dst] + opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD + code__2 dst = code `snocOL` opc src dst in - returnUs (Any pk code__2) + returnNat (Any pk code__2) ------------ -coerceFP2Int x - = getRegister x `thenUs` \ register -> - getNewRegNCG DoubleRep `thenUs` \ tmp -> +coerceFP2Int fprep x + = getRegister x `thenNat` \ register -> + getNewRegNCG DoubleRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp pk = registerRep register - code__2 dst = let - in code . mkSeqInstrs [ - FRNDINT, - FIST L (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)), - MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)] + opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI + code__2 dst = code `snocOL` opc src dst in - returnUs (Any IntRep code__2) + 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 - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ reg -> + = getRegister x `thenNat` \ register -> + getNewRegNCG IntRep `thenNat` \ reg -> let code = registerCode register reg src = registerName register reg - code__2 dst = code . mkSeqInstrs [ + code__2 dst = code `appOL` toOL [ ST W src (spRel (-2)), LD W (spRel (-2)) dst, FxTOy W (primRepToSize pk) dst dst] in - returnUs (Any pk code__2) + returnNat (Any pk code__2) ------------ -coerceFP2Int x - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ reg -> - getNewRegNCG FloatRep `thenUs` \ tmp -> +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 . mkSeqInstrs [ - FxTOy (primRepToSize pk) W src tmp, + code__2 dst = code `appOL` toOL [ + FxTOy (primRepToSize fprep) W src tmp, ST W tmp (spRel (-2)), LD W (spRel (-2)) dst] in - returnUs (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 -> UniqSM Register - -#if alpha_TARGET_ARCH - -chrCode x - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ reg -> - let - code = registerCode register reg - src = registerName register reg - code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst) - in - returnUs (Any IntRep code__2) - -#endif {- alpha_TARGET_ARCH -} --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#if i386_TARGET_ARCH - -chrCode x - = getRegister x `thenUs` \ register -> - --getNewRegNCG IntRep `thenUs` \ reg -> - let - fixedname = registerName register eax - code__2 dst = let - code = registerCode register dst - src = registerName register dst - in code . - if isFixed register && src /= dst - then mkSeqInstrs [MOV L (OpReg src) (OpReg dst), - AND L (OpImm (ImmInt 255)) (OpReg dst)] - else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src)) - in - returnUs (Any IntRep code__2) + returnNat (Any IntRep code__2) -#endif {- i386_TARGET_ARCH -} --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#if sparc_TARGET_ARCH - -chrCode (StInd pk mem) - = getAmode mem `thenUs` \ 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 . mkSeqInstr (LD BU src__2 dst) - else - code . mkSeqInstrs [ - LD (primRepToSize pk) src dst, - AND False dst (RIImm (ImmInt 255)) dst] +------------ +coerceDbl2Flt x + = getRegister x `thenNat` \ register -> + getNewRegNCG DoubleRep `thenNat` \ tmp -> + let code = registerCode register tmp + src = registerName register tmp in - returnUs (Any pk code__2) + returnNat (Any FloatRep + (\dst -> code `snocOL` FxTOy DF F src dst)) -chrCode x - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ reg -> - let - code = registerCode register reg - src = registerName register reg - code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst) +------------ +coerceFlt2Dbl x + = getRegister x `thenNat` \ register -> + getNewRegNCG FloatRep `thenNat` \ tmp -> + let code = registerCode register tmp + src = registerName register tmp in - returnUs (Any IntRep code__2) + returnNat (Any DoubleRep + (\dst -> code `snocOL` FxTOy F DF src dst)) #endif {- sparc_TARGET_ARCH -} -\end{code} - -%************************************************************************ -%* * -\subsubsection{Absolute value on integers} -%* * -%************************************************************************ - -Absolute value on integers, mostly for gmp size check macros. Again, -the argument cannot be an StInt, because genericOpt already folded -constants. - -If applicable, do not fill the delay slots here; you will confuse the -register allocator. - -\begin{code} -absIntCode :: StixTree -> UniqSM Register - -#if alpha_TARGET_ARCH -absIntCode = panic "MachCode.absIntCode: not on Alphas" -#endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#if i386_TARGET_ARCH - -absIntCode x - = getRegister x `thenUs` \ register -> - --getNewRegNCG IntRep `thenUs` \ reg -> - getUniqLabelNCG `thenUs` \ lbl -> - let - code__2 dst = let code = registerCode register dst - src = registerName register dst - in code . if isFixed register && dst /= src - then mkSeqInstrs [MOV L (OpReg src) (OpReg dst), - TEST L (OpReg dst) (OpReg dst), - JXX GE lbl, - NEGI L (OpReg dst), - LABEL lbl] - else mkSeqInstrs [TEST L (OpReg src) (OpReg src), - JXX GE lbl, - NEGI L (OpReg src), - LABEL lbl] - in - returnUs (Any IntRep code__2) - -#endif {- i386_TARGET_ARCH -} --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#if sparc_TARGET_ARCH - -absIntCode x - = getRegister x `thenUs` \ register -> - getNewRegNCG IntRep `thenUs` \ reg -> - getUniqLabelNCG `thenUs` \ lbl -> - let - code = registerCode register reg - src = registerName register reg - code__2 dst = code . mkSeqInstrs [ - SUB False True g0 (RIReg src) dst, - BI GE False (ImmCLbl lbl), NOP, - OR False g0 (RIReg src) dst, - LABEL lbl] - in - returnUs (Any IntRep code__2) - -#endif {- sparc_TARGET_ARCH -} \end{code}