From: sewardj Date: Tue, 1 Feb 2000 14:02:02 +0000 (+0000) Subject: [project @ 2000-02-01 14:02:02 by sewardj] X-Git-Tag: Approximately_9120_patches~5166 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=85ef3b326950dc22db60a78ed8ea7702562c298e;p=ghc-hetmet.git [project @ 2000-02-01 14:02:02 by sewardj] -- Cosmetic changes in register allocator. -- Implement macro HP_GEN_SEQ_NP. -- MachCode(trivialCode, x86): because one of the operands is also the destination (on this 2-address arch), it's invalid to sequence the code to compute the operands using asmParThen [code1, code2]. since the order of assignments matters. Fixed. --- diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.lhs b/ghc/compiler/nativeGen/AsmRegAlloc.lhs index 2ddb991..2412173 100644 --- a/ghc/compiler/nativeGen/AsmRegAlloc.lhs +++ b/ghc/compiler/nativeGen/AsmRegAlloc.lhs @@ -10,6 +10,7 @@ module AsmRegAlloc ( runRegAllocate, runHairyRegAllocate ) where import MachCode ( InstrList ) import MachMisc ( Instr ) +import PprMach ( pprUserReg ) -- debugging import MachRegs import RegAllocInfo @@ -41,16 +42,11 @@ runRegAllocate regs find_reserve_regs instrs Nothing -> tryHairy reserves where tryHairy [] - = error "nativeGen: register allocator: too difficult! Try -fvia-C.\n" + = error "nativeGen: spilling failed. Try -fvia-C.\n" tryHairy (resv:resvs) = case hairyAlloc resv of Just success -> success - Nothing -> fooble resvs (tryHairy resvs) - - fooble [] x = x - fooble (resvs:_) x = trace ("nativeGen: spilling with " - ++ show (length resvs - 2) ++ - " int temporaries") x + Nothing -> tryHairy resvs reserves = find_reserve_regs flatInstrs flatInstrs = flattenOrdList instrs @@ -168,17 +164,25 @@ hairyRegAlloc regs reserve_regs instrs = noFuture instrs_patched of ((RH _ mloc2 _),_,instrs'') -- successfully allocated the patched code - | mloc2 == mloc1 -> Just instrs'' + | mloc2 == mloc1 -> trace (spillMsg True) (Just instrs'') -- no; we have to give up - | otherwise -> Nothing + | otherwise -> trace (spillMsg False) Nothing -- instrs'' - -- pprPanic "runRegAllocate" (ppr mloc2 <+> ppr mloc1) where regs' = regs `useMRegs` reserve_regs regs'' = mkMRegsState reserve_regs noFuture :: RegFuture noFuture = RF emptyRegSet (FL emptyRegSet emptyFM) emptyFM + + spillMsg success + = "nativeGen: spilling " + ++ (if success then "succeeded" else "failed ") + ++ " using " + ++ showSDoc (hsep (map (pprUserReg.toMappedReg) + (reverse reserve_regs))) + where + toMappedReg (I# i) = MappedReg i \end{code} Here we patch instructions that reference ``registers'' which are really in diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index 0ae1867..41f8410 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -483,8 +483,10 @@ getRegister (StDouble d) in returnUs (Any DoubleRep code) +-- incorrectly assumes that %esp doesn't move (as does spilling); ToDo: fix getRegister (StScratchWord i) - = let code dst = mkSeqInstr (LEA L (OpAddr (spRel (-1000+i))) (OpReg dst)) + | i >= 0 && i < 6 + = let code dst = mkSeqInstr (LEA L (OpAddr (spRel (i+1))) (OpReg dst)) in returnUs (Any PtrRep code) getRegister (StPrim primop [x]) -- unary PrimOps @@ -2476,10 +2478,10 @@ condIntReg cond x y code = condCode condition cond = condName condition -- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move. - code__2 dst = code . mkSeqInstrs [COMMENT (_PK_ "aaaaa"), + code__2 dst = code . mkSeqInstrs [ SETCC cond (OpReg tmp), AND L (OpImm (ImmInt 1)) (OpReg tmp), - MOV L (OpReg tmp) (OpReg dst) ,COMMENT (_PK_ "bbbbb")] + MOV L (OpReg tmp) (OpReg dst)] in returnUs (Any IntRep code__2) @@ -2729,11 +2731,10 @@ trivialCode instr x y code__2 dst = let code1 = registerCode register1 dst src1 = registerName register1 dst in code1 . - if isFixed register1 && src1 /= dst + if isFixed register1 && src1 /= dst then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst), instr (OpImm imm__2) (OpReg dst)] - else - mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)] + else mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)] in returnUs (Any IntRep code__2) where @@ -2745,17 +2746,15 @@ trivialCode instr x y getRegister y `thenUs` \ register2 -> getNewRegNCG IntRep `thenUs` \ tmp2 -> let - code2 = registerCode register2 tmp2 asmVoid + code2 = registerCode register2 tmp2 --asmVoid src2 = registerName register2 tmp2 - code__2 dst = let - code1 = registerCode register1 dst asmVoid + code__2 dst = let code1 = registerCode register1 dst --asmVoid src1 = registerName register1 dst - in asmParThen [code1, code2] . - if isFixed register1 && src1 /= dst + in code2 . code1 . --asmParThen [code1, code2] . + if isFixed register1 && src1 /= dst then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst), instr (OpReg src2) (OpReg dst)] - else - mkSeqInstr (instr (OpReg src2) (OpReg src1)) + else mkSeqInstr (instr (OpReg src2) (OpReg src1)) in returnUs (Any IntRep code__2) @@ -2763,13 +2762,13 @@ trivialCode instr x y trivialUCode instr x = getRegister x `thenUs` \ register -> let - code__2 dst = let - code = registerCode register dst + code__2 dst = let code = registerCode register dst src = registerName register dst - in code . if isFixed register && dst /= src - then mkSeqInstrs [MOV L (OpReg src) (OpReg dst), - instr (OpReg dst)] - else mkSeqInstr (instr (OpReg src)) + in code . + if isFixed register && dst /= src + then mkSeqInstrs [MOV L (OpReg src) (OpReg dst), + instr (OpReg dst)] + else mkSeqInstr (instr (OpReg src)) in returnUs (Any IntRep code__2) diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs index 3933351..23f81a9 100644 --- a/ghc/compiler/nativeGen/PprMach.lhs +++ b/ghc/compiler/nativeGen/PprMach.lhs @@ -10,7 +10,7 @@ We start with the @pprXXX@s with some cross-platform commonality \begin{code} #include "nativeGen/NCG.h" -module PprMach ( pprInstr, pprSize ) where +module PprMach ( pprInstr, pprSize, pprUserReg ) where #include "HsVersions.h" @@ -38,6 +38,10 @@ import Char ( ord ) For x86, the way we print a register name depends on which bit of it we care about. Yurgh. \begin{code} +pprUserReg:: Reg -> SDoc +pprUserReg = pprReg IF_ARCH_i386(L,) + + pprReg :: IF_ARCH_i386(Size ->,) Reg -> SDoc pprReg IF_ARCH_i386(s,) r @@ -94,49 +98,16 @@ pprReg IF_ARCH_i386(s,) r _ -> SLIT("very naughty I386 byte register") }) -{- UNUSED: - ppr_reg_no HB i = ptext - (case i of { - ILIT( 0) -> SLIT("%ah"); ILIT( 1) -> SLIT("%bh"); - ILIT( 2) -> SLIT("%ch"); ILIT( 3) -> SLIT("%dh"); - _ -> SLIT("very naughty I386 high byte register") - }) --} - -{- UNUSED: - ppr_reg_no S i = ptext - (case i of { - ILIT( 0) -> SLIT("%ax"); ILIT( 1) -> SLIT("%bx"); - ILIT( 2) -> SLIT("%cx"); ILIT( 3) -> SLIT("%dx"); - ILIT( 4) -> SLIT("%si"); ILIT( 5) -> SLIT("%di"); - ILIT( 6) -> SLIT("%bp"); ILIT( 7) -> SLIT("%sp"); - _ -> SLIT("very naughty I386 word register") - }) --} - - ppr_reg_no L i = ptext + ppr_reg_no _ i = ptext (case i of { ILIT( 0) -> SLIT("%eax"); ILIT( 1) -> SLIT("%ebx"); ILIT( 2) -> SLIT("%ecx"); ILIT( 3) -> SLIT("%edx"); ILIT( 4) -> SLIT("%esi"); ILIT( 5) -> SLIT("%edi"); ILIT( 6) -> SLIT("%ebp"); ILIT( 7) -> SLIT("%esp"); - _ -> SLIT("very naughty I386 double word register") - }) - - ppr_reg_no F i = ptext - (case i of { - ILIT( 8) -> SLIT("%fake0"); ILIT( 9) -> SLIT("%fake1"); - ILIT(10) -> SLIT("%fake2"); ILIT(11) -> SLIT("%fake3"); - ILIT(12) -> SLIT("%fake4"); ILIT(13) -> SLIT("%fake5"); - _ -> SLIT("very naughty I386 float register") - }) - - ppr_reg_no DF i = ptext - (case i of { ILIT( 8) -> SLIT("%fake0"); ILIT( 9) -> SLIT("%fake1"); ILIT(10) -> SLIT("%fake2"); ILIT(11) -> SLIT("%fake3"); ILIT(12) -> SLIT("%fake4"); ILIT(13) -> SLIT("%fake5"); - _ -> SLIT("very naughty I386 float register") + _ -> SLIT("very naughty I386 register") }) #endif #if sparc_TARGET_ARCH diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index 530146d..cf2cc8a 100644 --- a/ghc/compiler/nativeGen/StixMacro.lhs +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -252,6 +252,11 @@ checkCode macro args assts in (\xs -> assign_hp words : cjmp_hp : assts (gc_enter ptrs : join : xs)) + HP_CHK_SEQ_NP -> + let [words,ptrs] = args_stix + in (\xs -> assign_hp words : cjmp_hp : + assts (gc_seq ptrs : join : xs)) + STK_CHK_NP -> let [words,ptrs] = args_stix in (\xs -> cjmp_sp_pass words : @@ -309,7 +314,8 @@ checkCode macro args assts HP_CHK_UT_ALT -> let [words,ptrs,nonptrs,r,ret] = args_stix in (\xs -> assign_hp words : cjmp_hp : - assts (assign_ret r ret : gc_ut ptrs nonptrs : join : xs)) + assts (assign_ret r ret : gc_ut ptrs nonptrs + : join : xs)) HP_CHK_GEN -> let [words,liveness,reentry] = args_stix @@ -321,8 +327,12 @@ checkCode macro args assts -- Various canned heap-check routines -gc_chk (StInt n) = StJump (StLitLbl (ptext SLIT("stg_chk_") <> int (fromInteger n))) -gc_enter (StInt n) = StJump (StLitLbl (ptext SLIT("stg_gc_enter_") <> int (fromInteger n))) +gc_chk (StInt n) = StJump (StLitLbl (ptext SLIT("stg_chk_") + <> int (fromInteger n))) +gc_enter (StInt n) = StJump (StLitLbl (ptext SLIT("stg_gc_enter_") + <> int (fromInteger n))) +gc_seq (StInt n) = StJump (StLitLbl (ptext SLIT("stg_gc_seq_") + <> int (fromInteger n))) gc_noregs = StJump (StLitLbl (ptext SLIT("stg_gc_noregs"))) gc_unpt_r1 = StJump (StLitLbl (ptext SLIT("stg_gc_unpt_r1"))) gc_unbx_r1 = StJump (StLitLbl (ptext SLIT("stg_gc_unbx_r1"))) @@ -331,6 +341,7 @@ gc_d1 = StJump (StLitLbl (ptext SLIT("stg_gc_d1"))) gc_gen = StJump (StLitLbl (ptext SLIT("stg_gen_chk"))) gc_ut (StInt p) (StInt np) - = StJump (StLitLbl (ptext SLIT("stg_gc_ut_") <> int (fromInteger p) + = StJump (StLitLbl (ptext SLIT("stg_gc_ut_") + <> int (fromInteger p) <> char '_' <> int (fromInteger np))) \end{code}