% % (c) The AQUA Project, Glasgow University, 1996-1998 % \section[MachCode]{Generating machine code} This is a big module, but, if you pay attention to (a) the sectioning, (b) the type signatures, and (c) the \tr{#if blah_TARGET_ARCH} things, the structure should not be too overwhelming. \begin{code} module MachCode ( stmtsToInstrs, InstrBlock ) where #include "HsVersions.h" #include "nativeGen/NCG.h" import MachMisc -- may differ per-platform import MachRegs import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL, snocOL, consOL, concatOL ) import AbsCUtils ( magicIdPrimRep ) import CallConv ( CallConv ) import CLabel ( isAsmTemp, CLabel, labelDynamic ) import Maybes ( maybeToBool, expectJust ) import PrimRep ( isFloatingRep, PrimRep(..) ) import PrimOp ( PrimOp(..) ) import CallConv ( cCallConv, stdCallConv ) import Stix ( getNatLabelNCG, StixTree(..), StixReg(..), CodeSegment(..), DestInfo, hasDestInfo, pprStixTree, NatM, thenNat, returnNat, mapNat, mapAndUnzipNat, mapAccumLNat, getDeltaNat, setDeltaNat ) import Outputable import CmdLineOpts ( opt_Static ) infixr 3 `bind` \end{code} @InstrBlock@s are the insn sequences generated by the insn selectors. They are really trees of insns to facilitate fast appending, where a left-to-right traversal (pre-order?) yields the insns in the correct order. \begin{code} type InstrBlock = OrdList Instr x `bind` f = f x \end{code} Code extractor for an entire stix tree---stix statement level. \begin{code} stmtsToInstrs :: [StixTree] -> NatM InstrBlock stmtsToInstrs stmts = liftStrings stmts [] [] `thenNat` \ lifted -> mapNat stmtToInstrs lifted `thenNat` \ instrss -> returnNat (concatOL instrss) -- Lift StStrings out of top-level StDatas, putting them at the end of -- the block, and replacing them with StCLbls which refer to the lifted-out strings. {- Motivation for this hackery provided by the following bug: Stix: (DataSegment) Bogon.ping_closure : (Data P_ Addr.A#_static_info) (Data StgAddr (Str `alalal')) (Data P_ (0)) results in: .data .align 8 .global Bogon_ping_closure Bogon_ping_closure: .long Addr_Azh_static_info .long .Ln1a8 .Ln1a8: .byte 0x61 .byte 0x6C .byte 0x61 .byte 0x6C .byte 0x61 .byte 0x6C .byte 0x00 .long 0 ie, the Str is planted in-line, when what we really meant was to place a _reference_ to the string there. liftStrings will lift out all such strings in top-level data and place them at the end of the block. This is still a rather half-baked solution -- to do the job entirely right would mean a complete traversal of all the Stixes, but there's currently no real need for it, and it would be slow. Also, potentially there could be literal types other than strings which need lifting out? -} liftStrings :: [StixTree] -- originals -> [StixTree] -- (reverse) originals with strings lifted out -> [(CLabel, FAST_STRING)] -- lifted strs, and their new labels -> NatM [StixTree] -- First, examine the original trees and lift out strings in top-level StDatas. liftStrings (st:sts) acc_stix acc_strs = case st of StData sz datas -> lift datas acc_strs `thenNat` \ (datas_done, acc_strs1) -> liftStrings sts ((StData sz datas_done):acc_stix) acc_strs1 other -> liftStrings sts (other:acc_stix) acc_strs where -- Handle a top-level StData lift [] acc_strs = returnNat ([], acc_strs) lift (d:ds) acc_strs = lift ds acc_strs `thenNat` \ (ds_done, acc_strs1) -> case d of StString s -> getNatLabelNCG `thenNat` \ lbl -> returnNat ((StCLbl lbl):ds_done, ((lbl,s):acc_strs1)) other -> returnNat (other:ds_done, acc_strs1) -- When we've run out of original trees, emit the lifted strings. liftStrings [] acc_stix acc_strs = returnNat (reverse acc_stix ++ concatMap f acc_strs) where f (lbl,str) = [StSegment RoDataSegment, StLabel lbl, StString str, StSegment TextSegment] stmtToInstrs :: StixTree {- a stix statement -} -> 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 StCall fn cconv VoidRep args -> genCCall fn cconv VoidRep (map derefDLL args) StAssign pk dst src | isFloatingRep pk -> assignFltCode pk (derefDLL dst) (derefDLL src) | otherwise -> assignIntCode pk (derefDLL dst) (derefDLL src) 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))) ,returnNat nilOL) StData kind args -> mapAndUnzipNat getData args `thenNat` \ (codes, imms) -> returnNat (DATA (primRepToSize kind) imms `consOL` concatOL codes) where getData :: StixTree -> 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 * sizeOf rep)) -- Top-level lifted-out string. The segment will already have been set -- (see liftStrings above). StString str -> returnNat (unitOL (ASCII True (_UNPK_ str))) -- Walk a Stix tree, and insert dereferences to CLabels which are marked -- as labelDynamic. stmt2Instrs calls derefDLL selectively, because -- not all such CLabel occurrences need this dereferencing -- SRTs don't -- for one. derefDLL :: StixTree -> StixTree derefDLL 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) StPrim pk args -> StPrim pk (map qq args) StInd pk addr -> StInd pk (qq addr) StCall who cc pk args -> StCall who cc pk (map qq args) StInt _ -> t StFloat _ -> t StDouble _ -> t StString _ -> t StReg _ -> t StScratchWord _ -> t _ -> pprPanic "derefDLL: unhandled case" (pprStixTree t) \end{code} %************************************************************************ %* * \subsection{General things for putting together code sequences} %* * %************************************************************************ \begin{code} mangleIndexTree :: StixTree -> StixTree mangleIndexTree (StIndex pk base (StInt i)) = StPrim IntAddOp [base, off] where off = StInt (i * toInteger (sizeOf pk)) mangleIndexTree (StIndex pk base off) = StPrim IntAddOp [ base, let s = shift pk in if s == 0 then off else StPrim SllOp [off, StInt (toInteger s)] ] where shift :: PrimRep -> Int shift rep = case sizeOf rep of 1 -> 0 2 -> 1 4 -> 2 8 -> 3 other -> pprPanic "MachCode.mangleIndexTree.shift: unhandled rep size" (int other) \end{code} \begin{code} maybeImm :: StixTree -> Maybe Imm maybeImm (StCLbl l) = Just (ImmCLbl l) maybeImm (StIndex rep (StCLbl l) (StInt off)) = Just (ImmIndex l (fromInteger off * sizeOf rep)) maybeImm (StInt i) | i >= toInteger minInt && i <= toInteger maxInt = Just (ImmInt (fromInteger i)) | otherwise = Just (ImmInteger i) maybeImm _ = Nothing \end{code} %************************************************************************ %* * \subsection{The @Register@ type} %* * %************************************************************************ @Register@s passed up the tree. If the stix code forces the register to live in a pre-decided machine register, it comes out as @Fixed@; otherwise, it comes out as @Any@, and the parent can decide which register to put it in. \begin{code} data Register = Fixed PrimRep Reg InstrBlock | Any PrimRep (Reg -> InstrBlock) registerCode :: Register -> Reg -> InstrBlock registerCode (Fixed _ _ code) reg = code registerCode (Any _ code) reg = code reg registerCodeF (Fixed _ _ code) = code registerCodeF (Any _ _) = pprPanic "registerCodeF" empty registerCodeA (Any _ code) = code registerCodeA (Fixed _ _ _) = pprPanic "registerCodeA" empty registerName :: Register -> Reg -> Reg registerName (Fixed _ reg _) _ = reg registerName (Any _ _) reg = reg registerNameF (Fixed _ reg _) = reg registerNameF (Any _ _) = pprPanic "registerNameF" empty registerRep :: Register -> PrimRep registerRep (Fixed pk _ _) = pk registerRep (Any pk _) = pk {-# 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 -> NatM Register getRegister (StReg (StixMagicId stgreg)) = case (magicIdRegMaybe stgreg) of Just reg -> returnNat (Fixed (magicIdPrimRep stgreg) reg nilOL) -- cannae be Nothing getRegister (StReg (StixTemp u pk)) = returnNat (Fixed pk (mkVReg u pk) nilOL) getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree) getRegister (StCall fn cconv kind args) = 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( fake0, IF_ARCH_sparc( f0,))) else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,))) getRegister (StString s) = getNatLabelNCG `thenNat` \ lbl -> let imm_lbl = ImmCLbl lbl code dst = toOL [ SEGMENT RoDataSegment, 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 returnNat (Any PtrRep code) -- end of machine-"independent" bit; here we go on the rest... #if alpha_TARGET_ARCH getRegister (StDouble d) = getNatLabelNCG `thenNat` \ lbl -> getNewRegNCG PtrRep `thenNat` \ tmp -> let code dst = mkSeqInstrs [ SEGMENT DataSegment, LABEL lbl, DATA TF [ImmLab (rational d)], SEGMENT TextSegment, LDA tmp (AddrImm (ImmCLbl lbl)), LD TF dst (AddrReg tmp)] in returnNat (Any DoubleRep code) getRegister (StPrim primop [x]) -- unary PrimOps = case primop of IntNegOp -> trivialUCode (NEG Q False) x NotOp -> trivialUCode NOT x FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x OrdOp -> coerceIntCode IntRep x ChrOp -> chrCode x Float2IntOp -> coerceFP2Int x Int2FloatOp -> coerceInt2FP pr x Double2IntOp -> coerceFP2Int x Int2DoubleOp -> coerceInt2FP pr x Double2FloatOp -> coerceFltCode x Float2DoubleOp -> coerceFltCode x 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") where pr = panic "MachCode.getRegister: no primrep needed for Alpha" getRegister (StPrim primop [x, y]) -- dyadic PrimOps = case primop of CharGtOp -> trivialCode (CMP LTT) y x CharGeOp -> trivialCode (CMP LE) y x CharEqOp -> trivialCode (CMP EQQ) x y CharNeOp -> int_NE_code x y CharLtOp -> trivialCode (CMP LTT) x y CharLeOp -> trivialCode (CMP LE) x y IntGtOp -> trivialCode (CMP LTT) y x IntGeOp -> trivialCode (CMP LE) y x IntEqOp -> trivialCode (CMP EQQ) x y IntNeOp -> int_NE_code 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 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 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) 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) 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 IntSubOp -> trivialCode (SUB Q False) x y IntMulOp -> trivialCode (MUL Q False) x y IntQuotOp -> trivialCode (DIV Q False) x y IntRemOp -> trivialCode (REM Q False) x y 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 FloatDivOp -> trivialFCode FloatRep (FDIV TF) x y DoubleAddOp -> trivialFCode DoubleRep (FADD TF) x y DoubleSubOp -> trivialFCode DoubleRep (FSUB TF) x y DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y AndOp -> trivialCode AND x y OrOp -> trivialCode OR x y XorOp -> trivialCode XOR x y SllOp -> trivialCode SLL x y SrlOp -> trivialCode SRL x y 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") cCallConv DoubleRep [x,y]) DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y]) where {- ------------------------------------------------------------ Some bizarre special code for getting condition codes into registers. Integer non-equality is a test for equality followed by an XOR with 1. (Integer comparisons always set the result register to 0 or 1.) Floating point comparisons of any kind leave the result in a floating point register, so we need to wrangle an integer register out of things. -} int_NE_code :: StixTree -> StixTree -> NatM Register int_NE_code x y = 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 returnNat (Any IntRep code__2) {- ------------------------------------------------------------ Comments for int_NE_code also apply to cmpF_code -} cmpF_code :: (Reg -> Reg -> Reg -> Instr) -> Cond -> StixTree -> StixTree -> NatM Register cmpF_code instr cond x y = 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 zeroh (RIImm (ImmInt 1)) dst, BF cond result (ImmCLbl lbl), OR zeroh (RIReg zeroh) dst, LABEL lbl] in returnNat (Any IntRep code__2) where pr = panic "trivialU?FCode: does not use PrimRep on Alpha" ------------------------------------------------------------ getRegister (StInd pk mem) = getAmode mem `thenNat` \ amode -> let code = amodeCode amode src = amodeAddr amode size = primRepToSize pk code__2 dst = code . mkSeqInstr (LD size dst src) in returnNat (Any pk code__2) getRegister (StInt i) | fits8Bits i = let code dst = mkSeqInstr (OR zeroh (RIImm src) dst) in returnNat (Any IntRep code) | otherwise = let code dst = mkSeqInstr (LDI Q dst src) in returnNat (Any IntRep code) where src = ImmInt (fromInteger i) getRegister leaf | maybeToBool imm = let code dst = mkSeqInstr (LDA dst (AddrImm imm__2)) in 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 (StFloat f) = getNatLabelNCG `thenNat` \ lbl -> let code dst = toOL [ SEGMENT DataSegment, LABEL lbl, DATA F [ImmFloat f], SEGMENT TextSegment, GLD F (ImmAddr (ImmCLbl lbl) 0) dst ] in returnNat (Any FloatRep code) getRegister (StDouble d) | 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 [ImmDouble d], SEGMENT TextSegment, GLD DF (ImmAddr (ImmCLbl lbl) 0) dst ] in returnNat (Any DoubleRep code) -- Calculate the offset for (i+1) words above the _initial_ -- %esp value by first determining the current offset of it. getRegister (StScratchWord i) | i >= 0 && i < 6 = getDeltaNat `thenNat` \ current_stack_offset -> let j = i+1 - (current_stack_offset `div` 4) code dst = unitOL (LEA L (OpAddr (spRel j)) (OpReg dst)) in returnNat (Any PtrRep code) getRegister (StPrim primop [x]) -- unary PrimOps = case primop of IntNegOp -> trivialUCode (NEGI L) x NotOp -> trivialUCode (NOT L) x FloatNegOp -> trivialUFCode FloatRep (GNEG F) x DoubleNegOp -> trivialUFCode DoubleRep (GNEG DF) x FloatSqrtOp -> trivialUFCode FloatRep (GSQRT F) x DoubleSqrtOp -> trivialUFCode DoubleRep (GSQRT DF) x FloatSinOp -> trivialUFCode FloatRep (GSIN F) x DoubleSinOp -> trivialUFCode DoubleRep (GSIN DF) x FloatCosOp -> trivialUFCode FloatRep (GCOS F) x DoubleCosOp -> trivialUFCode DoubleRep (GCOS DF) x FloatTanOp -> trivialUFCode FloatRep (GTAN F) x DoubleTanOp -> trivialUFCode DoubleRep (GTAN DF) x Double2FloatOp -> trivialUFCode FloatRep GDTOF x Float2DoubleOp -> trivialUFCode DoubleRep GFTOD x OrdOp -> coerceIntCode IntRep x ChrOp -> chrCode x Float2IntOp -> coerceFP2Int x Int2FloatOp -> coerceInt2FP FloatRep x Double2IntOp -> coerceFP2Int x Int2DoubleOp -> coerceInt2FP DoubleRep x IntToInt8Op -> extendIntCode Int8Rep IntRep x IntToInt16Op -> extendIntCode Int16Rep IntRep x IntToInt32Op -> getRegister x WordToWord8Op -> extendIntCode Word8Rep WordRep x WordToWord16Op -> extendIntCode Word16Rep WordRep x WordToWord32Op -> getRegister x other_op -> getRegister (StCall fn cCallConv DoubleRep [x]) where (is_float_op, fn) = case primop of FloatExpOp -> (True, SLIT("exp")) FloatLogOp -> (True, SLIT("log")) FloatAsinOp -> (True, SLIT("asin")) FloatAcosOp -> (True, SLIT("acos")) FloatAtanOp -> (True, SLIT("atan")) FloatSinhOp -> (True, SLIT("sinh")) FloatCoshOp -> (True, SLIT("cosh")) FloatTanhOp -> (True, SLIT("tanh")) DoubleExpOp -> (False, SLIT("exp")) DoubleLogOp -> (False, SLIT("log")) DoubleAsinOp -> (False, SLIT("asin")) DoubleAcosOp -> (False, SLIT("acos")) DoubleAtanOp -> (False, SLIT("atan")) DoubleSinhOp -> (False, SLIT("sinh")) DoubleCoshOp -> (False, SLIT("cosh")) DoubleTanhOp -> (False, SLIT("tanh")) other -> pprPanic "getRegister(x86,unary primop)" (pprStixTree (StPrim primop [x])) getRegister (StPrim primop [x, y]) -- dyadic PrimOps = case primop of CharGtOp -> condIntReg GTT x y CharGeOp -> condIntReg GE x y CharEqOp -> condIntReg EQQ x y CharNeOp -> condIntReg NE x y CharLtOp -> condIntReg LTT x y CharLeOp -> condIntReg LE x y IntGtOp -> condIntReg GTT x y IntGeOp -> condIntReg GE x y IntEqOp -> condIntReg EQQ x y IntNeOp -> condIntReg NE x y IntLtOp -> condIntReg LTT x y IntLeOp -> condIntReg LE x y WordGtOp -> condIntReg GU x y WordGeOp -> condIntReg GEU x y WordEqOp -> condIntReg EQQ x y WordNeOp -> condIntReg NE x y WordLtOp -> condIntReg LU x y WordLeOp -> condIntReg LEU x y AddrGtOp -> condIntReg GU x y AddrGeOp -> condIntReg GEU x y AddrEqOp -> condIntReg EQQ x y AddrNeOp -> condIntReg NE x y AddrLtOp -> condIntReg LU x y AddrLeOp -> condIntReg LEU x y FloatGtOp -> condFltReg GTT x y FloatGeOp -> condFltReg GE x y FloatEqOp -> condFltReg EQQ x y FloatNeOp -> condFltReg NE x y FloatLtOp -> condFltReg LTT x y FloatLeOp -> condFltReg LE x y DoubleGtOp -> condFltReg GTT x y DoubleGeOp -> condFltReg GE x y DoubleEqOp -> condFltReg EQQ x y DoubleNeOp -> condFltReg NE x y DoubleLtOp -> condFltReg LTT x y DoubleLeOp -> condFltReg LE x y IntAddOp -> add_code L x y IntSubOp -> sub_code L x y IntQuotOp -> trivialCode (IQUOT L) Nothing x y IntRemOp -> trivialCode (IREM L) Nothing x y IntMulOp -> let op = IMUL L in trivialCode op (Just op) x y WordAddOp -> add_code L x y WordSubOp -> sub_code L x y WordMulOp -> let op = IMUL L in trivialCode op (Just op) x y FloatAddOp -> trivialFCode FloatRep GADD x y FloatSubOp -> trivialFCode FloatRep GSUB x y FloatMulOp -> trivialFCode FloatRep GMUL x y FloatDivOp -> trivialFCode FloatRep GDIV x y DoubleAddOp -> trivialFCode DoubleRep GADD x y DoubleSubOp -> trivialFCode DoubleRep GSUB x y DoubleMulOp -> trivialFCode DoubleRep GMUL x y DoubleDivOp -> trivialFCode DoubleRep GDIV x y AndOp -> let op = AND L in trivialCode op (Just op) x y OrOp -> let op = OR L in trivialCode op (Just op) x y XorOp -> let op = XOR L in trivialCode op (Just op) x y {- Shift ops on x86s have constraints on their source, it either has to be Imm, CL or 1 => trivialCode's is not restrictive enough (sigh.) -} SllOp -> shift_code (SHL L) x y {-False-} SrlOp -> shift_code (SHR L) x y {-False-} ISllOp -> shift_code (SHL L) x y {-False-} ISraOp -> shift_code (SAR L) x y {-False-} ISrlOp -> shift_code (SHR L) x y {-False-} FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y]) where promote x = StPrim Float2DoubleOp [x] DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y]) other -> pprPanic "getRegister(x86,dyadic primop)" (pprStixTree (StPrim primop [x, y])) where -------------------- shift_code :: (Imm -> Operand -> Instr) -> StixTree -> StixTree -> 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 (_PK_ "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 (_PK_ "end shift sequence") ] in returnNat (Any IntRep code__2) -------------------- add_code :: Size -> StixTree -> StixTree -> NatM Register add_code sz x (StInt y) = 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 `snocOL` LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) (OpReg dst) in returnNat (Any IntRep code__2) add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y -------------------- sub_code :: Size -> StixTree -> StixTree -> NatM Register sub_code sz x (StInt y) = 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 `snocOL` LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) (OpReg dst) in returnNat (Any IntRep code__2) sub_code sz x y = trivialCode (SUB sz) Nothing x y getRegister (StInd pk mem) = getAmode mem `thenNat` \ amode -> let code = amodeCode amode src = amodeAddr amode size = primRepToSize pk 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 | i == 0 = unitOL (XOR L (OpReg dst) (OpReg dst)) | otherwise = unitOL (MOV L (OpImm src) (OpReg dst)) in returnNat (Any IntRep code) getRegister leaf | maybeToBool imm = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst)) in returnNat (Any PtrRep code) | otherwise = pprPanic "getRegister(x86)" (pprStixTree 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) = getNatLabelNCG `thenNat` \ lbl -> getNewRegNCG PtrRep `thenNat` \ tmp -> let code dst = toOL [ SEGMENT DataSegment, LABEL lbl, DATA DF [ImmDouble d], SEGMENT TextSegment, SETHI (HI (ImmCLbl lbl)) tmp, LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] in returnNat (Any DoubleRep code) -- The 6-word scratch area is immediately below the frame pointer. -- Below that is the spill area. getRegister (StScratchWord i) | i >= 0 && i < 6 = let code dst = unitOL (fpRelEA (i-6) dst) in returnNat (Any PtrRep code) getRegister (StPrim primop [x]) -- unary PrimOps = case primop of IntNegOp -> trivialUCode (SUB False False g0) x NotOp -> trivialUCode (XNOR False g0) x FloatNegOp -> trivialUFCode FloatRep (FNEG F) x DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x 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 cCallConv DoubleRep [fixed_x]) where (is_float_op, fn) = case primop of FloatExpOp -> (True, SLIT("exp")) FloatLogOp -> (True, SLIT("log")) FloatSqrtOp -> (True, SLIT("sqrt")) FloatSinOp -> (True, SLIT("sin")) FloatCosOp -> (True, SLIT("cos")) FloatTanOp -> (True, SLIT("tan")) FloatAsinOp -> (True, SLIT("asin")) FloatAcosOp -> (True, SLIT("acos")) FloatAtanOp -> (True, SLIT("atan")) FloatSinhOp -> (True, SLIT("sinh")) FloatCoshOp -> (True, SLIT("cosh")) FloatTanhOp -> (True, SLIT("tanh")) DoubleExpOp -> (False, SLIT("exp")) DoubleLogOp -> (False, SLIT("log")) DoubleSqrtOp -> (False, SLIT("sqrt")) DoubleSinOp -> (False, SLIT("sin")) DoubleCosOp -> (False, SLIT("cos")) DoubleTanOp -> (False, SLIT("tan")) DoubleAsinOp -> (False, SLIT("asin")) DoubleAcosOp -> (False, SLIT("acos")) DoubleAtanOp -> (False, SLIT("atan")) DoubleSinhOp -> (False, SLIT("sinh")) DoubleCoshOp -> (False, SLIT("cosh")) DoubleTanhOp -> (False, SLIT("tanh")) other -> pprPanic "getRegister(sparc,monadicprimop)" (pprStixTree (StPrim primop [x])) getRegister (StPrim primop [x, y]) -- dyadic PrimOps = case primop of CharGtOp -> condIntReg GTT x y CharGeOp -> condIntReg GE x y CharEqOp -> condIntReg EQQ x y CharNeOp -> condIntReg NE x y CharLtOp -> condIntReg LTT x y CharLeOp -> condIntReg LE x y IntGtOp -> condIntReg GTT x y IntGeOp -> condIntReg GE x y IntEqOp -> condIntReg EQQ x y IntNeOp -> condIntReg NE x y IntLtOp -> condIntReg LTT x y IntLeOp -> condIntReg LE x y WordGtOp -> condIntReg GU x y WordGeOp -> condIntReg GEU x y WordEqOp -> condIntReg EQQ x y WordNeOp -> condIntReg NE x y WordLtOp -> condIntReg LU x y WordLeOp -> condIntReg LEU x y AddrGtOp -> condIntReg GU x y AddrGeOp -> condIntReg GEU x y AddrEqOp -> condIntReg EQQ x y AddrNeOp -> condIntReg NE x y AddrLtOp -> condIntReg LU x y AddrLeOp -> condIntReg LEU x y FloatGtOp -> condFltReg GTT x y FloatGeOp -> condFltReg GE x y FloatEqOp -> condFltReg EQQ x y FloatNeOp -> condFltReg NE x y FloatLtOp -> condFltReg LTT x y FloatLeOp -> condFltReg LE x y DoubleGtOp -> condFltReg GTT x y DoubleGeOp -> condFltReg GE x y DoubleEqOp -> condFltReg EQQ x y DoubleNeOp -> condFltReg NE x y DoubleLtOp -> condFltReg LTT x y DoubleLeOp -> condFltReg LE x y IntAddOp -> trivialCode (ADD False False) x y IntSubOp -> trivialCode (SUB False False) x y -- ToDo: teach about V8+ SPARC mul/div instructions IntMulOp -> imul_div SLIT(".umul") x y IntQuotOp -> imul_div SLIT(".div") x y IntRemOp -> imul_div SLIT(".rem") x y WordAddOp -> trivialCode (ADD False False) x y WordSubOp -> trivialCode (SUB False False) x y WordMulOp -> imul_div SLIT(".umul") x y FloatAddOp -> trivialFCode FloatRep FADD x y FloatSubOp -> trivialFCode FloatRep FSUB x y FloatMulOp -> trivialFCode FloatRep FMUL x y FloatDivOp -> trivialFCode FloatRep FDIV x y DoubleAddOp -> trivialFCode DoubleRep FADD x y DoubleSubOp -> trivialFCode DoubleRep FSUB x y DoubleMulOp -> trivialFCode DoubleRep FMUL x y DoubleDivOp -> trivialFCode DoubleRep FDIV x y AndOp -> trivialCode (AND False) x y OrOp -> trivialCode (OR False) x y XorOp -> trivialCode (XOR False) x y SllOp -> trivialCode SLL x y SrlOp -> trivialCode SRL x y ISllOp -> trivialCode SLL x y ISraOp -> trivialCode SRA x y ISrlOp -> trivialCode SRL x y FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y]) where promote x = StPrim Float2DoubleOp [x] DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y]) other -> pprPanic "getRegister(sparc,dyadic primop)" (pprStixTree (StPrim primop [x, y])) where imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y]) getRegister (StInd pk mem) = getAmode mem `thenNat` \ amode -> let code = amodeCode amode src = amodeAddr amode size = primRepToSize pk code__2 dst = code `snocOL` LD size src dst in returnNat (Any pk code__2) getRegister (StInt i) | fits13Bits i = let src = ImmInt (fromInteger i) code dst = unitOL (OR False g0 (RIImm src) dst) in returnNat (Any IntRep code) getRegister leaf | maybeToBool imm = let code dst = toOL [ SETHI (HI imm__2) dst, OR False dst (RIImm (LO imm__2)) dst] in returnNat (Any PtrRep code) | otherwise = pprPanic "getRegister(sparc)" (pprStixTree leaf) where imm = maybeImm leaf imm__2 = case imm of Just x -> x #endif {- sparc_TARGET_ARCH -} \end{code} %************************************************************************ %* * \subsection{The @Amode@ type} %* * %************************************************************************ @Amode@s: Memory addressing modes passed up the tree. \begin{code} data Amode = Amode MachRegsAddr InstrBlock amodeAddr (Amode addr _) = addr amodeCode (Amode _ code) = code \end{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 -> NatM Amode getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree) #if alpha_TARGET_ARCH getAmode (StPrim IntSubOp [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 returnNat (Amode (AddrRegImm reg off) code) getAmode (StPrim IntAddOp [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 returnNat (Amode (AddrRegImm reg off) code) getAmode leaf | maybeToBool imm = returnNat (Amode (AddrImm imm__2) id) where imm = maybeImm leaf imm__2 = case imm of Just x -> x getAmode other = getNewRegNCG PtrRep `thenNat` \ tmp -> getRegister other `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp in returnNat (Amode (AddrReg reg) code) #endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH getAmode (StPrim IntSubOp [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 returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code) getAmode (StPrim IntAddOp [x, StInt i]) | maybeToBool imm = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL) where imm = maybeImm x imm__2 = case imm of Just x -> x getAmode (StPrim IntAddOp [x, StInt i]) = getNewRegNCG PtrRep `thenNat` \ tmp -> getRegister x `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp off = ImmInt (fromInteger i) in returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code) getAmode (StPrim IntAddOp [x, StPrim SllOp [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 reg1 = registerName register1 tmp1 code2 = registerCode register2 tmp2 reg2 = registerName register2 tmp2 code__2 = code1 `appOL` code2 base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8 in returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0)) code__2) getAmode leaf | maybeToBool imm = returnNat (Amode (ImmAddr imm__2 0) nilOL) where imm = maybeImm leaf imm__2 = case imm of Just x -> x getAmode other = getNewRegNCG PtrRep `thenNat` \ tmp -> getRegister other `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp in returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code) #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH getAmode (StPrim IntSubOp [x, StInt i]) | fits13Bits (-i) = getNewRegNCG PtrRep `thenNat` \ tmp -> getRegister x `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp off = ImmInt (-(fromInteger i)) in returnNat (Amode (AddrRegImm reg off) code) getAmode (StPrim IntAddOp [x, StInt i]) | fits13Bits i = getNewRegNCG PtrRep `thenNat` \ tmp -> getRegister x `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp off = ImmInt (fromInteger i) in returnNat (Amode (AddrRegImm reg off) code) getAmode (StPrim IntAddOp [x, y]) = getNewRegNCG PtrRep `thenNat` \ tmp1 -> getNewRegNCG IntRep `thenNat` \ tmp2 -> getRegister x `thenNat` \ register1 -> getRegister y `thenNat` \ register2 -> let code1 = registerCode register1 tmp1 reg1 = registerName register1 tmp1 code2 = registerCode register2 tmp2 reg2 = registerName register2 tmp2 code__2 = code1 `appOL` code2 in returnNat (Amode (AddrRegReg reg1 reg2) code__2) getAmode leaf | maybeToBool imm = getNewRegNCG PtrRep `thenNat` \ tmp -> let code = unitOL (SETHI (HI imm__2) tmp) in returnNat (Amode (AddrRegImm tmp (LO imm__2)) code) where imm = maybeImm leaf imm__2 = case imm of Just x -> x getAmode other = getNewRegNCG PtrRep `thenNat` \ tmp -> getRegister other `thenNat` \ register -> let code = registerCode register tmp reg = registerName register tmp off = ImmInt 0 in returnNat (Amode (AddrRegImm reg off) code) #endif {- sparc_TARGET_ARCH -} \end{code} %************************************************************************ %* * \subsection{The @CondCode@ type} %* * %************************************************************************ Condition codes passed up the tree. \begin{code} data CondCode = CondCode Bool Cond InstrBlock condName (CondCode _ cond _) = cond condFloat (CondCode is_float _ _) = is_float condCode (CondCode _ _ code) = code \end{code} Set up a condition code for a conditional branch. \begin{code} getCondCode :: StixTree -> NatM CondCode #if alpha_TARGET_ARCH getCondCode = panic "MachCode.getCondCode: not on Alphas" #endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH || sparc_TARGET_ARCH -- yes, they really do seem to want exactly the same! getCondCode (StPrim primop [x, y]) = case primop of CharGtOp -> condIntCode GTT x y CharGeOp -> condIntCode GE x y CharEqOp -> condIntCode EQQ x y CharNeOp -> condIntCode NE x y CharLtOp -> condIntCode LTT x y CharLeOp -> condIntCode LE x y IntGtOp -> condIntCode GTT x y IntGeOp -> condIntCode GE x y IntEqOp -> condIntCode EQQ x y IntNeOp -> condIntCode NE x y IntLtOp -> condIntCode LTT x y IntLeOp -> condIntCode LE x y WordGtOp -> condIntCode GU x y WordGeOp -> condIntCode GEU x y WordEqOp -> condIntCode EQQ x y WordNeOp -> condIntCode NE x y WordLtOp -> condIntCode LU x y WordLeOp -> condIntCode LEU x y AddrGtOp -> condIntCode GU x y AddrGeOp -> condIntCode GEU x y AddrEqOp -> condIntCode EQQ x y AddrNeOp -> condIntCode NE x y AddrLtOp -> condIntCode LU x y AddrLeOp -> condIntCode LEU x y FloatGtOp -> condFltCode GTT x y FloatGeOp -> condFltCode GE x y FloatEqOp -> condFltCode EQQ x y FloatNeOp -> condFltCode NE x y FloatLtOp -> condFltCode LTT x y FloatLeOp -> condFltCode LE x y DoubleGtOp -> condFltCode GTT x y DoubleGeOp -> condFltCode GE x y DoubleEqOp -> condFltCode EQQ x y DoubleNeOp -> condFltCode NE x y DoubleLtOp -> condFltCode LTT x y DoubleLeOp -> condFltCode LE x y #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -} \end{code} % ----------------- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be passed back up the tree. \begin{code} condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> NatM CondCode #if alpha_TARGET_ARCH condIntCode = panic "MachCode.condIntCode: not on Alphas" condFltCode = panic "MachCode.condFltCode: not on Alphas" #endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH -- memory vs immediate condIntCode cond (StInd pk x) y | maybeToBool imm = getAmode x `thenNat` \ amode -> let code1 = amodeCode amode x__2 = amodeAddr amode sz = primRepToSize pk code__2 = code1 `snocOL` CMP sz (OpImm imm__2) (OpAddr x__2) in returnNat (CondCode False cond code__2) where imm = maybeImm y imm__2 = case imm of Just x -> x -- anything vs zero condIntCode cond x (StInt 0) = getRegister x `thenNat` \ register1 -> getNewRegNCG IntRep `thenNat` \ tmp1 -> let code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 code__2 = code1 `snocOL` TEST L (OpReg src1) (OpReg src1) in returnNat (CondCode False cond code__2) -- anything vs immediate condIntCode cond x y | maybeToBool imm = getRegister x `thenNat` \ register1 -> getNewRegNCG IntRep `thenNat` \ tmp1 -> let code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 code__2 = code1 `snocOL` CMP L (OpImm imm__2) (OpReg src1) in returnNat (CondCode False cond code__2) where imm = maybeImm y imm__2 = case imm of Just x -> x -- memory vs anything condIntCode cond (StInd pk x) y = 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 `thenNat` \ register1 -> getRegister y `thenNat` \ register2 -> getNewRegNCG IntRep `thenNat` \ tmp1 -> getNewRegNCG IntRep `thenNat` \ tmp2 -> let code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 code__2 = code1 `snocOL` MOV L (OpReg src1) (OpReg tmp1) `appOL` code2 `snocOL` CMP L (OpReg src2) (OpReg tmp1) in returnNat (CondCode False cond code__2) ----------- condFltCode cond x y = getRegister x `thenNat` \ register1 -> getRegister y `thenNat` \ register2 -> getNewRegNCG (registerRep register1) `thenNat` \ tmp1 -> getNewRegNCG (registerRep register2) `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 | isAny register1 = code1 `appOL` -- result in tmp1 code2 `snocOL` GCMP (primRepToSize pk1) tmp1 src2 | otherwise = code1 `snocOL` GMOV src1 tmp1 `appOL` code2 `snocOL` GCMP (primRepToSize pk1) tmp1 src2 {- On the 486, the flags set by FP compare are the unsigned ones! (This looks like a HACK to me. WDP 96/03) -} fix_FP_cond :: Cond -> Cond fix_FP_cond GE = GEU fix_FP_cond GTT = GU fix_FP_cond LTT = LU fix_FP_cond LE = LEU fix_FP_cond any = any in returnNat (CondCode True (fix_FP_cond cond) code__2) #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH condIntCode cond x (StInt y) | fits13Bits y = getRegister x `thenNat` \ register -> getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src1 = registerName register tmp src2 = ImmInt (fromInteger y) code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0 in returnNat (CondCode False cond code__2) condIntCode cond x y = getRegister x `thenNat` \ register1 -> getRegister y `thenNat` \ register2 -> getNewRegNCG IntRep `thenNat` \ tmp1 -> getNewRegNCG IntRep `thenNat` \ tmp2 -> let code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 code__2 = code1 `appOL` code2 `snocOL` SUB False True src1 (RIReg src2) g0 in returnNat (CondCode False cond code__2) ----------- condFltCode cond x y = getRegister x `thenNat` \ register1 -> getRegister y `thenNat` \ register2 -> getNewRegNCG (registerRep register1) `thenNat` \ tmp1 -> getNewRegNCG (registerRep register2) `thenNat` \ tmp2 -> getNewRegNCG DoubleRep `thenNat` \ tmp -> let promote x = FxTOy F DF x tmp pk1 = registerRep register1 code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 pk2 = registerRep register2 code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 code__2 = if pk1 == pk2 then code1 `appOL` code2 `snocOL` FCMP True (primRepToSize pk1) src1 src2 else if pk1 == FloatRep then code1 `snocOL` promote src1 `appOL` code2 `snocOL` FCMP True DF tmp src2 else code1 `appOL` code2 `snocOL` promote src2 `snocOL` FCMP True DF src1 tmp in returnNat (CondCode True cond code__2) #endif {- sparc_TARGET_ARCH -} \end{code} %************************************************************************ %* * \subsection{Generating assignments} %* * %************************************************************************ Assignments are really at the heart of the whole code generation business. Almost all top-level nodes of any real importance are assignments, which correspond to loads, stores, or register transfers. If we're really lucky, some of the register transfers will go away, because we can use the destination register to complete the code generation for the right hand side. This only fails when the right hand side is forced into a fixed register (e.g. the result of a call). \begin{code} assignIntCode, assignFltCode :: PrimRep -> StixTree -> StixTree -> NatM InstrBlock #if alpha_TARGET_ARCH assignIntCode pk (StInd _ dst) src = getNewRegNCG IntRep `thenNat` \ tmp -> getAmode dst `thenNat` \ amode -> getRegister src `thenNat` \ register -> let code1 = amodeCode amode [] dst__2 = amodeAddr amode code2 = registerCode register tmp [] src__2 = registerName register tmp sz = primRepToSize pk code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) in returnNat code__2 assignIntCode pk dst src = getRegister dst `thenNat` \ register1 -> getRegister src `thenNat` \ register2 -> let 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 returnNat code__2 #endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH -- Destination of an assignment can only be reg or mem. -- This is the mem case. assignIntCode pk (StInd _ dst) src = getAmode dst `thenNat` \ amode -> 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 -> NatM (InstrBlock,Operand) -- code, operator get_op_RI op | maybeToBool imm = returnNat (nilOL, OpImm imm_op) where imm = maybeImm op imm_op = case imm of Just x -> x get_op_RI op = getRegister op `thenNat` \ register -> getNewRegNCG (registerRep register) `thenNat` \ tmp -> let code = registerCode register tmp reg = registerName register tmp in returnNat (code, OpReg reg) -- Assign; dst is a reg, rhs is mem assignIntCode pk dst (StInd pks src) = getNewRegNCG PtrRep `thenNat` \ tmp -> getAmode src `thenNat` \ amode -> getRegister dst `thenNat` \ reg_dst -> let c_addr = amodeCode amode am_addr = amodeAddr amode c_dst = registerCode reg_dst tmp -- should be empty r_dst = registerName reg_dst tmp szs = primRepToSize pks opc = case szs of B -> MOVSxL B Bu -> MOVZxL Bu W -> MOVSxL W Wu -> MOVZxL Wu L -> MOV L Lu -> MOV L code | isNilOL c_dst = c_addr `snocOL` opc (OpAddr am_addr) (OpReg r_dst) | otherwise = pprPanic "assignIntCode(x86): bad dst(2)" empty in returnNat code -- dst is a reg, but src could be anything assignIntCode pk dst src = getRegister dst `thenNat` \ registerd -> getRegister src `thenNat` \ registers -> getNewRegNCG IntRep `thenNat` \ tmp -> let r_dst = registerName registerd tmp c_dst = registerCode registerd tmp -- should be empty r_src = registerName registers r_dst c_src = registerCode registers r_dst code | isNilOL c_dst = c_src `snocOL` MOV L (OpReg r_src) (OpReg r_dst) | otherwise = pprPanic "assignIntCode(x86): bad dst(3)" empty in returnNat code #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH assignIntCode pk (StInd _ dst) src = getNewRegNCG IntRep `thenNat` \ tmp -> getAmode dst `thenNat` \ amode -> getRegister src `thenNat` \ register -> let code1 = amodeCode amode dst__2 = amodeAddr amode code2 = registerCode register tmp src__2 = registerName register tmp sz = primRepToSize pk code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2 in returnNat code__2 assignIntCode pk dst src = getRegister dst `thenNat` \ register1 -> getRegister src `thenNat` \ register2 -> let dst__2 = registerName register1 g0 code = registerCode register2 dst__2 src__2 = registerName register2 dst__2 code__2 = if isFixed register2 then code `snocOL` OR False g0 (RIReg src__2) dst__2 else code in 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 `thenNat` \ tmp -> getAmode dst `thenNat` \ amode -> getRegister src `thenNat` \ register -> let code1 = amodeCode amode [] dst__2 = amodeAddr amode code2 = registerCode register tmp [] src__2 = registerName register tmp sz = primRepToSize pk code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) in returnNat code__2 assignFltCode pk dst src = getRegister dst `thenNat` \ register1 -> getRegister src `thenNat` \ register2 -> let dst__2 = registerName register1 zeroh 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 returnNat code__2 #endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH -- dst is memory assignFltCode pk (StInd pk_dst addr) src | pk /= pk_dst = pprPanic "assignFltCode(x86): src/ind sz mismatch" empty | otherwise = 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 -- dst must be a (FP) register assignFltCode pk dst src = getRegister dst `thenNat` \ reg_dst -> getRegister src `thenNat` \ reg_src -> getNewRegNCG pk `thenNat` \ tmp -> let r_dst = registerName reg_dst tmp c_dst = registerCode reg_dst tmp -- should be empty r_src = registerName reg_src r_dst c_src = registerCode reg_src r_dst code | isNilOL c_dst = if isFixed reg_src then c_src `snocOL` GMOV r_src r_dst else c_src | otherwise = pprPanic "assignFltCode(x86): lhs is not mem or reg" empty in returnNat code #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH assignFltCode pk (StInd _ dst) src = getNewRegNCG pk `thenNat` \ tmp1 -> getAmode dst `thenNat` \ amode -> getRegister src `thenNat` \ register -> let sz = primRepToSize pk dst__2 = amodeAddr amode code1 = amodeCode amode code2 = registerCode register tmp1 src__2 = registerName register tmp1 pk__2 = registerRep register sz__2 = primRepToSize pk__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 returnNat code__2 assignFltCode pk dst src = getRegister dst `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 code__2 = if pk /= pk__2 then code `snocOL` FxTOy sz__2 sz src__2 dst__2 else if isFixed register2 then code `snocOL` FMOV sz src__2 dst__2 else code in returnNat code__2 #endif {- sparc_TARGET_ARCH -} \end{code} %************************************************************************ %* * \subsection{Generating an unconditional branch} %* * %************************************************************************ We accept two types of targets: an immediate CLabel or a tree that gets evaluated into a register. Any CLabels which are AsmTemporaries are assumed to be in the local block of code, close enough for a branch instruction. Other CLabels are assumed to be far away. (If applicable) Do not fill the delay slots here; you will confuse the register allocator. \begin{code} genJump :: DestInfo -> StixTree{-the branch target-} -> NatM InstrBlock #if alpha_TARGET_ARCH genJump (StCLbl lbl) | isAsmTemp lbl = returnInstr (BR target) | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0] where target = ImmCLbl lbl genJump tree = 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 zeroh (AddrReg pv) 0] else returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0)) #endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH genJump dsts (StInd pk mem) = getAmode mem `thenNat` \ amode -> let code = amodeCode amode target = amodeAddr amode in returnNat (code `snocOL` JMP dsts (OpAddr target)) genJump dsts tree | maybeToBool imm = returnNat (unitOL (JMP dsts (OpImm target))) | otherwise = getRegister tree `thenNat` \ register -> getNewRegNCG PtrRep `thenNat` \ tmp -> let code = registerCode register tmp target = registerName register tmp in 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 dsts (StCLbl lbl) | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts" | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP]) | otherwise = returnNat (toOL [CALL target 0 True, NOP]) where target = ImmCLbl lbl genJump dsts tree = getRegister tree `thenNat` \ register -> getNewRegNCG PtrRep `thenNat` \ tmp -> let code = registerCode register tmp target = registerName register tmp in returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP) #endif {- sparc_TARGET_ARCH -} \end{code} %************************************************************************ %* * \subsection{Conditional jumps} %* * %************************************************************************ Conditional jumps are always to local labels, so we can use branch instructions. We peek at the arguments to decide what kind of comparison to do. ALPHA: For comparisons with 0, we're laughing, because we can just do the desired conditional branch. I386: First, we have to ensure that the condition codes are set according to the supplied comparison operation. SPARC: First, we have to ensure that the condition codes are set according to the supplied comparison operation. We generate slightly different code for floating point comparisons, because a floating point operation cannot directly precede a @BF@. We assume the worst and fill that slot with a @NOP@. SPARC: Do not fill the delay slots here; you will confuse the register allocator. \begin{code} genCondJump :: CLabel -- the branch target -> StixTree -- the condition on which to branch -> NatM InstrBlock #if alpha_TARGET_ARCH genCondJump lbl (StPrim op [x, StInt 0]) = getRegister x `thenNat` \ register -> getNewRegNCG (registerRep register) `thenNat` \ tmp -> let code = registerCode register tmp value = registerName register tmp pk = registerRep register target = ImmCLbl lbl in returnSeq code [BI (cmpOp op) value target] where cmpOp CharGtOp = GTT cmpOp CharGeOp = GE cmpOp CharEqOp = EQQ cmpOp CharNeOp = NE cmpOp CharLtOp = LTT cmpOp CharLeOp = LE cmpOp IntGtOp = GTT cmpOp IntGeOp = GE cmpOp IntEqOp = EQQ cmpOp IntNeOp = NE cmpOp IntLtOp = LTT cmpOp IntLeOp = LE cmpOp WordGtOp = NE cmpOp WordGeOp = ALWAYS cmpOp WordEqOp = EQQ cmpOp WordNeOp = NE cmpOp WordLtOp = NEVER cmpOp WordLeOp = EQQ cmpOp AddrGtOp = NE cmpOp AddrGeOp = ALWAYS cmpOp AddrEqOp = EQQ cmpOp AddrNeOp = NE cmpOp AddrLtOp = NEVER cmpOp AddrLeOp = EQQ genCondJump lbl (StPrim op [x, StDouble 0.0]) = getRegister x `thenNat` \ register -> getNewRegNCG (registerRep register) `thenNat` \ tmp -> let code = registerCode register tmp value = registerName register tmp pk = registerRep register target = ImmCLbl lbl in returnNat (code . mkSeqInstr (BF (cmpOp op) value target)) where cmpOp FloatGtOp = GTT cmpOp FloatGeOp = GE cmpOp FloatEqOp = EQQ cmpOp FloatNeOp = NE cmpOp FloatLtOp = LTT cmpOp FloatLeOp = LE cmpOp DoubleGtOp = GTT cmpOp DoubleGeOp = GE cmpOp DoubleEqOp = EQQ cmpOp DoubleNeOp = NE cmpOp DoubleLtOp = LTT cmpOp DoubleLeOp = LE genCondJump lbl (StPrim op [x, y]) | fltCmpOp op = trivialFCode pr instr x y `thenNat` \ register -> getNewRegNCG DoubleRep `thenNat` \ tmp -> let code = registerCode register tmp result = registerName register tmp target = ImmCLbl lbl in returnNat (code . mkSeqInstr (BF cond result target)) where pr = panic "trivialU?FCode: does not use PrimRep on Alpha" fltCmpOp op = case op of FloatGtOp -> True FloatGeOp -> True FloatEqOp -> True FloatNeOp -> True FloatLtOp -> True FloatLeOp -> True DoubleGtOp -> True DoubleGeOp -> True DoubleEqOp -> True DoubleNeOp -> True DoubleLtOp -> True DoubleLeOp -> True _ -> False (instr, cond) = case op of 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, 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 `thenNat` \ register -> getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp result = registerName register tmp target = ImmCLbl lbl in returnNat (code . mkSeqInstr (BI cond result target)) where (instr, cond) = case op of 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, EQQ) IntGeOp -> (CMP LTT, EQQ) IntEqOp -> (CMP EQQ, NE) IntNeOp -> (CMP EQQ, EQQ) IntLtOp -> (CMP LTT, NE) IntLeOp -> (CMP LE, NE) 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, 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 `thenNat` \ condition -> let code = condCode condition cond = condName condition in returnNat (code `snocOL` JXX cond lbl) #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH genCondJump lbl bool = getCondCode bool `thenNat` \ condition -> let code = condCode condition cond = condName condition target = ImmCLbl lbl in 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} %************************************************************************ %* * \subsection{Generating C calls} %* * %************************************************************************ Now the biggest nightmare---calls. Most of the nastiness is buried in @get_arg@, which moves the arguments to the correct registers/stack locations. Apart from that, the code is easy. (If applicable) Do not fill the delay slots here; you will confuse the register allocator. \begin{code} genCCall :: FAST_STRING -- function to call -> CallConv -> PrimRep -- type of the result -> [StixTree] -- arguments (of mixed type) -> NatM InstrBlock #if alpha_TARGET_ARCH genCCall fn cconv kind args = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args `thenNat` \ ((unused,_), argCode) -> let nRegs = length allArgRegs - length unused code = asmSeqThen (map ($ []) argCode) in returnSeq code [ LDA pv (AddrImm (ImmLab (ptext fn))), JSR ra (AddrReg pv) nRegs, LDGP gp (AddrReg ra)] where ------------------------ {- Try to get a value into a specific register (or registers) for a call. The first 6 arguments go into the appropriate argument register (separate registers for integer and floating point arguments, but used in lock-step), and the remaining arguments are dumped to the stack, beginning at 0(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 @mapAccumLNat@. -} get_arg :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator) -> StixTree -- Current argument -> 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 `thenNat` \ register -> let reg = if isFloatingRep pk then fDst else iDst code = registerCode register reg src = registerName register reg pk = registerRep register in returnNat ( if isFloatingRep pk then ((dsts, offset), if isFixed register then code . mkSeqInstr (FMOV src fDst) else code) else ((dsts, offset), if isFixed register then code . mkSeqInstr (OR src (RIReg src) iDst) else code)) -- Once we have run out of argument registers, we move to the -- stack... get_arg ([], offset) arg = getRegister arg `thenNat` \ register -> getNewRegNCG (registerRep register) `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp pk = registerRep register sz = primRepToSize pk in returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset))) #endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH genCCall fn cconv kind [StInt i] | fn == SLIT ("PerformGC_wrapper") = let call = toOL [ MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax), CALL (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper"))))) ] in returnNat call genCCall fn cconv kind args = mapNat get_call_arg (reverse args) `thenNat` \ sizes_n_codes -> getDeltaNat `thenNat` \ delta -> let (sizes, codes) = unzip sizes_n_codes tot_arg_size = sum sizes code2 = concatOL codes call = toOL ( [CALL (fn__2 tot_arg_size)] ++ (if cconv == stdCallConv then [] else [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)]) ++ [DELTA (delta + tot_arg_size)] ) in setDeltaNat (delta + tot_arg_size) `thenNat` \ _ -> returnNat (code2 `appOL` call) 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_u = _UNPK_ fn fn__2 tot_arg_size | head fn_u == '.' = ImmLit (text (fn_u ++ stdcallsize tot_arg_size)) | otherwise = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size)) stdcallsize tot_arg_size | cconv == stdCallConv = '@':show tot_arg_size | otherwise = "" arg_size DF = 8 arg_size F = 4 arg_size _ = 4 ------------ get_call_arg :: StixTree{-current argument-} -> NatM (Int, InstrBlock) -- argsz, code get_call_arg arg = get_op arg `thenNat` \ (code, reg, sz) -> getDeltaNat `thenNat` \ delta -> arg_size sz `bind` \ size -> setDeltaNat (delta-size) `thenNat` \ _ -> 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) ) ------------ get_op :: StixTree -> NatM (InstrBlock, Reg, Size) -- code, reg, size get_op op = getRegister op `thenNat` \ register -> getNewRegNCG (registerRep register) `thenNat` \ tmp -> let code = registerCode register tmp reg = registerName register tmp pk = registerRep register sz = primRepToSize pk in returnNat (code, reg, sz) #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH {- The SPARC calling convention is an absolute nightmare. The first 6x32 bits of arguments are mapped into %o0 through %o5, and the remaining arguments are dumped to the stack, beginning at [%sp+92]. (Note that %o6 == %sp.) If we have to put args on the stack, move %o6==%sp down by the number of words to go on the stack, to ensure there's enough space. According to Fraser and Hanson's lcc book, page 478, fig 17.2, 16 words above the stack pointer is a word for the address of a structure return value. I use this as a temporary location for moving values from float to int regs. Certainly it isn't safe to put anything in the 16 words starting at %sp, since this area can get trashed at any time due to window overflows caused by signal handlers. A final complication (if the above isn't enough) is that we can't blithely calculate the arguments one by one into %o0 .. %o5. Consider the following nested calls: fff a (fff b c) Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately the inner call will itself use %o0, which trashes the value put there in preparation for the outer call. Upshot: we need to calculate the args into temporary regs, and move those to arg regs or onto the stack only immediately prior to the call proper. Sigh. -} genCCall fn cconv kind args = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs -> let (argcodes, vregss) = unzip argcode_and_vregs argcode = concatOL argcodes vregs = concat vregss n_argRegs = length allArgRegs n_argRegs_used = min (length vregs) n_argRegs (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) call = unitOL (CALL fn__2 n_argRegs_used False) in returnNat (argcode `appOL` move_sp_down `appOL` transfer_code `appOL` call `appOL` unitOL NOP `appOL` move_sp_up) where -- function names that begin with '.' are assumed to be special -- internally generated names like '.mul,' which don't get an -- underscore prefix -- ToDo:needed (WDP 96/03) ??? fn__2 = case (_HEAD_ fn) of '.' -> ImmLit (ptext fn) _ -> ImmLab False (ptext fn) -- 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 :: StixTree -> NatM (OrdList Instr, [Reg]) arg_to_int_vregs arg = 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} %************************************************************************ %* * \subsection{Support bits} %* * %************************************************************************ %************************************************************************ %* * \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers} %* * %************************************************************************ Turn those condition codes into integers now (when they appear on the right hand side of an assignment). (If applicable) Do not fill the delay slots here; you will confuse the register allocator. \begin{code} condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> NatM Register #if alpha_TARGET_ARCH condIntReg = panic "MachCode.condIntReg (not on Alpha)" condFltReg = panic "MachCode.condFltReg (not on Alpha)" #endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH condIntReg cond x y = condIntCode cond x y `thenNat` \ condition -> getNewRegNCG IntRep `thenNat` \ tmp -> let code = condCode condition cond = condName condition code__2 dst = code `appOL` toOL [ SETCC cond (OpReg tmp), AND L (OpImm (ImmInt 1)) (OpReg tmp), MOV L (OpReg tmp) (OpReg dst)] in returnNat (Any IntRep code__2) condFltReg cond x y = getNatLabelNCG `thenNat` \ lbl1 -> getNatLabelNCG `thenNat` \ lbl2 -> condFltCode cond x y `thenNat` \ condition -> let code = condCode condition cond = condName condition code__2 dst = code `appOL` toOL [ JXX cond lbl1, MOV L (OpImm (ImmInt 0)) (OpReg dst), JXX ALWAYS lbl2, LABEL lbl1, MOV L (OpImm (ImmInt 1)) (OpReg dst), LABEL lbl2] in returnNat (Any IntRep code__2) #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH 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 `appOL` toOL [ SUB False True g0 (RIReg src) g0, SUB True False g0 (RIImm (ImmInt (-1))) dst] in returnNat (Any IntRep code__2) 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 src1 = registerName register1 tmp1 code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 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 returnNat (Any IntRep code__2) condIntReg NE x (StInt 0) = getRegister x `thenNat` \ register -> getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp code__2 dst = code `appOL` toOL [ SUB False True g0 (RIReg src) g0, ADD True False g0 (RIImm (ImmInt 0)) dst] in returnNat (Any IntRep code__2) condIntReg NE x y = getRegister x `thenNat` \ register1 -> getRegister y `thenNat` \ register2 -> getNewRegNCG IntRep `thenNat` \ tmp1 -> getNewRegNCG IntRep `thenNat` \ tmp2 -> let code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 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 returnNat (Any IntRep code__2) condIntReg cond x y = getNatLabelNCG `thenNat` \ lbl1 -> getNatLabelNCG `thenNat` \ lbl2 -> condIntCode cond x y `thenNat` \ condition -> let code = condCode condition cond = condName condition 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, LABEL lbl1, OR False g0 (RIImm (ImmInt 1)) dst, LABEL lbl2] in returnNat (Any IntRep code__2) condFltReg cond x y = getNatLabelNCG `thenNat` \ lbl1 -> getNatLabelNCG `thenNat` \ lbl2 -> condFltCode cond x y `thenNat` \ condition -> let code = condCode condition cond = condName condition code__2 dst = code `appOL` toOL [ NOP, BF cond False (ImmCLbl lbl1), NOP, OR False g0 (RIImm (ImmInt 0)) dst, BI ALWAYS False (ImmCLbl lbl2), NOP, LABEL lbl1, OR False g0 (RIImm (ImmInt 1)) dst, LABEL lbl2] in returnNat (Any IntRep code__2) #endif {- sparc_TARGET_ARCH -} \end{code} %************************************************************************ %* * \subsubsection{@trivial*Code@: deal with trivial instructions} %* * %************************************************************************ Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary: @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions. Only look for constants on the right hand side, because that's where the generic optimizer will have put them. Similarly, for unary instructions, we don't have to worry about matching an StInt as the argument, because genericOpt will already have handled the constant-folding. \begin{code} trivialCode :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr) ,IF_ARCH_i386 ((Operand -> Operand -> Instr) -> Maybe (Operand -> Operand -> Instr) ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr) ,))) -> StixTree -> StixTree -- 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 ((Size -> Reg -> Reg -> Reg -> Instr) ,))) -> StixTree -> StixTree -- 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 -> NatM Register trivialUFCode :: PrimRep -> IF_ARCH_alpha((Reg -> Reg -> Instr) ,IF_ARCH_i386 ((Reg -> Reg -> Instr) ,IF_ARCH_sparc((Reg -> Reg -> Instr) ,))) -> StixTree -- the one argument -> NatM Register #if alpha_TARGET_ARCH trivialCode instr x (StInt y) | fits8Bits y = 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 returnNat (Any IntRep code__2) trivialCode instr x y = getRegister x `thenNat` \ register1 -> getRegister y `thenNat` \ register2 -> getNewRegNCG IntRep `thenNat` \ tmp1 -> getNewRegNCG IntRep `thenNat` \ tmp2 -> let code1 = registerCode register1 tmp1 [] src1 = registerName register1 tmp1 code2 = registerCode register2 tmp2 [] src2 = registerName register2 tmp2 code__2 dst = asmSeqThen [code1, code2] . mkSeqInstr (instr src1 (RIReg src2) dst) in returnNat (Any IntRep code__2) ------------ trivialUCode instr x = 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 returnNat (Any IntRep code__2) ------------ trivialFCode _ instr x y = 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 code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 code__2 dst = asmSeqThen [code1 [], code2 []] . mkSeqInstr (instr src1 src2 dst) in returnNat (Any DoubleRep code__2) trivialUFCode _ instr x = 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 returnNat (Any DoubleRep code__2) #endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH \end{code} The Rules of the Game are: * You cannot assume anything about the destination register dst; it may be anything, including a fixed reg. * 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. * 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 ----------- trivialUCode instr x = getRegister x `thenNat` \ register -> let code__2 dst = let code = registerCode register dst src = registerName register dst 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 returnNat (Any IntRep code__2) ----------- trivialFCode pk instr x y = 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 code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 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 -- be paranoid (and inefficient) | otherwise = code1 `snocOL` GMOV src1 tmp1 `appOL` code2 `snocOL` instr (primRepToSize pk) tmp1 src2 dst in returnNat (Any pk code__2) ------------- trivialUFCode pk instr x = getRegister x `thenNat` \ register -> getNewRegNCG pk `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp code__2 dst = code `snocOL` instr src dst in returnNat (Any pk code__2) #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH trivialCode instr x (StInt y) | fits13Bits y = 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 `snocOL` instr src1 (RIImm src2) dst in returnNat (Any IntRep code__2) trivialCode instr x y = getRegister x `thenNat` \ register1 -> getRegister y `thenNat` \ register2 -> getNewRegNCG IntRep `thenNat` \ tmp1 -> getNewRegNCG IntRep `thenNat` \ tmp2 -> let code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 code__2 dst = code1 `appOL` code2 `snocOL` instr src1 (RIReg src2) dst in returnNat (Any IntRep code__2) ------------ trivialFCode pk instr x y = getRegister x `thenNat` \ register1 -> getRegister y `thenNat` \ register2 -> getNewRegNCG (registerRep register1) `thenNat` \ tmp1 -> getNewRegNCG (registerRep register2) `thenNat` \ tmp2 -> getNewRegNCG DoubleRep `thenNat` \ tmp -> let promote x = FxTOy F DF x tmp pk1 = registerRep register1 code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 pk2 = registerRep register2 code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 code__2 dst = if pk1 == pk2 then code1 `appOL` code2 `snocOL` instr (primRepToSize pk) src1 src2 dst else if pk1 == FloatRep then code1 `snocOL` promote src1 `appOL` code2 `snocOL` instr DF tmp src2 dst else code1 `appOL` code2 `snocOL` promote src2 `snocOL` instr DF src1 tmp dst in returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2) ------------ trivialUCode instr x = getRegister x `thenNat` \ register -> getNewRegNCG IntRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp code__2 dst = code `snocOL` instr (RIReg src) dst in returnNat (Any IntRep code__2) ------------- trivialUFCode pk instr x = getRegister x `thenNat` \ register -> getNewRegNCG pk `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp code__2 dst = code `snocOL` instr src dst in returnNat (Any pk code__2) #endif {- sparc_TARGET_ARCH -} \end{code} %************************************************************************ %* * \subsubsection{Coercing to/from integer/floating-point...} %* * %************************************************************************ @coerce(Int|Flt)Code@ are simple coercions that don't require any code to be generated. Here we just change the type on the Register passed on up. The code is machine-independent. @coerce(Int2FP|FP2Int)@ are more complicated integer/float conversions. We have to store temporaries in memory to move between the integer and the floating point register sets. \begin{code} coerceIntCode :: PrimRep -> StixTree -> NatM Register coerceFltCode :: StixTree -> NatM Register coerceInt2FP :: PrimRep -> StixTree -> NatM Register coerceFP2Int :: StixTree -> NatM Register coerceIntCode pk x = getRegister x `thenNat` \ register -> returnNat ( case register of Fixed _ reg code -> Fixed pk reg code Any _ code -> Any pk code ) ------------- coerceFltCode x = getRegister x `thenNat` \ register -> returnNat ( case register of Fixed _ reg code -> Fixed DoubleRep reg code Any _ code -> Any DoubleRep code ) \end{code} \begin{code} #if alpha_TARGET_ARCH coerceInt2FP _ x = getRegister x `thenNat` \ register -> getNewRegNCG IntRep `thenNat` \ reg -> let code = registerCode register reg src = registerName register reg code__2 dst = code . mkSeqInstrs [ ST Q src (spRel 0), LD TF dst (spRel 0), CVTxy Q TF dst dst] in returnNat (Any DoubleRep code__2) ------------- coerceFP2Int x = getRegister x `thenNat` \ register -> getNewRegNCG DoubleRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp code__2 dst = code . mkSeqInstrs [ CVTxy TF Q src tmp, ST TF tmp (spRel 0), LD Q dst (spRel 0)] in returnNat (Any IntRep code__2) #endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH extendIntCode :: PrimRep -> PrimRep -> StixTree -> NatM Register extendIntCode pks pkd x = coerceIntCode pks x `thenNat` \ register -> getNewRegNCG pks `thenNat` \ reg -> let code = registerCode register reg src = registerName register reg opc = case pkd of IntRep -> MOVSxL ; WordRep -> MOVZxL sz = primRepToSize pks code__2 dst = code `snocOL` opc sz (OpReg src) (OpReg dst) in returnNat (Any pkd code__2) ------------ coerceInt2FP pk x = getRegister x `thenNat` \ register -> getNewRegNCG IntRep `thenNat` \ reg -> let code = registerCode register reg src = registerName register reg opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD code__2 dst = code `snocOL` opc src dst in returnNat (Any pk code__2) ------------ coerceFP2Int x = getRegister x `thenNat` \ register -> getNewRegNCG DoubleRep `thenNat` \ tmp -> let code = registerCode register tmp src = registerName register tmp pk = registerRep register opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI code__2 dst = code `snocOL` opc src dst in returnNat (Any IntRep code__2) #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH coerceInt2FP pk x = getRegister x `thenNat` \ register -> getNewRegNCG IntRep `thenNat` \ reg -> let code = registerCode register reg src = registerName register reg code__2 dst = code `appOL` toOL [ ST W src (spRel (-2)), LD W (spRel (-2)) dst, FxTOy W (primRepToSize pk) dst dst] in returnNat (Any pk code__2) ------------ coerceFP2Int x = getRegister x `thenNat` \ register -> getNewRegNCG IntRep `thenNat` \ reg -> getNewRegNCG FloatRep `thenNat` \ tmp -> let code = registerCode register reg src = registerName register reg pk = registerRep register code__2 dst = code `appOL` toOL [ FxTOy (primRepToSize pk) W src tmp, ST W tmp (spRel (-2)), LD W (spRel (-2)) dst] in returnNat (Any IntRep code__2) #endif {- sparc_TARGET_ARCH -} \end{code} %************************************************************************ %* * \subsubsection{Coercing integer to @Char@...} %* * %************************************************************************ Integer to character conversion. \begin{code} chrCode :: StixTree -> NatM Register #if alpha_TARGET_ARCH -- TODO: This is probably wrong, but I don't know Alpha assembler. -- It should coerce a 64-bit value to a 32-bit value. chrCode x = getRegister x `thenNat` \ register -> getNewRegNCG IntRep `thenNat` \ reg -> let code = registerCode register reg src = registerName register reg code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst) in returnNat (Any IntRep code__2) #endif {- alpha_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH chrCode x = getRegister x `thenNat` \ register -> returnNat ( case register of Fixed _ reg code -> Fixed IntRep reg code Any _ code -> Any IntRep code ) #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH chrCode x = getRegister x `thenNat` \ register -> returnNat ( case register of Fixed _ reg code -> Fixed IntRep reg code Any _ code -> Any IntRep code ) #endif {- sparc_TARGET_ARCH -} \end{code}