X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FMachCode.lhs;h=01b9c6e9c3edfbeb5b63f9857e135de74cde04df;hb=f6007733dc8e9a3f58c36e2bab97d2858d2b569a;hp=d4195d7b0542fea633832cc3f8cb8aa27015db52;hpb=cc31b821c13cca0d84bd6ff612dc049ed73cd2db;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index d4195d7..01b9c6e 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -9,7 +9,7 @@ This is a big module, but, if you pay attention to structure should not be too overwhelming. \begin{code} -module MachCode ( stmt2Instrs, InstrBlock ) where +module MachCode ( stmtsToInstrs, InstrBlock ) where #include "HsVersions.h" #include "nativeGen/NCG.h" @@ -18,17 +18,16 @@ import MachMisc -- may differ per-platform import MachRegs import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL, snocOL, consOL, concatOL ) -import AbsCSyn ( MagicId ) import AbsCUtils ( magicIdPrimRep ) -import CallConv ( CallConv ) -import CLabel ( isAsmTemp, CLabel, pprCLabel_asm, labelDynamic ) +import ForeignCall ( CCallConv(..) ) +import CLabel ( isAsmTemp, CLabel, labelDynamic ) import Maybes ( maybeToBool, expectJust ) import PrimRep ( isFloatingRep, PrimRep(..) ) import PrimOp ( PrimOp(..) ) -import CallConv ( cCallConv ) import Stix ( getNatLabelNCG, StixTree(..), StixReg(..), CodeSegment(..), - pprStixTree, ppStixReg, + DestInfo, hasDestInfo, + pprStixTree, NatM, thenNat, returnNat, mapNat, mapAndUnzipNat, mapAccumLNat, getDeltaNat, setDeltaNat @@ -56,9 +55,85 @@ x `bind` f = f x Code extractor for an entire stix tree---stix statement level. \begin{code} -stmt2Instrs :: StixTree {- a stix statement -} -> NatM InstrBlock +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] -stmt2Instrs stmt = case stmt of + +stmtToInstrs :: StixTree {- a stix statement -} -> NatM InstrBlock +stmtToInstrs stmt = case stmt of StComment s -> returnNat (unitOL (COMMENT s)) StSegment seg -> returnNat (unitOL (SEGMENT seg)) @@ -69,7 +144,7 @@ stmt2Instrs stmt = case stmt of StLabel lab -> returnNat (unitOL (LABEL lab)) - StJump arg -> genJump (derefDLL arg) + StJump dsts arg -> genJump dsts (derefDLL arg) StCondJump lab arg -> genCondJump lab (derefDLL arg) -- A call returning void, ie one done for its side-effects @@ -92,19 +167,21 @@ stmt2Instrs stmt = case stmt of `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) = - getNatLabelNCG `thenNat` \ lbl -> - returnNat (toOL [LABEL lbl, - ASCII True (_UNPK_ s)], - ImmCLbl lbl) + getData (StString s) = panic "MachCode.stmtToInstrs: unlifted StString" -- the linker can handle simple arithmetic... getData (StIndex rep (StCLbl lbl) (StInt off)) = - returnNat (nilOL, - ImmIndex lbl (fromInteger (off * sizeOf rep))) + returnNat (nilOL, + ImmIndex lbl (fromInteger off * 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 @@ -128,6 +205,7 @@ derefDLL tree 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 @@ -148,19 +226,23 @@ mangleIndexTree :: StixTree -> StixTree mangleIndexTree (StIndex pk base (StInt i)) = StPrim IntAddOp [base, off] where - off = StInt (i * sizeOf pk) + off = StInt (i * toInteger (sizeOf pk)) mangleIndexTree (StIndex pk base off) = StPrim IntAddOp [ base, let s = shift pk - in ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk))) - if s == 0 then off else StPrim SllOp [off, StInt s] + in if s == 0 then off else StPrim SllOp [off, StInt (toInteger s)] ] where - shift DoubleRep = 3::Integer - shift CharRep = 0::Integer - shift _ = IF_ARCH_alpha(3,2) + shift :: PrimRep -> Int + shift rep = case 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} @@ -169,7 +251,7 @@ maybeImm :: StixTree -> Maybe Imm maybeImm (StCLbl l) = Just (ImmCLbl l) maybeImm (StIndex rep (StCLbl l) (StInt off)) - = Just (ImmIndex l (fromInteger (off * sizeOf rep))) + = Just (ImmIndex l (fromInteger off * sizeOf rep)) maybeImm (StInt i) | i >= toInteger minInt && i <= toInteger maxInt = Just (ImmInt (fromInteger i)) @@ -241,7 +323,7 @@ getRegister (StReg (StixMagicId stgreg)) -- cannae be Nothing getRegister (StReg (StixTemp u pk)) - = returnNat (Fixed pk (UnmappedReg u pk) nilOL) + = returnNat (Fixed pk (mkVReg u pk) nilOL) getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree) @@ -259,7 +341,7 @@ getRegister (StString s) imm_lbl = ImmCLbl lbl code dst = toOL [ - SEGMENT DataSegment, + SEGMENT RoDataSegment, LABEL lbl, ASCII True (_UNPK_ s), SEGMENT TextSegment, @@ -316,7 +398,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps Double2FloatOp -> coerceFltCode x Float2DoubleOp -> coerceFltCode x - other_op -> getRegister (StCall fn cCallConv DoubleRep [x]) + other_op -> getRegister (StCall fn CCallConv DoubleRep [x]) where fn = case other_op of FloatExpOp -> SLIT("exp") @@ -396,6 +478,9 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps IntQuotOp -> trivialCode (DIV Q False) x y IntRemOp -> trivialCode (REM Q False) x y + WordAddOp -> trivialCode (ADD Q False) x y + WordSubOp -> trivialCode (SUB Q False) x y + WordMulOp -> trivialCode (MUL Q False) x y WordQuotOp -> trivialCode (DIV Q True) x y WordRemOp -> trivialCode (REM Q True) x y @@ -419,8 +504,8 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra" ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl" - FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y]) - DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y]) + FloatPowerOp -> getRegister (StCall 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 @@ -508,6 +593,19 @@ getRegister leaf -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #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 @@ -537,7 +635,7 @@ getRegister (StScratchWord i) = getDeltaNat `thenNat` \ current_stack_offset -> let j = i+1 - (current_stack_offset `div` 4) code dst - = unitOL (LEA L (OpAddr (spRel (j+1))) (OpReg dst)) + = unitOL (LEA L (OpAddr (spRel j)) (OpReg dst)) in returnNat (Any PtrRep code) @@ -573,12 +671,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps 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 [x]) + getRegister (StCall fn CCallConv DoubleRep [x]) where (is_float_op, fn) = case primop of @@ -652,12 +745,16 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps DoubleLtOp -> condFltReg LTT x y DoubleLeOp -> condFltReg LE x y - IntAddOp -> add_code L x y - IntSubOp -> sub_code L x y - IntQuotOp -> quot_code L x y True{-division-} - IntRemOp -> quot_code L x y False{-remainder-} + 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 @@ -683,10 +780,10 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps ISraOp -> shift_code (SAR L) x y {-False-} ISrlOp -> shift_code (SHR L) x y {-False-} - FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep + FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [promote x, promote y]) where promote x = StPrim Float2DoubleOp [x] - DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep + DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x, y]) other -> pprPanic "getRegister(x86,dyadic primop)" @@ -821,41 +918,6 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps sub_code sz x y = trivialCode (SUB sz) Nothing x y - -------------------- - quot_code - :: Size - -> StixTree -> StixTree - -> Bool -- True => division, False => remainder operation - -> NatM Register - - -- x must go into eax, edx must be a sign-extension of eax, and y - -- should go in some other register (or memory), so that we get - -- edx:eax / reg -> eax (remainder in edx). Currently we choose - -- to put y on the C stack, since that avoids tying up yet another - -- precious register. - - quot_code sz x y is_division - = getRegister x `thenNat` \ register1 -> - getRegister y `thenNat` \ register2 -> - getNewRegNCG IntRep `thenNat` \ tmp -> - getDeltaNat `thenNat` \ delta -> - let - code1 = registerCode register1 tmp - src1 = registerName register1 tmp - code2 = registerCode register2 tmp - src2 = registerName register2 tmp - code__2 = code2 `snocOL` -- src2 := y - PUSH L (OpReg src2) `snocOL` -- -4(%esp) := y - DELTA (delta-4) `appOL` - code1 `snocOL` -- src1 := x - MOV L (OpReg src1) (OpReg eax) `snocOL` -- eax := x - CLTD `snocOL` - IDIV sz (OpAddr (spRel 0)) `snocOL` - ADD L (OpImm (ImmInt 4)) (OpReg esp) `snocOL` - DELTA delta - in - returnNat (Fixed IntRep (if is_division then eax else edx) code__2) - ----------------------- getRegister (StInd pk mem) = getAmode mem `thenNat` \ amode -> @@ -866,9 +928,14 @@ getRegister (StInd pk mem) code__2 dst = code `snocOL` if pk == DoubleRep || pk == FloatRep then GLD size src dst - else case size of - L -> MOV L (OpAddr src) (OpReg dst) - B -> MOVZxL B (OpAddr src) (OpReg dst) + else (case size of + B -> MOVSxL B + Bu -> MOVZxL Bu + W -> MOVSxL W + Wu -> MOVZxL Wu + L -> MOV L + Lu -> MOV L) + (OpAddr src) (OpReg dst) in returnNat (Any pk code__2) @@ -898,6 +965,19 @@ getRegister leaf -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #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 -> @@ -911,33 +991,42 @@ getRegister (StDouble d) in returnNat (Any DoubleRep code) +-- The 6-word scratch area is immediately below the frame pointer. +-- Below that is the spill area. +getRegister (StScratchWord i) + | i >= 0 && i < 6 + = let + 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 + IntNegOp -> trivialUCode (SUB False False g0) x + NotOp -> trivialUCode (XNOR False g0) x - DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) 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 + OrdOp -> coerceIntCode IntRep x + ChrOp -> chrCode x - Float2IntOp -> coerceFP2Int x - Int2FloatOp -> coerceInt2FP FloatRep x - Double2IntOp -> coerceFP2Int x - Int2DoubleOp -> coerceInt2FP DoubleRep 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 + fixed_x = if is_float_op -- promote to double + then StPrim Float2DoubleOp [x] + else x in - getRegister (StCall fn cCallConv DoubleRep [x]) + getRegister (StCall fn CCallConv DoubleRep [fixed_x]) where (is_float_op, fn) = case primop of @@ -959,7 +1048,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps DoubleExpOp -> (False, SLIT("exp")) DoubleLogOp -> (False, SLIT("log")) - DoubleSqrtOp -> (True, SLIT("sqrt")) + DoubleSqrtOp -> (False, SLIT("sqrt")) DoubleSinOp -> (False, SLIT("sin")) DoubleCosOp -> (False, SLIT("cos")) @@ -972,7 +1061,10 @@ getRegister (StPrim primop [x]) -- unary PrimOps DoubleSinhOp -> (False, SLIT("sinh")) DoubleCoshOp -> (False, SLIT("cosh")) DoubleTanhOp -> (False, SLIT("tanh")) - _ -> panic ("Monadic PrimOp not handled: " ++ show primop) + + other + -> pprPanic "getRegister(sparc,monadicprimop)" + (pprStixTree (StPrim primop [x])) getRegister (StPrim primop [x, y]) -- dyadic PrimOps = case primop of @@ -1022,9 +1114,13 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps 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 + 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 @@ -1042,16 +1138,22 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps SllOp -> trivialCode SLL x y SrlOp -> trivialCode SRL x y - ISllOp -> trivialCode SLL x y --was: panic "SparcGen:isll" - ISraOp -> trivialCode SRA x y --was: panic "SparcGen:isra" - ISrlOp -> trivialCode SRL x y --was: panic "SparcGen:isrl" + 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]) + 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]) --- _ -> panic "Prim op " ++ (showPrimOp primop) ++ " not handled!" + 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]) + imul_div fn x y = getRegister (StCall fn CCallConv IntRep [x, y]) getRegister (StInd pk mem) = getAmode mem `thenNat` \ amode -> @@ -1079,6 +1181,8 @@ getRegister leaf 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 @@ -1508,7 +1612,6 @@ condFltCode cond x y code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 - pk2 = registerRep register2 code2 = registerCode register2 tmp2 src2 = registerName register2 tmp2 @@ -1717,7 +1820,13 @@ assignIntCode pk dst (StInd pks src) c_dst = registerCode reg_dst tmp -- should be empty r_dst = registerName reg_dst tmp szs = primRepToSize pks - opc = case szs of L -> MOV L ; B -> MOVZxL B + 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` @@ -1938,7 +2047,7 @@ branch instruction. Other CLabels are assumed to be far away. register allocator. \begin{code} -genJump :: StixTree{-the branch target-} -> NatM InstrBlock +genJump :: DestInfo -> StixTree{-the branch target-} -> NatM InstrBlock #if alpha_TARGET_ARCH @@ -1949,7 +2058,7 @@ genJump (StCLbl lbl) target = ImmCLbl lbl genJump tree - = getRegister tree `thenNat` \ register -> + = getRegister tree `thenNat` \ register -> getNewRegNCG PtrRep `thenNat` \ tmp -> let dst = registerName register pv @@ -1965,17 +2074,17 @@ genJump tree -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH -genJump (StInd pk mem) +genJump dsts (StInd pk mem) = getAmode mem `thenNat` \ amode -> let code = amodeCode amode target = amodeAddr amode in - returnNat (code `snocOL` JMP (OpAddr target)) + returnNat (code `snocOL` JMP dsts (OpAddr target)) -genJump tree +genJump dsts tree | maybeToBool imm - = returnNat (unitOL (JMP (OpImm target))) + = returnNat (unitOL (JMP dsts (OpImm target))) | otherwise = getRegister tree `thenNat` \ register -> @@ -1984,7 +2093,7 @@ genJump tree code = registerCode register tmp target = registerName register tmp in - returnNat (code `snocOL` JMP (OpReg target)) + returnNat (code `snocOL` JMP dsts (OpReg target)) where imm = maybeImm tree target = case imm of Just x -> x @@ -1993,20 +2102,21 @@ genJump tree -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH -genJump (StCLbl lbl) - | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP]) - | otherwise = returnNat (toOL [CALL target 0 True, NOP]) +genJump dsts (StCLbl lbl) + | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts" + | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP]) + | otherwise = returnNat (toOL [CALL target 0 True, NOP]) where target = ImmCLbl lbl -genJump tree +genJump dsts tree = getRegister tree `thenNat` \ register -> getNewRegNCG PtrRep `thenNat` \ tmp -> let code = registerCode register tmp target = registerName register tmp in - returnNat (code `snocOL` JMP (AddrRegReg target g0) `snocOL` NOP) + returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP) #endif {- sparc_TARGET_ARCH -} \end{code} @@ -2192,7 +2302,6 @@ genCondJump lbl bool let code = condCode condition cond = condName condition - target = ImmCLbl lbl in returnNat (code `snocOL` JXX cond lbl) @@ -2235,7 +2344,7 @@ register allocator. \begin{code} genCCall :: FAST_STRING -- function to call - -> CallConv + -> CCallConv -> PrimRep -- type of the result -> [StixTree] -- arguments (of mixed type) -> NatM InstrBlock @@ -2329,11 +2438,17 @@ genCCall fn cconv kind args let (sizes, codes) = unzip sizes_n_codes tot_arg_size = sum sizes code2 = concatOL codes - call = toOL [ - CALL fn__2, - ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp), - DELTA (delta + tot_arg_size) - ] + call = toOL ( + [CALL (fn__2 tot_arg_size)] + ++ + -- Deallocate parameters after call for ccall; + -- but not for stdcall (callee does it) + (if cconv == StdCallConv then [] else + [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)]) + ++ + + [DELTA (delta + tot_arg_size)] + ) in setDeltaNat (delta + tot_arg_size) `thenNat` \ _ -> returnNat (code2 `appOL` call) @@ -2343,12 +2458,19 @@ genCCall fn cconv kind args -- internally generated names like '.mul,' which don't get an -- underscore prefix -- ToDo:needed (WDP 96/03) ??? - fn__2 = case (_HEAD_ fn) of - '.' -> ImmLit (ptext fn) - _ -> ImmLab False (ptext fn) + fn_u = _UNPK_ fn + fn__2 tot_arg_size + | head fn_u == '.' + = ImmLit (text (fn_u ++ stdcallsize tot_arg_size)) + | otherwise -- General case + = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size)) + + stdcallsize tot_arg_size + | cconv == StdCallConv = '@':show tot_arg_size + | otherwise = "" arg_size DF = 8 - arg_size F = 8 + arg_size F = 4 arg_size _ = 4 ------------ @@ -2363,9 +2485,9 @@ genCCall fn cconv kind args if (case sz of DF -> True; F -> True; _ -> False) then returnNat (size, code `appOL` - toOL [SUB L (OpImm (ImmInt 8)) (OpReg esp), + toOL [SUB L (OpImm (ImmInt size)) (OpReg esp), DELTA (delta-size), - GST DF reg (AddrBaseIndex (Just esp) + GST sz reg (AddrBaseIndex (Just esp) Nothing (ImmInt 0))] ) @@ -2394,101 +2516,125 @@ genCCall fn cconv kind args #endif {- i386_TARGET_ARCH -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH +{- + The SPARC calling convention is an absolute + nightmare. The first 6x32 bits of arguments are mapped into + %o0 through %o5, and the remaining arguments are dumped to the + stack, beginning at [%sp+92]. (Note that %o6 == %sp.) + + If we have to put args on the stack, move %o6==%sp down by + the number of words to go on the stack, to ensure there's enough space. + + According to Fraser and Hanson's lcc book, page 478, fig 17.2, + 16 words above the stack pointer is a word for the address of + a structure return value. I use this as a temporary location + for moving values from float to int regs. Certainly it isn't + safe to put anything in the 16 words starting at %sp, since + this area can get trashed at any time due to window overflows + caused by signal handlers. + + A final complication (if the above isn't enough) is that + we can't blithely calculate the arguments one by one into + %o0 .. %o5. Consider the following nested calls: + + fff a (fff b c) + + Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately + the inner call will itself use %o0, which trashes the value put there + in preparation for the outer call. Upshot: we need to calculate the + args into temporary regs, and move those to arg regs or onto the + stack only immediately prior to the call proper. Sigh. +-} genCCall fn cconv kind args - = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args - `thenNat` \ ((unused,_), argCode) -> - let - nRegs = length allArgRegs - length unused - call = CALL fn__2 nRegs False - code = concatOL argCode - in - returnNat (code `snocOL` call `snocOL` NOP) + = 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) - - ------------------------------------ - {- 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 - -> NatM (([Reg],Int), InstrBlock) -- Updated accumulator and code - - -- We have to use up all of our argument registers first... - - get_arg (dst:dsts, offset) arg - = getRegister arg `thenNat` \ register -> - getNewRegNCG (registerRep register) - `thenNat` \ tmp -> - let - reg = if isFloatingRep pk then tmp else dst - code = registerCode register reg - src = registerName register reg - pk = registerRep register - in - returnNat ( - case pk of - DoubleRep -> - case dsts of - [] -> ( ([], offset + 1), - code `snocOL` - -- conveniently put the second part in the right stack - -- location, and load the first part into %o5 - ST DF src (spRel (offset - 1)) `snocOL` - LD W (spRel (offset - 1)) dst - ) - (dst__2:dsts__2) - -> ( (dsts__2, offset), - code `snocOL` - ST DF src (spRel (-2)) `snocOL` - LD W (spRel (-2)) dst `snocOL` - LD W (spRel (-1)) dst__2 - ) - FloatRep - -> ( (dsts, offset), - code `snocOL` - ST F src (spRel (-2)) `snocOL` - LD W (spRel (-2)) dst - ) - _ -> ( (dsts, offset), - if isFixed register - then code `snocOL` OR False g0 (RIReg src) dst - else code - ) - ) - -- Once we have run out of argument registers, we move to the - -- stack... - - get_arg ([], offset) arg - = getRegister arg `thenNat` \ register -> - getNewRegNCG (registerRep register) - `thenNat` \ tmp -> - let - code = registerCode register tmp - src = registerName register tmp - pk = registerRep register - sz = primRepToSize pk - words = if pk == DoubleRep then 2 else 1 - in - returnNat ( ([], offset + words), - code `snocOL` ST sz src (spRel offset) ) - + -- function names that begin with '.' are assumed to be special + -- internally generated names like '.mul,' which don't get an + -- underscore prefix + -- ToDo:needed (WDP 96/03) ??? + fn__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} @@ -2935,7 +3081,7 @@ trivialFCode pk instr x y code2 `snocOL` instr (primRepToSize pk) tmp1 src2 dst in - returnNat (Any DoubleRep code__2) + returnNat (Any pk code__2) ------------- @@ -3182,14 +3328,16 @@ coerceFP2Int x %* * %************************************************************************ -Integer to character conversion. Where applicable, we try to do this -in one step if the original object is in memory. +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 -> @@ -3206,47 +3354,23 @@ chrCode x chrCode x = getRegister x `thenNat` \ register -> - let - code__2 dst = let - code = registerCode register dst - src = registerName register dst - in code `appOL` - if isFixed register && src /= dst - then toOL [MOV L (OpReg src) (OpReg dst), - AND L (OpImm (ImmInt 255)) (OpReg dst)] - else unitOL (AND L (OpImm (ImmInt 255)) (OpReg src)) - in - returnNat (Any IntRep code__2) + 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 (StInd pk mem) - = getAmode mem `thenNat` \ amode -> - let - code = amodeCode amode - src = amodeAddr amode - src_off = addrOffset src 3 - src__2 = case src_off of Just x -> x - code__2 dst = if maybeToBool src_off then - code `snocOL` LD BU src__2 dst - else - code `snocOL` - LD (primRepToSize pk) src dst `snocOL` - AND False dst (RIImm (ImmInt 255)) dst - in - returnNat (Any pk code__2) - chrCode x = getRegister x `thenNat` \ register -> - getNewRegNCG IntRep `thenNat` \ reg -> - let - code = registerCode register reg - src = registerName register reg - code__2 dst = code `snocOL` AND False src (RIImm (ImmInt 255)) dst - in - returnNat (Any IntRep code__2) + returnNat ( + case register of + Fixed _ reg code -> Fixed IntRep reg code + Any _ code -> Any IntRep code + ) #endif {- sparc_TARGET_ARCH -} \end{code}