[project @ 1998-08-14 12:00:22 by sof]

StCall now takes extra callconv arg; StixPrim.primCode doesn't flush stdout and stderr anymore (it's done in the .hc code)

diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs
index 759fedc..7ad77c8 100644 (file)
--- a/ghc/compiler/nativeGen/AbsCStixGen.lhs
+++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs
@@ -367,7 +367,7 @@ comparison tree.  (Perhaps this could be tuned.)
 \begin{code}
 
  intTag :: Literal -> Integer
- intTag (MachChar c) = toInteger (ord c)
+ intTag (MachChar c)  = fromInt (ord c)
  intTag (MachInt i _) = i
  intTag _ = panic "intTag"
 
@@ -442,8 +442,8 @@ already finish with a jump to the join point.
  mkJumpTable am alts lowTag highTag dflt
   = getUniqLabelNCG                                    `thenUs` \ utlbl ->
     mapUs genLabel alts                                `thenUs` \ branches ->
-    let        cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt lowTag])
-       cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt highTag])
+    let        cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt (toInteger lowTag)])
+       cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt (toInteger highTag)])
 
        offset = StPrim IntSubOp [am, StInt lowTag]
 

diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs
index 1edfe9a..fe9828c 100644 (file)
--- a/ghc/compiler/nativeGen/AsmCodeGen.lhs
+++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs
@@ -156,8 +156,8 @@ genericOpt (StJump addr) = StJump (genericOpt addr)
 genericOpt (StCondJump addr test)
   = StCondJump addr (genericOpt test)
 
-genericOpt (StCall fn pk args)
-  = StCall fn pk (map genericOpt args)
+genericOpt (StCall fn cconv pk args)
+  = StCall fn cconv pk (map genericOpt args)
 \end{code}
 
 Fold indices together when the types match:
@@ -249,7 +249,6 @@ primOpt op args@[x, y@(StInt 0)]
        OrOp     -> x
        XorOp    -> x
        SllOp    -> x
-       SraOp    -> x
        SrlOp    -> x
        ISllOp   -> x
        ISraOp   -> x
@@ -271,10 +270,10 @@ primOpt op args@[x, y@(StInt n)]
   = case op of
        IntMulOp -> case exactLog2 n of
            Nothing -> StPrim op args
-           Just p  -> StPrim SllOp [x, StInt p]
+           Just p  -> StPrim ISllOp [x, StInt p]
        IntQuotOp -> case exactLog2 n of
            Nothing -> StPrim op args
-           Just p  -> StPrim SraOp [x, StInt p]
+           Just p  -> StPrim ISrlOp [x, StInt p]
        _ -> StPrim op args
 \end{code}
 

diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.lhs b/ghc/compiler/nativeGen/AsmRegAlloc.lhs
index 106fe29..8862f53 100644 (file)
--- a/ghc/compiler/nativeGen/AsmRegAlloc.lhs
+++ b/ghc/compiler/nativeGen/AsmRegAlloc.lhs
@@ -22,8 +22,7 @@ import OrdList                ( mkEmptyList, mkUnitList, mkSeqList, mkParList,
                        )
 import Stix            ( StixTree )
 import Unique          ( mkBuiltinUnique )
-import Util            ( mapAccumB, panic )
-import GlaExts         ( trace )
+import Util            ( mapAccumB, panic, trace )
 import Outputable
 \end{code}
 

diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs
index b9f66e8..b0aefde 100644 (file)
--- a/ghc/compiler/nativeGen/MachCode.lhs
+++ b/ghc/compiler/nativeGen/MachCode.lhs
@@ -19,11 +19,13 @@ import MachRegs
 
 import AbsCSyn         ( MagicId )
 import AbsCUtils       ( magicIdPrimRep )
+import CallConv                ( CallConv )
 import CLabel          ( isAsmTemp, CLabel )
 import Maybes          ( maybeToBool, expectJust )
 import OrdList         -- quite a bit of it
 import PrimRep         ( isFloatingRep, PrimRep(..) )
 import PrimOp          ( PrimOp(..), showPrimOp )
+import CallConv                ( cCallConv )
 import Stix            ( getUniqLabelNCG, StixTree(..),
                          StixReg(..), CodeSegment(..)
                        )
@@ -47,7 +49,7 @@ stmt2Instrs stmt = case stmt of
 
     StJump arg            -> genJump arg
     StCondJump lab arg    -> genCondJump lab arg
-    StCall fn VoidRep args -> genCCall fn VoidRep args
+    StCall fn cconv VoidRep args -> genCCall fn cconv VoidRep args
 
     StAssign pk dst src
       | isFloatingRep pk -> assignFltCode pk dst src
@@ -212,8 +214,8 @@ getRegister (StReg (StixTemp u pk))
 
 getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
 
-getRegister (StCall fn kind args)
-  = genCCall fn kind args          `thenUs` \ call ->
+getRegister (StCall fn cconv kind args)
+  = genCCall fn cconv kind args            `thenUs` \ call ->
     returnUs (Fixed kind reg call)
   where
     reg = if isFloatingRep kind
@@ -308,7 +310,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps
       Double2FloatOp -> coerceFltCode x
       Float2DoubleOp -> coerceFltCode x
 
-      other_op -> getRegister (StCall fn DoubleRep [x])
+      other_op -> getRegister (StCall fn cconv DoubleRep [x])
        where
          fn = case other_op of
                 FloatExpOp    -> SLIT("exp")
@@ -405,15 +407,14 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
       OrOp   -> trivialCode OR  x y
       XorOp  -> trivialCode XOR x y
       SllOp  -> trivialCode SLL x y
-      SraOp  -> trivialCode SRA x y
       SrlOp  -> trivialCode SRL x y
 
       ISllOp -> panic "AlphaGen:isll"
-      ISraOp -> panic "AlphaGen:isra"
+      ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
       ISrlOp -> panic "AlphaGen:isrl"
 
-      FloatPowerOp  -> getRegister (StCall SLIT("pow") DoubleRep [x,y])
-      DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x,y])
+      FloatPowerOp  -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
+      DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
   where
     {- ------------------------------------------------------------
        Some bizarre special code for getting condition codes into
@@ -556,7 +557,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps
                          then StPrim Float2DoubleOp [x]
                          else x
        in
-       getRegister (StCall fn DoubleRep [x])
+       getRegister (StCall fn cCallConv DoubleRep [x])
        where
        (is_float_op, fn)
          = case primop of
@@ -668,17 +669,16 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
        -}
           
       SllOp -> shift_code (SHL L) x y {-False-}
-      SraOp -> shift_code (SAR L) x y {-False-}
       SrlOp -> shift_code (SHR L) x y {-False-}
 
       {- ToDo: nuke? -}
       ISllOp -> panic "I386Gen:isll"
-      ISraOp -> panic "I386Gen:isra"
+      ISraOp -> shift_code (SAR L) x y {-False-}  --panic "I386Gen:isra"
       ISrlOp -> panic "I386Gen:isrl"
 
-      FloatPowerOp  -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y])
+      FloatPowerOp  -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y])
                       where promote x = StPrim Float2DoubleOp [x]
-      DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y])
+      DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y])
   where
     shift_code :: (Operand -> Operand -> Instr)
               -> StixTree
@@ -970,7 +970,7 @@ getRegister (StPrim primop [x]) -- unary PrimOps
                          then StPrim Float2DoubleOp [x]
                          else x
        in
-       getRegister (StCall fn DoubleRep [x])
+       getRegister (StCall fn cCallConv DoubleRep [x])
        where
        (is_float_op, fn)
          = case primop of
@@ -1073,19 +1073,18 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps
       OrOp  -> trivialCode (OR  False) x y
       XorOp -> trivialCode (XOR False) x y
       SllOp -> trivialCode SLL x y
-      SraOp -> trivialCode SRA x y
       SrlOp -> trivialCode SRL x y
 
       ISllOp -> panic "SparcGen:isll"
-      ISraOp -> panic "SparcGen:isra"
+      ISraOp -> trivialCode SRA x y  --was: panic "SparcGen:isra"
       ISrlOp -> panic "SparcGen:isrl"
 
-      FloatPowerOp  -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y])
+      FloatPowerOp  -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y])
                       where promote x = StPrim Float2DoubleOp [x]
-      DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y])
+      DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y])
 --      _ -> panic "Prim op " ++ (showPrimOp primop) ++ " not handled!"
   where
-    imul_div fn x y = getRegister (StCall fn IntRep [x, y])
+    imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y])
 
 getRegister (StInd pk mem)
   = getAmode mem                   `thenUs` \ amode ->
@@ -2234,13 +2233,14 @@ register allocator.
 \begin{code}
 genCCall
     :: FAST_STRING     -- function to call
+    -> CallConv
     -> PrimRep         -- type of the result
     -> [StixTree]      -- arguments (of mixed type)
     -> UniqSM InstrBlock
 
 #if alpha_TARGET_ARCH
 
-genCCall fn kind args
+genCCall fn cconv kind args
   = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
                                    `thenUs` \ ((unused,_), argCode) ->
     let
@@ -2308,7 +2308,7 @@ genCCall fn kind args
 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 #if i386_TARGET_ARCH
 
-genCCall fn kind [StInt i]
+genCCall fn cconv kind [StInt i]
   | fn == SLIT ("PerformGC_wrapper")
   = let
      call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
@@ -2329,7 +2329,7 @@ genCCall fn kind [StInt i]
     returnInstrs call
 -}
 
-genCCall fn kind args
+genCCall fn cconv kind args
   = mapUs get_call_arg args `thenUs` \ argCode ->
     let
        nargs = length args
@@ -2401,7 +2401,7 @@ genCCall fn kind args
 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 #if sparc_TARGET_ARCH
 
-genCCall fn kind args
+genCCall fn cconv kind args
   = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
                                    `thenUs` \ ((unused,_), argCode) ->
     let

diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs
index 06cbae1..c30d6cf 100644 (file)
--- a/ghc/compiler/nativeGen/MachRegs.lhs
+++ b/ghc/compiler/nativeGen/MachRegs.lhs
@@ -596,6 +596,12 @@ baseRegOffset (FloatReg  ILIT(3))    = OFFSET_Flt3
 baseRegOffset (FloatReg  ILIT(4))    = OFFSET_Flt4
 baseRegOffset (DoubleReg ILIT(1))    = OFFSET_Dbl1
 baseRegOffset (DoubleReg ILIT(2))    = OFFSET_Dbl2
+#ifdef OFFSET_Lng1
+baseRegOffset (LongReg _ ILIT(1))    = OFFSET_Lng1
+#endif
+#ifdef OFFSET_Lng2
+baseRegOffset (LongReg _ ILIT(2))    = OFFSET_Lng2
+#endif
 baseRegOffset TagReg                = OFFSET_Tag
 baseRegOffset RetReg                = OFFSET_Ret
 baseRegOffset SpA                   = OFFSET_SpA
@@ -665,6 +671,12 @@ callerSaves (DoubleReg ILIT(1))            = True
 #ifdef CALLER_SAVES_DblReg2
 callerSaves (DoubleReg ILIT(2))                = True
 #endif
+#ifdef CALLER_SAVES_LngReg1
+callerSaves (LongReg _ ILIT(1))                = True
+#endif
+#ifdef CALLER_SAVES_LngReg2
+callerSaves (LongReg _ ILIT(2))                = True
+#endif
 #ifdef CALLER_SAVES_Tag
 callerSaves TagReg                     = True
 #endif
@@ -752,6 +764,12 @@ magicIdRegMaybe (DoubleReg ILIT(1))        = Just (FixedReg ILIT(REG_Dbl1))
 #ifdef REG_Dbl2                                
 magicIdRegMaybe (DoubleReg ILIT(2))    = Just (FixedReg ILIT(REG_Dbl2))
 #endif
+#ifdef REG_Lng1                                
+magicIdRegMaybe (LongReg _ ILIT(1))    = Just (FixedReg ILIT(REG_Lng1))
+#endif                                 
+#ifdef REG_Lng2                                
+magicIdRegMaybe (LongReg _ ILIT(2))    = Just (FixedReg ILIT(REG_Lng2))
+#endif
 #ifdef REG_Tag
 magicIdRegMaybe TagReg                 = Just (FixedReg ILIT(REG_TagReg))
 #endif     

diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs
index 2e7e64c..5923b00 100644 (file)
--- a/ghc/compiler/nativeGen/Stix.lhs
+++ b/ghc/compiler/nativeGen/Stix.lhs
@@ -19,6 +19,7 @@ import Ratio          ( Rational )
 
 import AbsCSyn         ( node, infoptr, MagicId(..) )
 import AbsCUtils       ( magicIdPrimRep )
+import CallConv                ( CallConv )
 import CLabel          ( mkAsmTempLabel, CLabel )
 import PrimRep          ( PrimRep )
 import PrimOp           ( PrimOp )
@@ -95,7 +96,7 @@ data StixTree
 
     -- Calls to C functions
 
-  | StCall FAST_STRING PrimRep [StixTree]
+  | StCall FAST_STRING CallConv PrimRep [StixTree]
 
     -- Assembly-language comments
 

diff --git a/ghc/compiler/nativeGen/StixInteger.lhs b/ghc/compiler/nativeGen/StixInteger.lhs
index 23c6a07..cd9a553 100644 (file)
--- a/ghc/compiler/nativeGen/StixInteger.lhs
+++ b/ghc/compiler/nativeGen/StixInteger.lhs
@@ -17,6 +17,7 @@ import MachMisc
 import MachRegs
 
 import AbsCSyn         -- bits and bobs...
+import CallConv                ( cCallConv )
 import Constants       ( mIN_MP_INT_SIZE )
 import Literal         ( Literal(..) )
 import OrdList         ( OrdList )
@@ -45,9 +46,9 @@ argument2 = mpStruct 2
 result2 = mpStruct 2
 result3 = mpStruct 3
 result4 = mpStruct 4
-init2 = StCall SLIT("mpz_init") VoidRep [result2]
-init3 = StCall SLIT("mpz_init") VoidRep [result3]
-init4 = StCall SLIT("mpz_init") VoidRep [result4]
+init2 = StCall SLIT("mpz_init") cCallConv VoidRep [result2]
+init3 = StCall SLIT("mpz_init") cCallConv VoidRep [result3]
+init4 = StCall SLIT("mpz_init") cCallConv VoidRep [result4]
 
 gmpTake1Return1 res@(car,csr,cdr) rtn arg@(clive,caa,csa,cda)
   = let
@@ -64,7 +65,7 @@ gmpTake1Return1 res@(car,csr,cdr) rtn arg@(clive,caa,csa,cda)
        safeHp = saveLoc Hp
        save = StAssign PtrRep safeHp oldHp
        (a1,a2,a3) = toStruct argument1 (aa,sa,da)
-       mpz_op = StCall rtn VoidRep [result2, argument1]
+       mpz_op = StCall rtn cCallConv VoidRep [result2, argument1]
        restore = StAssign PtrRep stgHp safeHp
        (r1,r2,r3) = fromStruct result2 (ar,sr,dr)
     in
@@ -99,7 +100,7 @@ gmpTake2Return1 res@(car,csr,cdr) rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda
        save = StAssign PtrRep safeHp oldHp
        (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1)
        (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2)
-       mpz_op = StCall rtn VoidRep [result3, argument1, argument2]
+       mpz_op = StCall rtn cCallConv VoidRep [result3, argument1, argument2]
        restore = StAssign PtrRep stgHp safeHp
        (r1,r2,r3) = fromStruct result3 (ar,sr,dr)
     in
@@ -140,7 +141,7 @@ gmpTake2Return2 res@(car1,csr1,cdr1, car2,csr2,cdr2)
        save = StAssign PtrRep safeHp oldHp
        (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1)
        (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2)
-       mpz_op = StCall rtn VoidRep [result3, result4, argument1, argument2]
+       mpz_op = StCall rtn cCallConv VoidRep [result3, result4, argument1, argument2]
        restore = StAssign PtrRep stgHp safeHp
        (r1,r2,r3) = fromStruct result3 (ar1,sr1,dr1)
        (r4,r5,r6) = fromStruct result4 (ar2,sr2,dr2)
@@ -181,7 +182,7 @@ gmpCompare res args@(chp, caa1,csa1,cda1, caa2,csa2,cda2)
        argument2 = StIndex IntRep hp (StInt (toInteger mpIntSize))
        (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1)
        (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2)
-       mpz_cmp = StCall SLIT("mpz_cmp") IntRep [argument1, argument2]
+       mpz_cmp = StCall SLIT("mpz_cmp") cCallConv IntRep [argument1, argument2]
        r1 = StAssign IntRep result mpz_cmp
     in
     returnUs (\xs -> a1 : a2 : a3 : a4 : a5 : a6 : r1 : xs)
@@ -204,7 +205,7 @@ gmpInteger2Int res args@(chp, caa,csa,cda)
        da      = amodeToStix cda
 
        (a1,a2,a3) = toStruct hp (aa,sa,da)
-       mpz_get_si = StCall SLIT("mpz_get_si") IntRep [hp]
+       mpz_get_si = StCall SLIT("mpz_get_si") cCallConv IntRep [hp]
        r1 = StAssign IntRep result mpz_get_si
     in
     returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
@@ -223,7 +224,7 @@ gmpInteger2Word res args@(chp, caa,csa,cda)
        da      = amodeToStix cda
 
        (a1,a2,a3) = toStruct hp (aa,sa,da)
-       mpz_get_ui = StCall SLIT("mpz_get_ui") IntRep [hp]
+       mpz_get_ui = StCall SLIT("mpz_get_ui") cCallConv IntRep [hp]
        r1 = StAssign WordRep result mpz_get_ui
     in
     returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
@@ -305,11 +306,11 @@ gmpString2Integer res@(car,csr,cdr) (liveness, str)
        safeHp = saveLoc Hp
        save = StAssign PtrRep safeHp oldHp
        result = StIndex IntRep stgHpLim (StInt (toInteger (-mpIntSize)))
-       set_str = StCall SLIT("mpz_init_set_str") IntRep
+       set_str = StCall SLIT("mpz_init_set_str") cCallConv IntRep
            [result, amodeToStix str, StInt 10]
        test = StPrim IntEqOp [set_str, StInt 0]
        cjmp = StCondJump ulbl test
-       abort = StCall SLIT("abort") VoidRep []
+       abort = StCall SLIT("abort") cCallConv VoidRep []
        join = StLabel ulbl
        restore = StAssign PtrRep stgHp safeHp
        (a1,a2,a3) = fromStruct result (ar,sr,dr)
@@ -346,7 +347,7 @@ encodeFloatingKind pk res args@(chp, caa,csa,cda, cexpon)
            FloatRep -> SLIT("__encodeFloat")
            DoubleRep -> SLIT("__encodeDouble")
            _ -> panic "encodeFloatingKind"
-       encode = StCall fn pk' [hp, expon]
+       encode = StCall fn cCallConv pk' [hp, expon]
        r1 = StAssign pk' result encode
     in
     returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
@@ -376,7 +377,7 @@ decodeFloatingKind pk res@(cexponr,car,csr,cdr) args@(chp, carg)
            FloatRep -> SLIT("__decodeFloat")
            DoubleRep -> SLIT("__decodeDouble")
            _ -> panic "decodeFloatingKind"
-       decode = StCall fn VoidRep [mantissa, hp, arg]
+       decode = StCall fn cCallConv VoidRep [mantissa, hp, arg]
        (a1,a2,a3) = fromStruct mantissa (ar,sr,dr)
        a4 = StAssign IntRep exponr (StInd IntRep hp)
     in

diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs
index ab0ecc4..3d1e564 100644 (file)
--- a/ghc/compiler/nativeGen/StixMacro.lhs
+++ b/ghc/compiler/nativeGen/StixMacro.lhs
@@ -12,6 +12,7 @@ import {-# SOURCE #-} StixPrim ( amodeToStix )
 import MachMisc
 import MachRegs
 import AbsCSyn         ( CStmtMacro(..), MagicId(..), mkIntCLit, CAddrMode )
+import CallConv                ( cCallConv )
 import Constants       ( uF_RET, uF_SUA, uF_SUB, uF_UPDATEE,
                          sTD_UF_SIZE
                        )
@@ -284,7 +285,7 @@ heapCheck liveness words reenter
        cjmp = StCondJump ulbl test
        arg = StPrim IntAddOp [StPrim IntMulOp [words, StInt 256], liveness]
        -- ToDo: Overflow?  (JSM)
-       gc = StCall SLIT("PerformGC_wrapper") VoidRep [arg]
+       gc = StCall SLIT("PerformGC_wrapper") cCallConv VoidRep [arg]
        join = StLabel ulbl
     in
     returnUs (\xs -> assign : cjmp : gc : join : xs)
@@ -306,5 +307,5 @@ ind_info  = sStLitLbl SLIT("Ind_info")
 updatePAP, stackOverflow :: StixTree
 
 updatePAP     = StJump (sStLitLbl SLIT("UpdatePAP"))
-stackOverflow = StCall SLIT("StackOverflow") VoidRep []
+stackOverflow = StCall SLIT("StackOverflow") cCallConv VoidRep []
 \end{code}

diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs
index 2b28c64..42c2bf9 100644 (file)
--- a/ghc/compiler/nativeGen/StixPrim.lhs
+++ b/ghc/compiler/nativeGen/StixPrim.lhs
@@ -13,6 +13,7 @@ import MachRegs
 
 import AbsCSyn
 import AbsCUtils       ( getAmodeRep, mixedTypeLocn )
+import CallConv                ( cCallConv )
 import Constants       ( spARelToInt, spBRelToInt )
 import CostCentre      ( noCostCentreAttached )
 import HeapOffs                ( hpRelToInt, subOff )
@@ -130,15 +131,14 @@ primCode [res] Word2IntOp [arg]
 \end{code}
 
 The @ErrorIO@ primitive is actually a bit weird...assign a new value
-to the root closure, flush stdout and stderr, and jump to the
-@ErrorIO_innards@.
+to the root closure, and jump to the @ErrorIO_innards@.
 
 \begin{code}
 primCode [] ErrorIOPrimOp [rhs]
   = let
        changeTop = StAssign PtrRep topClosure (amodeToStix rhs)
     in
-    returnUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs)
+    returnUs (\xs -> changeTop : errorIO : xs)
 \end{code}
 
 @newArray#@ ops allocate heap space.
@@ -152,7 +152,7 @@ primCode [res] NewArrayOp args
        loc = StIndex PtrRep stgHp
              (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
        assign = StAssign PtrRep result loc
-       initialise = StCall SLIT("newArrZh_init") VoidRep [result, n, initial]
+       initialise = StCall SLIT("newArrZh_init") cCallConv VoidRep [result, n, initial]
     in
     heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
 
@@ -318,7 +318,7 @@ primCode [lhs] DeRefStablePtrOp [sp]
        lhs' = amodeToStix lhs
        pk = getAmodeRep lhs
        sp' = amodeToStix sp
-       call = StCall SLIT("deRefStablePointer") pk [sp', smStablePtrTable]
+       call = StCall SLIT("deRefStablePointer") cCallConv pk [sp', smStablePtrTable]
        assign = StAssign pk lhs' call
     in
     returnUs (\xs -> assign : xs)
@@ -439,21 +439,21 @@ primCode [lhs] SeqOp [a]
      lhs'   = amodeToStix lhs
      a'     = amodeToStix a
      pk     = getAmodeRep lhs  -- an IntRep
-     call   = StCall SLIT("SeqZhCode") pk [a']
+     call   = StCall SLIT("SeqZhCode") cCallConv pk [a']
      assign = StAssign pk lhs' call
     in
 --    trace "SeqOp" $ 
     returnUs (\xs -> assign : xs)
 
-primCode lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs
+primCode lhs (CCallOp (Just fn) is_asm may_gc cconv arg_tys result_ty) rhs
   | is_asm = error "ERROR: Native code generator can't handle casm"
   | otherwise
   = case lhs of
-      [] -> returnUs (\xs -> (StCall fn VoidRep args) : xs)
+      [] -> returnUs (\xs -> (StCall fn cconv VoidRep args) : xs)
       [lhs] ->
          let lhs' = amodeToStix lhs
              pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
-             call = StAssign pk lhs' (StCall fn pk args)
+             call = StAssign pk lhs' (StCall fn cconv pk args)
          in
              returnUs (\xs -> call : xs)
   where
@@ -582,7 +582,7 @@ amodeToStix (CCharLike x)
 amodeToStix (CIntLike (CLit (MachInt i _)))
   = StPrim IntAddOp [intLikePtr, StInt off]
   where
-    off = toInteger intLikeSize * i
+    off = toInteger intLikeSize * toInteger i
 
 amodeToStix (CIntLike x)
   = StPrim IntAddOp [intLikePtr, off]
@@ -597,7 +597,7 @@ amodeToStix (CLit core)
       MachChar c     -> StInt (toInteger (ord c))
       MachStr s             -> StString s
       MachAddr a     -> StInt a
-      MachInt i _    -> StInt i
+      MachInt i _    -> StInt (toInteger i)
       MachLitLit s _ -> StLitLit s
       MachFloat d    -> StDouble d
       MachDouble d   -> StDouble d
@@ -643,10 +643,8 @@ charLike = sStLitLbl SLIT("CHARLIKE_closures")
 
 -- Trees for the ErrorIOPrimOp
 
-topClosure, flushStdout, flushStderr, errorIO :: StixTree
+topClosure, errorIO :: StixTree
 
 topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
-flushStdout = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stdout")]
-flushStderr = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stderr")]
 errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))
 \end{code}