From: sewardj Date: Mon, 19 Feb 2001 10:15:54 +0000 (+0000) Subject: [project @ 2001-02-19 10:15:54 by sewardj] X-Git-Tag: Approximately_9120_patches~2603 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=0879ee328b8d52877f82fda4ae2a234b5ba6c037;p=ghc-hetmet.git [project @ 2001-02-19 10:15:54 by sewardj] Fix two bugs exposed when trying to boot HEAD on sparc with NCG and -O: 1. StScratchWords on sparc were in the wrong place; they were immediately above %fp and should have been immediately below. Fixed. Also removed a suspicious-looking "+1" in the x86 version of same. 2. (Potentially affects all platforms): Lift strings out from top-level literal data, and place them at the end of the block. The motivating example (bug) was: 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. This is Way Wrong (tm). Fixed. --- diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs index dd3f8bc..60d9b49 100644 --- a/ghc/compiler/nativeGen/AsmCodeGen.lhs +++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs @@ -112,13 +112,13 @@ nativeCodeGen absC us absCtoNat :: AbstractC -> UniqSM (SDoc, SDoc) absCtoNat absC - = _scc_ "genCodeAbstractC" genCodeAbstractC absC `thenUs` \ stixRaw -> - _scc_ "genericOpt" genericOpt stixRaw `bind` \ stixOpt -> - _scc_ "genMachCode" genMachCode stixOpt `thenUs` \ pre_regalloc -> - _scc_ "regAlloc" regAlloc pre_regalloc `bind` \ almost_final -> - _scc_ "x86fp_kludge" x86fp_kludge almost_final `bind` \ final_mach_code -> - _scc_ "vcat" vcat (map pprInstr final_mach_code) `bind` \ final_sdoc -> - _scc_ "pprStixTrees" pprStixTrees stixOpt `bind` \ stix_sdoc -> + = _scc_ "genCodeAbstractC" genCodeAbstractC absC `thenUs` \ stixRaw -> + _scc_ "genericOpt" genericOpt stixRaw `bind` \ stixOpt -> + _scc_ "genMachCode" genMachCode stixOpt `thenUs` \ pre_regalloc -> + _scc_ "regAlloc" regAlloc pre_regalloc `bind` \ almost_final -> + _scc_ "x86fp_kludge" x86fp_kludge almost_final `bind` \ final_mach_code -> + _scc_ "vcat" vcat (map pprInstr final_mach_code) `bind` \ final_sdoc -> + _scc_ "pprStixTrees" pprStixTrees stixOpt `bind` \ stix_sdoc -> returnUs (stix_sdoc, final_sdoc) where bind f x = x f @@ -150,12 +150,10 @@ supply breaks abstraction. Is that bad? genMachCode :: [StixTree] -> UniqSM InstrBlock genMachCode stmts initial_us - = let initial_st = mkNatM_State initial_us 0 - (blocks, final_st) = initNat initial_st - (mapNat stmt2Instrs stmts) - instr_list = concatOL blocks - final_us = uniqOfNatM_State final_st - final_delta = deltaOfNatM_State final_st + = let initial_st = mkNatM_State initial_us 0 + (instr_list, final_st) = initNat initial_st (stmtsToInstrs stmts) + final_us = uniqOfNatM_State final_st + final_delta = deltaOfNatM_State final_st in if final_delta == 0 then (instr_list, final_us) diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index 5939f60..455e4ab 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" @@ -56,9 +56,80 @@ 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. +-} + +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,21 +163,22 @@ 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))) + -- 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 @@ -556,7 +628,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) @@ -907,8 +979,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)