[project @ 1999-03-01 17:41:50 by simonm]

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

diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs
index b0aefde..cbfe9dc 100644 (file)
--- a/ghc/compiler/nativeGen/MachCode.lhs
+++ b/ghc/compiler/nativeGen/MachCode.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The AQUA Project, Glasgow University, 1996
+% (c) The AQUA Project, Glasgow University, 1996-1998
 %
 \section[MachCode]{Generating machine code}
 
@@ -24,7 +24,7 @@ import CLabel         ( isAsmTemp, CLabel )
 import Maybes          ( maybeToBool, expectJust )
 import OrdList         -- quite a bit of it
 import PrimRep         ( isFloatingRep, PrimRep(..) )
-import PrimOp          ( PrimOp(..), showPrimOp )
+import PrimOp          ( PrimOp(..) )
 import CallConv                ( cCallConv )
 import Stix            ( getUniqLabelNCG, StixTree(..),
                          StixReg(..), CodeSegment(..)
@@ -78,6 +78,9 @@ stmt2Instrs stmt = case stmt of
            returnUs (mkSeqInstrs [LABEL lbl,
                                   ASCII True (_UNPK_ s)],
                                   ImmCLbl lbl)
+       -- the linker can handle simple arithmetic...
+       getData (StIndex rep (StCLbl lbl) (StInt off)) =
+               returnUs (id, ImmIndex lbl (fromInteger (off * sizeOf rep)))
 \end{code}
 
 %************************************************************************
@@ -158,6 +161,9 @@ maybeImm (StLitLbl s) = Just (ImmLab s)
 maybeImm (StLitLit s) = Just (strImmLit (cvtLitLit (_UNPK_ s)))
 maybeImm (StCLbl   l) = Just (ImmCLbl l)
 
+maybeImm (StIndex rep (StCLbl l) (StInt off)) = 
+       Just (ImmIndex l (fromInteger (off * sizeOf rep)))
+
 maybeImm (StInt i)
   | i >= toInteger minInt && i <= toInteger maxInt
   = Just (ImmInt (fromInteger i))
@@ -310,7 +316,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps
       Double2FloatOp -> coerceFltCode x
       Float2DoubleOp -> coerceFltCode x
 
-      other_op -> getRegister (StCall fn cconv DoubleRep [x])
+      other_op -> getRegister (StCall fn cCallConv DoubleRep [x])
        where
          fn = case other_op of
                 FloatExpOp    -> SLIT("exp")
@@ -409,9 +415,9 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
       SllOp  -> trivialCode SLL x y
       SrlOp  -> trivialCode SRL x y
 
-      ISllOp -> panic "AlphaGen:isll"
+      ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
       ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
-      ISrlOp -> panic "AlphaGen:isrl"
+      ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
 
       FloatPowerOp  -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
       DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
@@ -671,10 +677,9 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
       SllOp -> shift_code (SHL L) x y {-False-}
       SrlOp -> shift_code (SHR L) x y {-False-}
 
-      {- ToDo: nuke? -}
-      ISllOp -> panic "I386Gen:isll"
-      ISraOp -> shift_code (SAR L) x y {-False-}  --panic "I386Gen:isra"
-      ISrlOp -> panic "I386Gen:isrl"
+      ISllOp -> shift_code (SHL L) x y {-False-}  --was:panic "I386Gen:isll"
+      ISraOp -> shift_code (SAR L) x y {-False-}  --was:panic "I386Gen:isra"
+      ISrlOp -> shift_code (SHR L) x y {-False-}  --was:panic "I386Gen:isrl"
 
       FloatPowerOp  -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y])
                       where promote x = StPrim Float2DoubleOp [x]
@@ -752,7 +757,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
                          mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) (OpReg dst))
        in
        returnUs (Any IntRep code__2)
-
+{-
     add_code sz x (StInd _ mem)
       = getRegister x          `thenUs` \ register1 ->
        --getNewRegNCG (registerRep register1)
@@ -762,7 +767,6 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
            code2 = amodeCode amode
            src2  = amodeAddr amode
 
---         fixedname  = registerName register1 eax
            code__2 dst = let code1 = registerCode register1 dst
                              src1  = registerName register1 dst
                          in asmParThen [code2 asmVoid,code1 asmVoid] .
@@ -783,7 +787,6 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
            code1 = amodeCode amode
            src1  = amodeAddr amode
 
---         fixedname  = registerName register2 eax
            code__2 dst = let code2 = registerCode register2 dst
                              src2  = registerName register2 dst
                          in asmParThen [code1 asmVoid,code2 asmVoid] .
@@ -794,7 +797,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
                                    mkSeqInstrs [ADD sz (OpAddr src1) (OpReg src2)]
        in
        returnUs (Any IntRep code__2)
-
+-}
     add_code sz x y
       = getRegister x          `thenUs` \ register1 ->
        getRegister y           `thenUs` \ register2 ->
@@ -1005,7 +1008,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps
              DoubleSinhOp  -> (False, SLIT("sinh"))
              DoubleCoshOp  -> (False, SLIT("cosh"))
              DoubleTanhOp  -> (False, SLIT("tanh"))
-             _             -> panic ("Monadic PrimOp not handled: " ++ showPrimOp primop)
+             _             -> panic ("Monadic PrimOp not handled: " ++ show primop)
 
 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
   = case primop of
@@ -1075,9 +1078,9 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
       SllOp -> trivialCode SLL x y
       SrlOp -> trivialCode SRL x y
 
-      ISllOp -> panic "SparcGen:isll"
+      ISllOp -> trivialCode SLL x y  --was: panic "SparcGen:isll"
       ISraOp -> trivialCode SRA x y  --was: panic "SparcGen:isra"
-      ISrlOp -> panic "SparcGen:isrl"
+      ISrlOp -> trivialCode SRL x y  --was: panic "SparcGen:isrl"
 
       FloatPowerOp  -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y])
                       where promote x = StPrim Float2DoubleOp [x]
@@ -2781,7 +2784,6 @@ trivialCode instr x y
   = getRegister x              `thenUs` \ register1 ->
     --getNewRegNCG IntRep      `thenUs` \ tmp1 ->
     let
---     fixedname  = registerName register1 eax
        code__2 dst = let code1 = registerCode register1 dst
                          src1  = registerName register1 dst
                      in code1 .
@@ -2801,7 +2803,6 @@ trivialCode instr x y
   = getRegister y              `thenUs` \ register1 ->
     --getNewRegNCG IntRep      `thenUs` \ tmp1 ->
     let
---     fixedname  = registerName register1 eax
        code__2 dst = let code1 = registerCode register1 dst
                          src1  = registerName register1 dst
                      in code1 .
@@ -2815,13 +2816,12 @@ trivialCode instr x y
   where
     imm = maybeImm x
     imm__2 = case imm of Just x -> x
-
+{-
 trivialCode instr x (StInd pk mem)
   = getRegister x              `thenUs` \ register ->
     --getNewRegNCG IntRep      `thenUs` \ tmp ->
     getAmode mem               `thenUs` \ amode ->
     let
---     fixedname  = registerName register eax
        code2 = amodeCode amode asmVoid
        src2  = amodeAddr amode
        code__2 dst = let code1 = registerCode register dst asmVoid
@@ -2840,7 +2840,6 @@ trivialCode instr (StInd pk mem) y
     --getNewRegNCG IntRep      `thenUs` \ tmp ->
     getAmode mem               `thenUs` \ amode ->
     let
---     fixedname  = registerName register eax
        code2 = amodeCode amode asmVoid
        src2  = amodeAddr amode
        code__2 dst = let
@@ -2854,14 +2853,13 @@ trivialCode instr (StInd pk mem) y
                                mkSeqInstr (instr (OpAddr src2) (OpReg src1))
     in
     returnUs (Any pk code__2)
-
+-}
 trivialCode instr x y
   = getRegister x              `thenUs` \ register1 ->
     getRegister y              `thenUs` \ register2 ->
     --getNewRegNCG IntRep      `thenUs` \ tmp1 ->
     getNewRegNCG IntRep                `thenUs` \ tmp2 ->
     let
---     fixedname  = registerName register1 eax
        code2 = registerCode register2 tmp2 asmVoid
        src2  = registerName register2 tmp2
        code__2 dst = let
@@ -2881,7 +2879,6 @@ trivialUCode instr x
   = getRegister x              `thenUs` \ register ->
 --    getNewRegNCG IntRep      `thenUs` \ tmp ->
     let
---     fixedname = registerName register eax
        code__2 dst = let
                          code = registerCode register dst
                          src  = registerName register dst
@@ -3236,7 +3233,6 @@ chrCode x
   = getRegister x              `thenUs` \ register ->
     --getNewRegNCG IntRep      `thenUs` \ reg ->
     let
---     fixedname = registerName register eax
        code__2 dst = let
                          code = registerCode register dst
                          src  = registerName register dst