From: sewardj Date: Mon, 10 Dec 2001 18:04:52 +0000 (+0000) Subject: [project @ 2001-12-10 18:04:51 by sewardj] X-Git-Tag: Approximately_9120_patches~424 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=0d1a15fd5f3396ae711483b446c4b982083e5c87;p=ghc-hetmet.git [project @ 2001-12-10 18:04:51 by sewardj] Add just enough infrastructure to the NCG that it can deal with simple 64-bit code on 32-bit platforms. Main changes are: * Addition of a simple 64-bit instruction selection fn iselExpr64 to MachCode. This generates code for a 64-bit value and places the results into two virtual registers, related thusly: * Add a new type VRegUnique, which is used to label Stix virtual registers. This type used to be a plain Unique, but that forces the assumption that each Abstract-C level C temporary corresponds to exactly one Stix virtual register, which is untrue when the C temporary is 64-bit sized on a 32-bit machine. In the new scheme, the Unique for the C temporary can turn into two related VRegUniques, related by having the same embedded unique. * Made a start on 'target metrics' by adding ncg_target_is_32bits to the end of Stix.lhs. * Cleaned up numerous other gruesomenesses in the NCG which never came to light before now. Got rid of MachMisc.sizeOf, which doesn't make sense in a 64-bit setting, and replaced it by calls to PrimRep.getPrimRepArrayElemSize, which, as far as I'm concerned, is the definitive answer to the questio `How Big Is This PrimRep Really?' Result: on x86-linux, at least, you can now compile the Entire Prelude with -fasm! At this stage I cannot claim that the resulting code is correct, but it's a start. --- diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs index aee085a..90d2868 100644 --- a/ghc/compiler/nativeGen/AbsCStixGen.lhs +++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs @@ -33,7 +33,8 @@ import Literal ( Literal(..), word2IntLit ) import Maybes ( Maybe012(..), maybeToBool ) import StgSyn ( StgOp(..) ) import MachOp ( MachOp(..), resultRepsOfMachOp ) -import PrimRep ( isFloatingRep, PrimRep(..) ) +import PrimRep ( isFloatingRep, is64BitRep, + PrimRep(..), getPrimRepArrayElemSize ) import StixInfo ( genCodeInfoTable, genBitmapInfoTable, livenessIsSmall, bitmapToIntegers ) import StixMacro ( macroCode, checkCode ) @@ -237,8 +238,8 @@ Here we handle top-level things, like @CCodeBlock@s and -- We need to promote any item smaller than a word to a word promote_to_word pk - | sizeOf pk >= sizeOf IntRep = pk - | otherwise = IntRep + | getPrimRepArrayElemSize pk >= getPrimRepArrayElemSize IntRep = pk + | otherwise = IntRep upd_reqd = closureUpdReqd cl_info @@ -346,14 +347,23 @@ of the source? Be careful about floats/doubles. \begin{code} gencode (CAssign lhs rhs) - | getAmodeRep lhs == VoidRep = returnUs id + | lhs_rep == VoidRep + = returnUs id | otherwise - = let pk = getAmodeRep lhs - pk' = if mixedTypeLocn lhs && not (isFloatingRep pk) then IntRep else pk + = let -- This is a Hack. Should be cleaned up. + -- JRS, 10 Dec 01 + pk' | ncg_target_is_32bit && is64BitRep lhs_rep + = lhs_rep + | otherwise + = if mixedTypeLocn lhs && not (isFloatingRep lhs_rep) + then IntRep + else lhs_rep lhs' = a2stix lhs rhs' = a2stix' rhs in returnUs (\xs -> mkStAssign pk' lhs' rhs' : xs) + where + lhs_rep = getAmodeRep lhs \end{code} diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs index 2d65224..cf37bc9 100644 --- a/ghc/compiler/nativeGen/AsmCodeGen.lhs +++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs @@ -36,6 +36,8 @@ import MachMisc ( IF_ARCH_i386(i386_insert_ffrees,) ) import qualified Pretty import Outputable +-- DEBUGGING ONLY +--import OrdList \end{code} The 96/03 native-code generator has machine-independent and @@ -241,12 +243,18 @@ stixStmt_ConFold stmt StJump dsts addr -> StJump dsts (stixExpr_ConFold addr) StCondJump addr test - -> StCondJump addr (stixExpr_ConFold test) + -> let test_opt = stixExpr_ConFold test + in + if manifestlyZero test_opt + then StComment (_PK_ ("deleted: " ++ showSDoc (pprStixStmt stmt))) + else StCondJump addr (stixExpr_ConFold test) StData pk datas -> StData pk (map stixExpr_ConFold datas) other -> other - + where + manifestlyZero (StInt 0) = True + manifestlyZero other = False stixExpr_ConFold expr = case expr of diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.lhs b/ghc/compiler/nativeGen/AsmRegAlloc.lhs index bd2b111..744d1f6 100644 --- a/ghc/compiler/nativeGen/AsmRegAlloc.lhs +++ b/ghc/compiler/nativeGen/AsmRegAlloc.lhs @@ -271,7 +271,7 @@ spill slot numbers for the uniques. insertSpillCode :: [Instr] -> [Instr] insertSpillCode insns = let uniques_in_insns - = map getUnique + = map getVRegUnique (regSetToList (foldl unionRegSets emptyRegSet (map vregs_in_insn insns))) @@ -279,7 +279,7 @@ insertSpillCode insns = case regUsage i of RU rds wrs -> filterRegSet isVirtualReg (rds `unionRegSets` wrs) - vreg_to_slot_map :: FiniteMap Unique Int + vreg_to_slot_map :: FiniteMap VRegUnique Int vreg_to_slot_map = listToFM (zip uniques_in_insns [0..]) @@ -297,7 +297,7 @@ insertSpillCode insns -- to the stack pointer, as opposed to the frame pointer. The other is a -- counter, used to manufacture new temporary register names. -patchInstr :: FiniteMap Unique Int -> (Int,Int) -> Instr -> ((Int,Int), [Instr]) +patchInstr :: FiniteMap VRegUnique Int -> (Int,Int) -> Instr -> ((Int,Int), [Instr]) patchInstr vreg_to_slot_map (delta,ctr) instr | null memSrcs && null memDsts @@ -330,13 +330,15 @@ patchInstr vreg_to_slot_map (delta,ctr) instr | isVirtualReg vreg = case [vi | (vreg', vi) <- vreg_env, vreg' == vreg] of [i] -> case regClass vreg of - RcInteger -> VirtualRegI (mkPseudoUnique3 i) - RcFloat -> VirtualRegF (mkPseudoUnique3 i) - RcDouble -> VirtualRegD (mkPseudoUnique3 i) + RcInteger -> VirtualRegI (pseudoVReg i) + RcFloat -> VirtualRegF (pseudoVReg i) + RcDouble -> VirtualRegD (pseudoVReg i) _ -> pprPanic "patchInstr: unmapped VReg" (ppr vreg) | otherwise = vreg + pseudoVReg i = VRegUniqueLo (mkPseudoUnique3 i) + memSrcs = filter isVirtualReg (regSetToList srcs) memDsts = filter isVirtualReg (regSetToList dsts) diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index a8595f1..f6226e4 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -14,6 +14,7 @@ module MachCode ( stmtsToInstrs, InstrBlock ) where #include "HsVersions.h" #include "nativeGen/NCG.h" +import Unique ( Unique ) import MachMisc -- may differ per-platform import MachRegs import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL, @@ -27,25 +28,27 @@ import CLabel ( CLabel, labelDynamic ) import CLabel ( isAsmTemp ) #endif import Maybes ( maybeToBool, Maybe012(..) ) -import PrimRep ( isFloatingRep, PrimRep(..) ) +import PrimRep ( isFloatingRep, is64BitRep, PrimRep(..), + getPrimRepArrayElemSize ) import Stix ( getNatLabelNCG, StixStmt(..), StixExpr(..), - StixReg(..), StixVReg(..), CodeSegment(..), + StixReg(..), pprStixReg, StixVReg(..), CodeSegment(..), DestInfo, hasDestInfo, - pprStixExpr, + pprStixExpr, repOfStixExpr, liftStrings, NatM, thenNat, returnNat, mapNat, mapAndUnzipNat, mapAccumLNat, - getDeltaNat, setDeltaNat, - ncgPrimopMoan + getDeltaNat, setDeltaNat, getUniqueNat, + ncgPrimopMoan, + ncg_target_is_32bit ) import Pretty import Outputable ( panic, pprPanic, showSDoc ) import qualified Outputable import CmdLineOpts ( opt_Static ) +import Stix ( pprStixStmt ) -- DEBUGGING ONLY import IOExts ( trace ) -import Stix ( pprStixStmt ) infixr 3 `bind` \end{code} @@ -92,9 +95,13 @@ stmtToInstrs stmt = case stmt of StAssignMem pk addr src | isFloatingRep pk -> assignMem_FltCode pk (derefDLL addr) (derefDLL src) + | ncg_target_is_32bit + && is64BitRep pk -> assignMem_I64Code (derefDLL addr) (derefDLL src) | otherwise -> assignMem_IntCode pk (derefDLL addr) (derefDLL src) StAssignReg pk reg src | isFloatingRep pk -> assignReg_FltCode pk reg (derefDLL src) + | ncg_target_is_32bit + && is64BitRep pk -> assignReg_I64Code reg (derefDLL src) | otherwise -> assignReg_IntCode pk reg (derefDLL src) StAssignMachOp lhss mop rhss -> assignMachOp lhss mop rhss @@ -119,7 +126,7 @@ stmtToInstrs stmt = case stmt of -- the linker can handle simple arithmetic... getData (StIndex rep (StCLbl lbl) (StInt off)) = returnNat (nilOL, - ImmIndex lbl (fromInteger off * sizeOf rep)) + ImmIndex lbl (fromInteger off * getPrimRepArrayElemSize rep)) -- Top-level lifted-out string. The segment will already have been set -- (see Stix.liftStrings). @@ -172,7 +179,7 @@ mangleIndexTree :: StixExpr -> StixExpr mangleIndexTree (StIndex pk base (StInt i)) = StMachOp MO_Nat_Add [base, off] where - off = StInt (i * toInteger (sizeOf pk)) + off = StInt (i * toInteger (getPrimRepArrayElemSize pk)) mangleIndexTree (StIndex pk base off) = StMachOp MO_Nat_Add [ @@ -182,7 +189,7 @@ mangleIndexTree (StIndex pk base off) ] where shift :: PrimRep -> Int - shift rep = case sizeOf rep of + shift rep = case getPrimRepArrayElemSize rep of 1 -> 0 2 -> 1 4 -> 2 @@ -197,7 +204,7 @@ maybeImm :: StixExpr -> Maybe Imm maybeImm (StCLbl l) = Just (ImmCLbl l) maybeImm (StIndex rep (StCLbl l) (StInt off)) - = Just (ImmIndex l (fromInteger off * sizeOf rep)) + = Just (ImmIndex l (fromInteger off * getPrimRepArrayElemSize rep)) maybeImm (StInt i) | i >= toInteger (minBound::Int) && i <= toInteger (maxBound::Int) = Just (ImmInt (fromInteger i)) @@ -209,6 +216,132 @@ maybeImm _ = Nothing %************************************************************************ %* * +\subsection{The @Register64@ type} +%* * +%************************************************************************ + +Simple support for generating 64-bit code (ie, 64 bit values and 64 +bit assignments) on 32-bit platforms. Unlike the main code generator +we merely shoot for generating working code as simply as possible, and +pay little attention to code quality. Specifically, there is no +attempt to deal cleverly with the fixed-vs-floating register +distinction; all values are generated into (pairs of) floating +registers, even if this would mean some redundant reg-reg moves as a +result. Only one of the VRegUniques is returned, since it will be +of the VRegUniqueLo form, and the upper-half VReg can be determined +by applying getHiVRegFromLo to it. + +\begin{code} + +data ChildCode64 -- a.k.a "Register64" + = ChildCode64 + InstrBlock -- code + VRegUnique -- unique for the lower 32-bit temporary + -- which contains the result; use getHiVRegFromLo to find + -- the other VRegUnique. + -- Rules of this simplified insn selection game are + -- therefore that the returned VRegUniques may be modified + +assignMem_I64Code :: StixExpr -> StixExpr -> NatM InstrBlock +assignReg_I64Code :: StixReg -> StixExpr -> NatM InstrBlock +iselExpr64 :: StixExpr -> NatM ChildCode64 + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +#if i386_TARGET_ARCH + +assignMem_I64Code addrTree valueTree + = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) -> + getRegister addrTree `thenNat` \ register_addr -> + getNewRegNCG IntRep `thenNat` \ t_addr -> + let rlo = VirtualRegI vrlo + rhi = getHiVRegFromLo rlo + code_addr = registerCode register_addr t_addr + reg_addr = registerName register_addr t_addr + -- Little-endian store + mov_lo = MOV L (OpReg rlo) + (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0))) + mov_hi = MOV L (OpReg rhi) + (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4))) + in + returnNat (vcode `appOL` code_addr `snocOL` mov_lo `snocOL` mov_hi) + +assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree + = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) -> + let + r_dst_lo = mkVReg u_dst IntRep + r_src_lo = VirtualRegI vr_src_lo + r_dst_hi = getHiVRegFromLo r_dst_lo + r_src_hi = getHiVRegFromLo r_src_lo + mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo) + mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi) + in + returnNat ( + vcode `snocOL` mov_lo `snocOL` mov_hi + ) + +assignReg_I64Code lvalue valueTree + = pprPanic "assignReg_I64Code(i386): invalid lvalue" + (pprStixReg lvalue) + + + +iselExpr64 (StInd pk addrTree) + | is64BitRep pk + = getRegister addrTree `thenNat` \ register_addr -> + getNewRegNCG IntRep `thenNat` \ t_addr -> + getNewRegNCG IntRep `thenNat` \ rlo -> + let rhi = getHiVRegFromLo rlo + code_addr = registerCode register_addr t_addr + reg_addr = registerName register_addr t_addr + mov_lo = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 0))) + (OpReg rlo) + mov_hi = MOV L (OpAddr (AddrBaseIndex (Just reg_addr) Nothing (ImmInt 4))) + (OpReg rhi) + in + returnNat ( + ChildCode64 (code_addr `snocOL` mov_lo `snocOL` mov_hi) + (getVRegUnique rlo) + ) + +iselExpr64 (StReg (StixTemp (StixVReg vu pk))) + | is64BitRep pk + = getNewRegNCG IntRep `thenNat` \ r_dst_lo -> + let r_dst_hi = getHiVRegFromLo r_dst_lo + r_src_lo = mkVReg vu IntRep + r_src_hi = getHiVRegFromLo r_src_lo + mov_lo = MOV L (OpReg r_src_lo) (OpReg r_dst_lo) + mov_hi = MOV L (OpReg r_src_hi) (OpReg r_dst_hi) + in + returnNat ( + ChildCode64 (toOL [mov_lo, mov_hi]) (getVRegUnique r_dst_lo) + ) + +iselExpr64 (StCall fn cconv kind args) + | is64BitRep kind + = genCCall fn cconv kind args `thenNat` \ call -> + getNewRegNCG IntRep `thenNat` \ r_dst_lo -> + let r_dst_hi = getHiVRegFromLo r_dst_lo + mov_lo = MOV L (OpReg eax) (OpReg r_dst_lo) + mov_hi = MOV L (OpReg edx) (OpReg r_dst_hi) + in + returnNat ( + ChildCode64 (call `snocOL` mov_lo `snocOL` mov_hi) + (getVRegUnique r_dst_lo) + ) + +iselExpr64 expr + = pprPanic "iselExpr64(i386)" (pprStixExpr expr) + +#endif {- i386_TARGET_ARCH -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + +\end{code} + +%************************************************************************ +%* * \subsection{The @Register@ type} %* * %************************************************************************ @@ -292,6 +425,7 @@ getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree) getRegister (StCall fn cconv kind args) + | not (ncg_target_is_32bit && is64BitRep kind) = genCCall fn cconv kind args `thenNat` \ call -> returnNat (Fixed kind reg call) where @@ -895,6 +1029,7 @@ getRegister (StMachOp mop [x, y]) -- dyadic MachOps sub_code sz x y = trivialCode (SUB sz) Nothing x y getRegister (StInd pk mem) + | not (is64BitRep pk) = getAmode mem `thenNat` \ amode -> let code = amodeCode amode @@ -1477,6 +1612,8 @@ getCondCode (StMachOp mop [x, y]) other -> pprPanic "getCondCode(x86,sparc)" (pprMachOp mop) +getCondCode other = pprPanic "getCondCode(2)(x86,sparc)" (pprStixExpr other) + #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -} \end{code} @@ -2407,7 +2544,7 @@ genCCall fn cconv kind args -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH -genCCall fn cconv kind [StInt i] +genCCall fn cconv ret_rep [StInt i] | fn == SLIT ("PerformGC_wrapper") = let call = toOL [ MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax), @@ -2419,8 +2556,8 @@ genCCall fn cconv kind [StInt i] returnNat call -genCCall fn cconv kind args - = mapNat get_call_arg +genCCall fn cconv ret_rep args + = mapNat push_arg (reverse args) `thenNat` \ sizes_n_codes -> getDeltaNat `thenNat` \ delta -> let (sizes, codes) = unzip sizes_n_codes @@ -2462,14 +2599,25 @@ genCCall fn cconv kind args arg_size _ = 4 ------------ - get_call_arg :: StixExpr{-current argument-} + push_arg :: StixExpr{-current argument-} -> NatM (Int, InstrBlock) -- argsz, code - get_call_arg arg - = get_op arg `thenNat` \ (code, reg, sz) -> - getDeltaNat `thenNat` \ delta -> - arg_size sz `bind` \ size -> - setDeltaNat (delta-size) `thenNat` \ _ -> + push_arg arg + | is64BitRep arg_rep + = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) -> + getDeltaNat `thenNat` \ delta -> + setDeltaNat (delta - 8) `thenNat` \ _ -> + let r_lo = VirtualRegI vr_lo + r_hi = getHiVRegFromLo r_lo + in returnNat (8, + toOL [PUSH L (OpReg r_hi), DELTA (delta - 4), + PUSH L (OpReg r_lo), DELTA (delta - 8)] + ) + | otherwise + = get_op arg `thenNat` \ (code, reg, sz) -> + getDeltaNat `thenNat` \ delta -> + arg_size sz `bind` \ size -> + setDeltaNat (delta-size) `thenNat` \ _ -> if (case sz of DF -> True; F -> True; _ -> False) then returnNat (size, code `appOL` @@ -2484,6 +2632,9 @@ genCCall fn cconv kind args PUSH L (OpReg reg) `snocOL` DELTA (delta-size) ) + where + arg_rep = repOfStixExpr arg + ------------ get_op :: StixExpr diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs index ce88dd3..4aa230b 100644 --- a/ghc/compiler/nativeGen/MachMisc.lhs +++ b/ghc/compiler/nativeGen/MachMisc.lhs @@ -8,7 +8,7 @@ module MachMisc ( - sizeOf, primRepToSize, + primRepToSize, eXTRA_STK_ARGS_HERE, @@ -93,18 +93,6 @@ eXTRA_STK_ARGS_HERE % - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -Size of a @PrimRep@, in bytes. - -\begin{code} -sizeOf :: PrimRep -> Int{-in bytes-} -sizeOf pr = case primRepToSize pr of - IF_ARCH_alpha({B->1; Bu->1; {-W->2; Wu->2;-} L->4; {-SF->4;-} Q->8; TF->8},) - IF_ARCH_i386 ({B->1; Bu->1; W->2; Wu->2; L->4; Lu->4; F->4; DF->8; F80->10},) - IF_ARCH_sparc({B->1; Bu->1; W->4; F->4; DF->8},) -\end{code} - -% - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Now the volatile saves and restores. We add the basic guys to the list of ``user'' registers provided. Note that there are more basic registers on the restore list, because some are reloaded from diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs index 1e6d0b5..ca9530f 100644 --- a/ghc/compiler/nativeGen/MachRegs.lhs +++ b/ghc/compiler/nativeGen/MachRegs.lhs @@ -15,7 +15,8 @@ modules --- the pleasure has been foregone.) module MachRegs ( RegClass(..), regClass, - Reg(..), isRealReg, isVirtualReg, + VRegUnique(..), pprVRegUnique, getHiVRegFromLo, + Reg(..), isRealReg, isVirtualReg, getVRegUnique, allocatableRegs, argRegs, allArgRegs, callClobberedRegs, Imm(..), @@ -248,6 +249,26 @@ Virtual regs can be of either class, so that info is attached. \begin{code} +data VRegUnique + = VRegUniqueLo Unique -- lower part of a split quantity + | VRegUniqueHi Unique -- upper part thereof + deriving (Eq, Ord) + +instance Show VRegUnique where + show (VRegUniqueLo u) = show u + show (VRegUniqueHi u) = "_hi_" ++ show u + +pprVRegUnique :: VRegUnique -> Outputable.SDoc +pprVRegUnique + = Outputable.text . show + +-- Determine the upper-half vreg for a 64-bit quantity on a 32-bit platform +-- when supplied with the vreg for the lower-half of the quantity. +getHiVRegFromLo (VirtualRegI (VRegUniqueLo u)) + = VirtualRegI (VRegUniqueHi u) +getHiVRegFromLo other + = pprPanic "getHiVRegFromLo" (ppr other) + data RegClass = RcInteger | RcFloat @@ -256,22 +277,29 @@ data RegClass data Reg = RealReg Int - | VirtualRegI Unique - | VirtualRegF Unique - | VirtualRegD Unique + | VirtualRegI VRegUnique + | VirtualRegF VRegUnique + | VirtualRegD VRegUnique unRealReg (RealReg i) = i unRealReg vreg = pprPanic "unRealReg on VirtualReg" (ppr vreg) +getVRegUnique :: Reg -> VRegUnique +getVRegUnique (VirtualRegI vu) = vu +getVRegUnique (VirtualRegF vu) = vu +getVRegUnique (VirtualRegD vu) = vu +getVRegUnique rreg = pprPanic "getVRegUnique on RealReg" (ppr rreg) + mkVReg :: Unique -> PrimRep -> Reg mkVReg u pk #if sparc_TARGET_ARCH = case pk of - FloatRep -> VirtualRegF u - DoubleRep -> VirtualRegD u - other -> VirtualRegI u + FloatRep -> VirtualRegF (VRegUniqueLo u) + DoubleRep -> VirtualRegD (VRegUniqueLo u) + other -> VirtualRegI (VRegUniqueLo u) #else - = if isFloatingRep pk then VirtualRegD u else VirtualRegI u + = if isFloatingRep pk then VirtualRegD (VRegUniqueLo u) + else VirtualRegI (VRegUniqueLo u) #endif isVirtualReg (RealReg _) = False @@ -314,19 +342,13 @@ instance Ord Reg where instance Show Reg where - showsPrec _ (RealReg i) = showString (showReg i) - showsPrec _ (VirtualRegI u) = showString "%vI_" . shows u - showsPrec _ (VirtualRegF u) = showString "%vF_" . shows u - showsPrec _ (VirtualRegD u) = showString "%vD_" . shows u + show (RealReg i) = showReg i + show (VirtualRegI u) = "%vI_" ++ show u + show (VirtualRegF u) = "%vF_" ++ show u + show (VirtualRegD u) = "%vD_" ++ show u instance Outputable Reg where ppr r = Outputable.text (show r) - -instance Uniquable Reg where - getUnique (RealReg i) = mkPseudoUnique2 i - getUnique (VirtualRegI u) = u - getUnique (VirtualRegF u) = u - getUnique (VirtualRegD u) = u \end{code} ** Machine-specific Reg stuff: ** diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs index b873dcd..c48b86f 100644 --- a/ghc/compiler/nativeGen/PprMach.lhs +++ b/ghc/compiler/nativeGen/PprMach.lhs @@ -51,8 +51,8 @@ pprReg :: IF_ARCH_i386(Size ->,) Reg -> Doc pprReg IF_ARCH_i386(s,) r = case r of RealReg i -> ppr_reg_no IF_ARCH_i386(s,) i - VirtualRegI u -> text "%vI_" <> asmSDoc (pprUnique u) - VirtualRegF u -> text "%vF_" <> asmSDoc (pprUnique u) + VirtualRegI u -> text "%vI_" <> asmSDoc (pprVRegUnique u) + VirtualRegF u -> text "%vF_" <> asmSDoc (pprVRegUnique u) where #if alpha_TARGET_ARCH ppr_reg_no :: Int -> Doc diff --git a/ghc/compiler/nativeGen/RegAllocInfo.lhs b/ghc/compiler/nativeGen/RegAllocInfo.lhs index f64ba40..8d82ae3 100644 --- a/ghc/compiler/nativeGen/RegAllocInfo.lhs +++ b/ghc/compiler/nativeGen/RegAllocInfo.lhs @@ -683,7 +683,7 @@ patchRegs instr env = case instr of JXX _ _ -> instr CALL _ -> instr CLTD -> instr - _ -> pprPanic "patchInstr(x86)" empty + _ -> pprPanic "patchRegs(x86)" empty where patch1 insn op = insn (patchOp op) @@ -753,9 +753,8 @@ patchRegs instr env = case instr of Spill to memory, and load it back... JRS, 000122: on x86, don't spill directly above the stack pointer, -since some insn sequences (int <-> conversions, and eventually -StixInteger) use this as a temp location. Leave 8 words (ie, 64 bytes -for a 64-bit arch) of slop. +since some insn sequences (int <-> conversions) use this as a temp +location. Leave 8 words (ie, 64 bytes for a 64-bit arch) of slop. \begin{code} spillSlotSize :: Int @@ -775,18 +774,18 @@ spillSlotToOffset slot = pprPanic "spillSlotToOffset:" (text "invalid spill location: " <> int slot) -vregToSpillSlot :: FiniteMap Unique Int -> Unique -> Int +vregToSpillSlot :: FiniteMap VRegUnique Int -> VRegUnique -> Int vregToSpillSlot vreg_to_slot_map u = case lookupFM vreg_to_slot_map u of Just xx -> xx - Nothing -> pprPanic "vregToSpillSlot: unmapped vreg" (ppr u) + Nothing -> pprPanic "vregToSpillSlot: unmapped vreg" (pprVRegUnique u) -spillReg, loadReg :: FiniteMap Unique Int -> Int -> Reg -> Reg -> Instr +spillReg, loadReg :: FiniteMap VRegUnique Int -> Int -> Reg -> Reg -> Instr spillReg vreg_to_slot_map delta dyn vreg | isVirtualReg vreg - = let slot_no = vregToSpillSlot vreg_to_slot_map (getUnique vreg) + = let slot_no = vregToSpillSlot vreg_to_slot_map (getVRegUnique vreg) off = spillSlotToOffset slot_no in {-Alpha: spill below the stack pointer (?)-} @@ -811,7 +810,7 @@ spillReg vreg_to_slot_map delta dyn vreg loadReg vreg_to_slot_map delta vreg dyn | isVirtualReg vreg - = let slot_no = vregToSpillSlot vreg_to_slot_map (getUnique vreg) + = let slot_no = vregToSpillSlot vreg_to_slot_map (getVRegUnique vreg) off = spillSlotToOffset slot_no in IF_ARCH_alpha( LD sz dyn (spRel (- (off `div` 8))) diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs index 951cfb6..4af4982 100644 --- a/ghc/compiler/nativeGen/Stix.lhs +++ b/ghc/compiler/nativeGen/Stix.lhs @@ -8,7 +8,7 @@ module Stix ( StixStmt(..), mkStAssign, StixStmtList, pprStixStmts, pprStixStmt, pprStixExpr, pprStixReg, stixStmt_CountTempUses, stixStmt_Subst, - liftStrings, + liftStrings, repOfStixExpr, DestInfo(..), hasDestInfo, stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, @@ -24,7 +24,10 @@ module Stix ( uniqOfNatM_State, deltaOfNatM_State, getUniqLabelNCG, getNatLabelNCG, - ncgPrimopMoan + ncgPrimopMoan, + + -- Information about the target arch + ncg_target_is_32bit ) where #include "HsVersions.h" @@ -34,15 +37,17 @@ import IOExts ( unsafePerformIO ) import IO ( hPutStrLn, stderr ) import AbsCSyn ( node, tagreg, MagicId(..) ) +import AbsCUtils ( magicIdPrimRep ) import ForeignCall ( CCallConv ) import CLabel ( mkAsmTempLabel, CLabel, pprCLabel ) import PrimRep ( PrimRep(..) ) -import MachOp ( MachOp(..), pprMachOp ) +import MachOp ( MachOp(..), pprMachOp, resultRepsOfMachOp ) import Unique ( Unique ) import SMRep ( fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize ) import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply, UniqSM, thenUs, returnUs, getUniqueUs ) import Maybes ( Maybe012(..), maybe012ToList ) +import Constants ( wORD_SIZE ) import Outputable import FastTypes \end{code} @@ -153,6 +158,23 @@ data StixExpr | StCall FAST_STRING CCallConv PrimRep [StixExpr] +-- What's the PrimRep of the value denoted by this StixExpr? +repOfStixExpr :: StixExpr -> PrimRep +repOfStixExpr (StInt _) = IntRep +repOfStixExpr (StFloat _) = FloatRep +repOfStixExpr (StDouble _) = DoubleRep +repOfStixExpr (StString _) = PtrRep +repOfStixExpr (StCLbl _) = PtrRep +repOfStixExpr (StReg reg) = repOfStixReg reg +repOfStixExpr (StIndex _ _ _) = PtrRep +repOfStixExpr (StInd rep _) = rep +repOfStixExpr (StCall target conv retrep args) = retrep +repOfStixExpr (StMachOp mop args) + = case resultRepsOfMachOp mop of + Just1 rep -> rep + other -> pprPanic "repOfStixExpr:StMachOp" (pprMachOp mop) + + -- used by insnFuture in RegAllocInfo.lhs data DestInfo = NoDestInfo -- no supplied dests; infer from context @@ -239,10 +261,13 @@ data StixReg pprStixReg (StixMagicId mid) = ppMId mid pprStixReg (StixTemp temp) = pprStixVReg temp +repOfStixReg (StixTemp (StixVReg u pr)) = pr +repOfStixReg (StixMagicId mid) = magicIdPrimRep mid + data StixVReg = StixVReg Unique PrimRep -pprStixVReg (StixVReg u pr) = hcat [text "VReg(", ppr u, ppr pr, char ')'] +pprStixVReg (StixVReg u pr) = hcat [text "VReg(", ppr u, colon, ppr pr, char ')'] @@ -612,3 +637,13 @@ ncgPrimopMoan msg pp_rep `seq` pprPanic msg pp_rep \end{code} + +Information about the target. + +\begin{code} + +ncg_target_is_32bit :: Bool +ncg_target_is_32bit | wORD_SIZE == 4 = True + | wORD_SIZE == 8 = False + +\end{code} \ No newline at end of file diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index 170cc39..141cf98 100644 --- a/ghc/compiler/nativeGen/StixMacro.lhs +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -316,6 +316,11 @@ checkCode macro args assts in (\xs -> assign_hp words : cjmp_hp : assts (hp_alloc words : gc_d1 : join : xs)) + HP_CHK_L1 -> + let [words] = args_stix + in (\xs -> assign_hp words : cjmp_hp : + assts (hp_alloc words : gc_l1 : join : xs)) + HP_CHK_UT_ALT -> let [words,ptrs,nonptrs,r,ret] = args_stix in (\xs -> assign_hp words : cjmp_hp : @@ -360,6 +365,7 @@ gc_unpt_r1 = mkStJump_to_GCentry_name "stg_gc_unpt_r1" gc_unbx_r1 = mkStJump_to_GCentry_name "stg_gc_unbx_r1" gc_f1 = mkStJump_to_GCentry_name "stg_gc_f1" gc_d1 = mkStJump_to_GCentry_name "stg_gc_d1" +gc_l1 = mkStJump_to_GCentry_name "stg_gc_l1" gc_gen = mkStJump_to_GCentry_name "stg_gen_chk" gc_ut (StInt p) (StInt np) = mkStJump_to_GCentry_name ("stg_gc_ut_" ++ show p ++ "_" ++ show np) diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index 6bce6c9..e7909b8 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -17,7 +17,7 @@ import AbsCUtils ( getAmodeRep, mixedTypeLocn ) import SMRep ( fixedHdrSize ) import Literal ( Literal(..), word2IntLit ) import MachOp ( MachOp(..) ) -import PrimRep ( PrimRep(..), getPrimRepSizeInBytes ) +import PrimRep ( PrimRep(..), getPrimRepArrayElemSize ) import UniqSupply ( returnUs, thenUs, getUniqueUs, UniqSM ) import Constants ( wORD_SIZE, mIN_INTLIKE, mIN_CHARLIKE, uF_UPDATEE, bLOCK_SIZE, @@ -104,6 +104,8 @@ foreignCallCode lhs (CCall (CCallSpec (StaticTarget fn) cconv safety)) rhs pk = case getAmodeRep lhs of FloatRep -> FloatRep DoubleRep -> DoubleRep + Int64Rep -> Int64Rep + Word64Rep -> Word64Rep other -> IntRep foreignCallCode lhs call rhs @@ -233,8 +235,8 @@ cHARLIKE_closure = StCLbl mkCharlikeClosureLabel mutArrPtrsFrozen_info = StCLbl mkMAP_FROZEN_infoLabel -- these are the sizes of charLike and intLike closures, in _bytes_. -charLikeSize = (fixedHdrSize + 1) * (sizeOf PtrRep) -intLikeSize = (fixedHdrSize + 1) * (sizeOf PtrRep) +charLikeSize = (fixedHdrSize + 1) * (getPrimRepArrayElemSize PtrRep) +intLikeSize = (fixedHdrSize + 1) * (getPrimRepArrayElemSize PtrRep) \end{code} diff --git a/ghc/compiler/prelude/PrimRep.lhs b/ghc/compiler/prelude/PrimRep.lhs index 8054366..515ba05 100644 --- a/ghc/compiler/prelude/PrimRep.lhs +++ b/ghc/compiler/prelude/PrimRep.lhs @@ -203,6 +203,8 @@ getPrimRepSizeInBytes other = pprPanic "getPrimRepSizeInBytes" (ppr othe -- getPrimRepSizeInBytes, the rationale behind which is -- unclear to me. getPrimRepArrayElemSize :: PrimRep -> Int +getPrimRepArrayElemSize CharRep = 4 +getPrimRepArrayElemSize DataPtrRep = wORD_SIZE getPrimRepArrayElemSize PtrRep = wORD_SIZE getPrimRepArrayElemSize IntRep = wORD_SIZE getPrimRepArrayElemSize WordRep = wORD_SIZE