[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.

2 files changed, 95 insertions, 25 deletions

diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs
index dd3f8bc697..60d9b4936b 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 5939f60282..455e4aba90 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)