[project @ 2000-08-21 15:40:14 by sewardj]

[ghc-hetmet.git] / ghc / compiler / nativeGen / MachCode.lhs

diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs
index cf1aef1..0d7dcb8 100644 (file)
--- a/ghc/compiler/nativeGen/MachCode.lhs
+++ b/ghc/compiler/nativeGen/MachCode.lhs
@@ -26,7 +26,7 @@ import PrimRep                ( isFloatingRep, PrimRep(..) )
 import PrimOp          ( PrimOp(..) )
 import CallConv                ( cCallConv )
 import Stix            ( getNatLabelNCG, StixTree(..),
-                         StixReg(..), CodeSegment(..), 
+                         StixReg(..), CodeSegment(..), DestInfo,
                           pprStixTree, ppStixReg,
                           NatM, thenNat, returnNat, mapNat, 
                           mapAndUnzipNat, mapAccumLNat,
@@ -68,7 +68,7 @@ stmt2Instrs stmt = case stmt of
 
     StLabel lab           -> returnNat (unitOL (LABEL lab))
 
-    StJump arg            -> genJump (derefDLL arg)
+    StJump dsts arg       -> genJump dsts (derefDLL arg)
     StCondJump lab arg    -> genCondJump lab (derefDLL arg)
 
     -- A call returning void, ie one done for its side-effects
@@ -160,7 +160,8 @@ mangleIndexTree (StIndex pk base off)
       ]
   where
     shift DoubleRep    = 3::Integer
-    shift CharRep       = 0::Integer
+    shift CharRep       = 2::Integer
+    shift Int8Rep       = 0::Integer
     shift _            = IF_ARCH_alpha(3,2)
 \end{code}
 
@@ -1981,7 +1982,7 @@ branch instruction.  Other CLabels are assumed to be far away.
 register allocator.
 
 \begin{code}
-genJump :: StixTree{-the branch target-} -> NatM InstrBlock
+genJump :: DestInfo -> StixTree{-the branch target-} -> NatM InstrBlock
 
 #if alpha_TARGET_ARCH
 
@@ -1992,7 +1993,7 @@ genJump (StCLbl lbl)
     target = ImmCLbl lbl
 
 genJump tree
-  = getRegister tree                       `thenNat` \ register ->
+  = getRegister tree               `thenNat` \ register ->
     getNewRegNCG PtrRep            `thenNat` \ tmp ->
     let
        dst    = registerName register pv
@@ -2008,17 +2009,17 @@ genJump tree
 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 #if i386_TARGET_ARCH
 
-genJump (StInd pk mem)
+genJump dsts (StInd pk mem)
   = getAmode mem                   `thenNat` \ amode ->
     let
        code   = amodeCode amode
        target = amodeAddr amode
     in
-    returnNat (code `snocOL` JMP (OpAddr target))
+    returnNat (code `snocOL` JMP dsts (OpAddr target))
 
-genJump tree
+genJump dsts tree
   | maybeToBool imm
-  = returnNat (unitOL (JMP (OpImm target)))
+  = returnNat (unitOL (JMP dsts (OpImm target)))
 
   | otherwise
   = getRegister tree               `thenNat` \ register ->
@@ -2027,7 +2028,7 @@ genJump tree
        code   = registerCode register tmp
        target = registerName register tmp
     in
-    returnNat (code `snocOL` JMP (OpReg target))
+    returnNat (code `snocOL` JMP dsts (OpReg target))
   where
     imm    = maybeImm tree
     target = case imm of Just x -> x
@@ -3249,14 +3250,16 @@ coerceFP2Int x
 %*                                                                     *
 %************************************************************************
 
-Integer to character conversion.  Where applicable, we try to do this
-in one step if the original object is in memory.
+Integer to character conversion.
 
 \begin{code}
 chrCode :: StixTree -> NatM Register
 
 #if alpha_TARGET_ARCH
 
+-- TODO: This is probably wrong, but I don't know Alpha assembler.
+-- It should coerce a 64-bit value to a 32-bit value.
+
 chrCode x
   = getRegister x              `thenNat` \ register ->
     getNewRegNCG IntRep                `thenNat` \ reg ->
@@ -3273,47 +3276,23 @@ chrCode x
 
 chrCode x
   = getRegister x              `thenNat` \ register ->
-    let
-       code__2 dst = let
-                         code = registerCode register dst
-                         src  = registerName register dst
-                     in code `appOL`
-                        if   isFixed register && src /= dst
-                        then toOL [MOV L (OpReg src) (OpReg dst),
-                                   AND L (OpImm (ImmInt 255)) (OpReg dst)]
-                        else unitOL (AND L (OpImm (ImmInt 255)) (OpReg src))
-    in
-    returnNat (Any IntRep code__2)
+    returnNat (
+    case register of
+       Fixed _ reg code -> Fixed IntRep reg code
+       Any   _ code     -> Any   IntRep code
+    )
 
 #endif {- i386_TARGET_ARCH -}
 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 #if sparc_TARGET_ARCH
 
-chrCode (StInd pk mem)
-  = getAmode mem               `thenNat` \ amode ->
-    let
-       code    = amodeCode amode
-       src     = amodeAddr amode
-       src_off = addrOffset src 3
-       src__2  = case src_off of Just x -> x
-       code__2 dst = if maybeToBool src_off then
-                       code `snocOL` LD BU src__2 dst
-                   else
-                       code `snocOL`
-                       LD (primRepToSize pk) src dst  `snocOL`
-                       AND False dst (RIImm (ImmInt 255)) dst
-    in
-    returnNat (Any pk code__2)
-
 chrCode x
   = getRegister x              `thenNat` \ register ->
-    getNewRegNCG IntRep                `thenNat` \ reg ->
-    let
-       code = registerCode register reg
-       src  = registerName register reg
-       code__2 dst = code `snocOL` AND False src (RIImm (ImmInt 255)) dst
-    in
-    returnNat (Any IntRep code__2)
+    returnNat (
+    case register of
+       Fixed _ reg code -> Fixed IntRep reg code
+       Any   _ code     -> Any   IntRep code
+    )
 
 #endif {- sparc_TARGET_ARCH -}
 \end{code}