X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FMachCode.lhs;h=9117e784ed75ad94b2b668db3c367733112ce80e;hb=03aa2ef64390090c64d0fcf81b1050a9f3a4a452;hp=5939f60282f71605d2c9d14f0391535ac4acfaf9;hpb=9e358c7e473ea6fdf8766b4944bc827adc41e5f0;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index 5939f60..9117e78 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" @@ -19,12 +19,11 @@ import MachRegs import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL, snocOL, consOL, concatOL ) import AbsCUtils ( magicIdPrimRep ) -import CallConv ( CallConv ) +import ForeignCall ( CCallConv(..) ) 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, @@ -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)) @@ -92,20 +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 @@ -150,7 +226,7 @@ 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 [ @@ -160,7 +236,7 @@ mangleIndexTree (StIndex pk base off) ] where shift :: PrimRep -> Int - shift rep = case (fromInteger (sizeOf rep) :: Int) of + shift rep = case sizeOf rep of 1 -> 0 2 -> 1 4 -> 2 @@ -175,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)) @@ -322,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") @@ -381,7 +457,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps AddrNeOp -> int_NE_code x y AddrLtOp -> trivialCode (CMP ULT) x y AddrLeOp -> trivialCode (CMP ULE) x y - + FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y @@ -402,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 @@ -415,6 +494,10 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y + AddrAddOp -> trivialCode (ADD Q False) x y + AddrSubOp -> trivialCode (SUB Q False) x y + AddrRemOp -> trivialCode (REM Q True) x y + AndOp -> trivialCode AND x y OrOp -> trivialCode OR x y XorOp -> trivialCode XOR x y @@ -425,8 +508,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 @@ -556,7 +639,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) @@ -592,7 +675,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps Int2DoubleOp -> coerceInt2FP DoubleRep x other_op -> - getRegister (StCall fn cCallConv DoubleRep [x]) + getRegister (StCall fn CCallConv DoubleRep [x]) where (is_float_op, fn) = case primop of @@ -666,12 +749,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 + 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 @@ -682,6 +769,10 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps DoubleMulOp -> trivialFCode DoubleRep GMUL x y DoubleDivOp -> trivialFCode DoubleRep GDIV x y + AddrAddOp -> add_code L x y + AddrSubOp -> sub_code L x y + AddrRemOp -> trivialCode (IREM L) Nothing 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 @@ -697,10 +788,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)" @@ -845,9 +936,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) - BU -> MOVZxL BU (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) @@ -907,8 +1003,8 @@ getRegister (StDouble d) -- Below that is the spill area. getRegister (StScratchWord i) | i >= 0 && i < 6 - = let j = i+1 - code dst = unitOL (fpRelEA j dst) + = let + code dst = unitOL (fpRelEA (i-6) dst) in returnNat (Any PtrRep code) @@ -938,7 +1034,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps then StPrim Float2DoubleOp [x] else x in - getRegister (StCall fn cCallConv DoubleRep [fixed_x]) + getRegister (StCall fn CCallConv DoubleRep [fixed_x]) where (is_float_op, fn) = case primop of @@ -1026,9 +1122,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 @@ -1040,20 +1140,24 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps DoubleMulOp -> trivialFCode DoubleRep FMUL x y DoubleDivOp -> trivialFCode DoubleRep FDIV x y + AddrAddOp -> trivialCode (ADD False False) x y + AddrSubOp -> trivialCode (SUB False False) x y + AddrRemOp -> imul_div SLIT(".rem") x y + AndOp -> trivialCode (AND False) x y OrOp -> trivialCode (OR False) x y XorOp -> trivialCode (XOR False) x y SllOp -> trivialCode SLL x y SrlOp -> trivialCode SRL x y - ISllOp -> trivialCode SLL x y --was: panic "SparcGen:isll" - ISraOp -> trivialCode SRA x y --was: panic "SparcGen:isra" - ISrlOp -> trivialCode SRL x y --was: panic "SparcGen:isrl" + ISllOp -> trivialCode SLL x y + ISraOp -> trivialCode SRA x y + ISrlOp -> trivialCode SRL x y - 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 @@ -1061,7 +1165,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps (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 -> @@ -1728,7 +1832,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 ; BU -> MOVZxL BU + 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` @@ -2246,7 +2356,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 @@ -2343,9 +2453,12 @@ genCCall fn cconv kind args call = toOL ( [CALL (fn__2 tot_arg_size)] ++ - (if cconv == stdCallConv then [] else + -- 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 @@ -2361,11 +2474,11 @@ genCCall fn cconv kind args fn__2 tot_arg_size | head fn_u == '.' = ImmLit (text (fn_u ++ stdcallsize tot_arg_size)) - | otherwise + | otherwise -- General case = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size)) stdcallsize tot_arg_size - | cconv == stdCallConv = '@':show tot_arg_size + | cconv == StdCallConv = '@':show tot_arg_size | otherwise = "" arg_size DF = 8