[project @ 2001-01-15 17:05:46 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 4406d45..a480840 100644 (file)
--- a/ghc/compiler/nativeGen/MachCode.lhs
+++ b/ghc/compiler/nativeGen/MachCode.lhs
@@ -20,15 +20,15 @@ import OrdList              ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
                          snocOL, consOL, concatOL )
 import AbsCUtils       ( magicIdPrimRep )
 import CallConv                ( CallConv )
-import CLabel          ( isAsmTemp, CLabel, pprCLabel_asm, labelDynamic )
+import CLabel          ( isAsmTemp, CLabel, labelDynamic )
 import Maybes          ( maybeToBool, expectJust )
 import PrimRep         ( isFloatingRep, PrimRep(..) )
 import PrimOp          ( PrimOp(..) )
-import CallConv                ( cCallConv )
+import CallConv                ( cCallConv, stdCallConv )
 import Stix            ( getNatLabelNCG, StixTree(..),
                          StixReg(..), CodeSegment(..), 
                           DestInfo, hasDestInfo,
-                          pprStixTree, ppStixReg,
+                          pprStixTree, 
                           NatM, thenNat, returnNat, mapNat, 
                           mapAndUnzipNat, mapAccumLNat,
                           getDeltaNat, setDeltaNat
@@ -262,7 +262,7 @@ getRegister (StString s)
        imm_lbl = ImmCLbl lbl
 
        code dst = toOL [
-           SEGMENT DataSegment,
+           SEGMENT RoDataSegment,
            LABEL lbl,
            ASCII True (_UNPK_ s),
            SEGMENT TextSegment,
@@ -665,8 +665,8 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
 
       IntAddOp  -> add_code  L x y
       IntSubOp  -> sub_code  L x y
-      IntQuotOp -> quot_code L x y True{-division-}
-      IntRemOp  -> quot_code L x y False{-remainder-}
+      IntQuotOp -> trivialCode (IQUOT L) Nothing x y
+      IntRemOp  -> trivialCode (IREM L) Nothing x y
       IntMulOp  -> let op = IMUL L in trivialCode op (Just op) x y
 
       FloatAddOp -> trivialFCode  FloatRep  GADD x y
@@ -832,41 +832,6 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
 
     sub_code sz x y = trivialCode (SUB sz) Nothing x y
 
-    --------------------
-    quot_code
-       :: Size
-       -> StixTree -> StixTree
-       -> Bool -- True => division, False => remainder operation
-       -> NatM Register
-
-    -- x must go into eax, edx must be a sign-extension of eax, and y
-    -- should go in some other register (or memory), so that we get
-    -- edx:eax / reg -> eax (remainder in edx).  Currently we choose
-    -- to put y on the C stack, since that avoids tying up yet another
-    -- precious register.
-
-    quot_code sz x y is_division
-      = getRegister x          `thenNat` \ register1 ->
-       getRegister y           `thenNat` \ register2 ->
-       getNewRegNCG IntRep     `thenNat` \ tmp ->
-        getDeltaNat             `thenNat` \ delta ->
-       let
-           code1   = registerCode register1 tmp
-           src1    = registerName register1 tmp
-           code2   = registerCode register2 tmp
-           src2    = registerName register2 tmp
-           code__2 = code2               `snocOL`      --       src2 := y
-                      PUSH L (OpReg src2) `snocOL`      --   -4(%esp) := y
-                      DELTA (delta-4)     `appOL`
-                      code1               `snocOL`      --       src1 := x
-                      MOV L (OpReg src1) (OpReg eax) `snocOL`  -- eax := x
-                      CLTD                           `snocOL`
-                      IDIV sz (OpAddr (spRel 0))     `snocOL`
-                      ADD L (OpImm (ImmInt 4)) (OpReg esp) `snocOL`
-                      DELTA delta
-       in
-       returnNat (Fixed IntRep (if is_division then eax else edx) code__2)
-       -----------------------
 
 getRegister (StInd pk mem)
   = getAmode mem                   `thenNat` \ amode ->
@@ -2238,7 +2203,6 @@ genCondJump lbl bool
     let
        code   = condCode condition
        cond   = condName condition
-       target = ImmCLbl lbl
     in
     returnNat (code `snocOL` JXX cond lbl)
 
@@ -2375,11 +2339,14 @@ genCCall fn cconv kind args
     let (sizes, codes) = unzip sizes_n_codes
         tot_arg_size   = sum sizes
        code2          = concatOL codes
-       call = toOL [
-                  CALL fn__2,
-                 ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp),
-                  DELTA (delta + tot_arg_size)
-               ]
+       call = toOL (
+                  [CALL (fn__2 tot_arg_size)]
+                  ++
+                  (if cconv == stdCallConv then [] else 
+                  [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
+                  ++
+                  [DELTA (delta + tot_arg_size)]
+               )
     in
     setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
     returnNat (code2 `appOL` call)
@@ -2389,9 +2356,16 @@ genCCall fn cconv kind args
     -- internally generated names like '.mul,' which don't get an
     -- underscore prefix
     -- ToDo:needed (WDP 96/03) ???
-    fn__2 = case (_HEAD_ fn) of
-             '.' -> ImmLit (ptext fn)
-             _   -> ImmLab False (ptext fn)
+    fn_u  = _UNPK_ fn
+    fn__2 tot_arg_size
+       | head fn_u == '.'
+       = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
+       | otherwise 
+       = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
+
+    stdcallsize tot_arg_size
+       | cconv == stdCallConv = '@':show tot_arg_size
+       | otherwise            = ""
 
     arg_size DF = 8
     arg_size F  = 4