[project @ 2000-05-15 15:03:36 by simonmar]

I lied earlier.  _ccall_GC_ should work now.

diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs
index 3cf44fa..d21f785 100644 (file)
--- a/ghc/compiler/absCSyn/AbsCSyn.lhs
+++ b/ghc/compiler/absCSyn/AbsCSyn.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: AbsCSyn.lhs,v 1.29 2000/03/23 17:45:17 simonpj Exp $
+% $Id: AbsCSyn.lhs,v 1.30 2000/05/15 15:03:36 simonmar Exp $
 %
 \section[AbstractC]{Abstract C: the last stop before machine code}
 
@@ -473,6 +473,9 @@ data MagicId
        PrimRep         -- Int64Rep or Word64Rep
        FAST_INT        -- its number (1 .. mAX_Long_REG)
 
+  | CurrentTSO         -- pointer to current thread's TSO
+  | CurrentNursery     -- pointer to allocation area
+
 
 node   = VanillaReg PtrRep     ILIT(1) -- A convenient alias for Node
 tagreg  = VanillaReg WordRep    ILIT(2) -- A convenient alias for TagReg

diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs
index e7a563e..07a91bf 100644 (file)
--- a/ghc/compiler/absCSyn/AbsCUtils.lhs
+++ b/ghc/compiler/absCSyn/AbsCUtils.lhs
@@ -133,6 +133,8 @@ magicIdPrimRep Hp               = PtrRep
 magicIdPrimRep HpLim               = PtrRep
 magicIdPrimRep CurCostCentre       = CostCentreRep
 magicIdPrimRep VoidReg             = VoidRep
+magicIdPrimRep CurrentTSO          = ThreadIdRep
+magicIdPrimRep CurrentNursery      = PtrRep
 \end{code}
 
 %************************************************************************

diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs
index 523fc09..705da74 100644 (file)
--- a/ghc/compiler/absCSyn/CLabel.lhs
+++ b/ghc/compiler/absCSyn/CLabel.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CLabel.lhs,v 1.33 2000/04/13 11:56:35 simonpj Exp $
+% $Id: CLabel.lhs,v 1.34 2000/05/15 15:03:36 simonmar Exp $
 %
 \section[CLabel]{@CLabel@: Information to make C Labels}
 
@@ -418,7 +418,7 @@ pprCLbl (CaseLabel u CaseBitmap)
 
 pprCLbl (RtsLabel RtsShouldNeverHappenCode) = ptext SLIT("stg_error_entry")
 
-pprCLbl (RtsLabel RtsUpdInfo) = ptext SLIT("Upd_frame_info")
+pprCLbl (RtsLabel RtsUpdInfo) = ptext SLIT("upd_frame_info")
 
 pprCLbl (RtsLabel RtsTopTickyCtr) = ptext SLIT("top_ct")
 

diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs
index bd72d6b..81ff772 100644 (file)
--- a/ghc/compiler/nativeGen/MachRegs.lhs
+++ b/ghc/compiler/nativeGen/MachRegs.lhs
@@ -584,6 +584,8 @@ baseRegOffset (LongReg _ ILIT(2))    = OFFSET_Lng2
 #endif
 baseRegOffset Hp                    = OFFSET_Hp
 baseRegOffset HpLim                 = OFFSET_HpLim
+baseRegOffset CurrentTSO            = OFFSET_CurrentTSO
+baseRegOffset CurrentNursery        = OFFSET_CurrentNursery
 #ifdef DEBUG
 baseRegOffset BaseReg               = panic "baseRegOffset:BaseReg"
 baseRegOffset CurCostCentre         = panic "baseRegOffset:CurCostCentre"
@@ -657,6 +659,12 @@ callerSaves Hp                             = True
 #ifdef CALLER_SAVES_HpLim
 callerSaves HpLim                      = True
 #endif
+#ifdef CALLER_SAVES_CurrentTSO
+callerSaves CurrentTSO                 = True
+#endif
+#ifdef CALLER_SAVES_CurrentNursery
+callerSaves CurrentNursery             = True
+#endif
 callerSaves _                          = False
 \end{code}
 
@@ -735,6 +743,12 @@ magicIdRegMaybe Hp                 = Just (FixedReg ILIT(REG_Hp))
 #ifdef REG_HpLim                       
 magicIdRegMaybe HpLim                  = Just (FixedReg ILIT(REG_HpLim))
 #endif                                 
+#ifdef REG_CurrentTSO                          
+magicIdRegMaybe CurrentTSO             = Just (FixedReg ILIT(REG_CurrentTSO))
+#endif                                 
+#ifdef REG_CurrentNursery                              
+magicIdRegMaybe CurrentNursery         = Just (FixedReg ILIT(REG_CurrentNursery))
+#endif                                 
 magicIdRegMaybe _                      = Nothing
 \end{code}
 

diff --git a/ghc/compiler/nativeGen/RegAllocInfo.lhs b/ghc/compiler/nativeGen/RegAllocInfo.lhs
index 2f3f5da..d5d3502 100644 (file)
--- a/ghc/compiler/nativeGen/RegAllocInfo.lhs
+++ b/ghc/compiler/nativeGen/RegAllocInfo.lhs
@@ -437,8 +437,8 @@ regUsage instr = case instr of
     usageM (OpReg reg)    = mkRU [reg] [reg]
     usageM (OpAddr ea)    = mkRU (use_EA ea) []
 
-    --callClobberedRegs = [ eax, ecx, edx ] -- according to gcc, anyway.
-    callClobberedRegs = [eax,fake0,fake1,fake2,fake3,fake4,fake5]
+    -- caller-saves registers
+    callClobberedRegs = [eax,ecx,edx,fake0,fake1,fake2,fake3,fake4,fake5]
 
     -- Registers defd when an operand is written.
     def_W (OpReg reg)  = [reg]

diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs
index c521ad9..04e1e19 100644 (file)
--- a/ghc/compiler/nativeGen/Stix.lhs
+++ b/ghc/compiler/nativeGen/Stix.lhs
@@ -9,7 +9,8 @@ module Stix (
         stixCountTempUses, stixSubst,
 
        stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, 
-        stgHp, stgHpLim, stgTagReg, stgR9, stgR10,
+        stgHp, stgHpLim, stgTagReg, stgR9, stgR10, 
+       stgCurrentTSO, stgCurrentNursery,
 
        fixedHS, arrWordsHS, arrPtrsHS,
 
@@ -227,6 +228,8 @@ stgSu                   = StReg (StixMagicId Su)
 stgSpLim           = StReg (StixMagicId SpLim)
 stgHp              = StReg (StixMagicId Hp)
 stgHpLim           = StReg (StixMagicId HpLim)
+stgCurrentTSO      = StReg (StixMagicId CurrentTSO)
+stgCurrentNursery   = StReg (StixMagicId CurrentNursery)
 stgR9               = StReg (StixMagicId (VanillaReg WordRep ILIT(9)))
 stgR10              = StReg (StixMagicId (VanillaReg WordRep ILIT(10)))
 

diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs
index 522aceb..8eee4e5 100644 (file)
--- a/ghc/compiler/nativeGen/StixMacro.lhs
+++ b/ghc/compiler/nativeGen/StixMacro.lhs
@@ -205,7 +205,7 @@ bh_info, ind_static_info, ind_info :: StixTree
 bh_info        = sStLitLbl SLIT("BLACKHOLE_info")
 ind_static_info        = sStLitLbl SLIT("IND_STATIC_info")
 ind_info       = sStLitLbl SLIT("IND_info")
-upd_frame_info = sStLitLbl SLIT("Upd_frame_info")
+upd_frame_info = sStLitLbl SLIT("upd_frame_info")
 seq_frame_info = sStLitLbl SLIT("seq_frame_info")
 
 -- Some common call trees

diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs
index 49dc68b..034e641 100644 (file)
--- a/ghc/compiler/nativeGen/StixPrim.lhs
+++ b/ghc/compiler/nativeGen/StixPrim.lhs
@@ -14,17 +14,18 @@ import StixInteger
 
 import AbsCSyn                 hiding ( spRel )
 import AbsCUtils       ( getAmodeRep, mixedTypeLocn )
-import Constants       ( uF_UPDATEE )
 import SMRep           ( fixedHdrSize )
 import Literal         ( Literal(..), word2IntLit )
 import CallConv                ( cCallConv )
 import PrimOp          ( PrimOp(..), CCall(..), CCallTarget(..) )
 import PrimRep         ( PrimRep(..), isFloatingRep )
 import UniqSupply      ( returnUs, thenUs, getUniqueUs, UniqSM )
-import Constants       ( mIN_INTLIKE )
+import Constants       ( mIN_INTLIKE, uF_UPDATEE, bLOCK_SIZE )
 import Outputable
 
-import Char            ( ord )
+import Char            ( ord, isAlphaNum )
+
+#include "NCG.h"
 \end{code}
 
 The main honcho here is primCode, which handles the guts of COpStmts.
@@ -242,14 +243,17 @@ primCode lhs (CCallOp (CCall (StaticTarget fn) is_asm may_gc cconv)) rhs
   | is_asm = error "ERROR: Native code generator can't handle casm"
   | not may_gc = returnUs (\xs -> ccall : xs)
   | otherwise =
+       save_thread_state       `thenUs` \ save ->
+       load_thread_state       `thenUs` \ load -> 
        getUniqueUs             `thenUs` \ uniq -> 
        let
-          id = StReg (StixTemp uniq IntRep)
+          id  = StReg (StixTemp uniq IntRep)
+
           suspend = StAssign IntRep id 
                        (StCall SLIT("suspendThread") cconv IntRep [stgBaseReg])
           resume  = StCall SLIT("resumeThread") cconv VoidRep [id]
        in
-       returnUs (\xs -> suspend : ccall : resume : xs)
+       returnUs (\xs -> save (suspend : ccall : resume : load xs))
 
   where
     args = map amodeCodeForCCall rhs
@@ -459,12 +463,11 @@ amodeToStix (CMacroExpr _ macro [arg])
 
 litLitToStix :: String -> StixTree
 litLitToStix nm
-   = case nm of
-        "stdout" -> stixFor_stdout
-        "stderr" -> stixFor_stderr
-        "stdin"  -> stixFor_stdin
-        other    -> error ("\nlitLitToStix: can't handle `" ++ nm ++ "'\n" 
+  | all is_id nm = StLitLbl (text nm)
+  | otherwise    = error ("\nlitLitToStix: can't handle `" ++ nm ++ "'\n" 
                            ++ "suggested workaround: use flag -fvia-C\n")
+
+  where is_id c = isAlphaNum c || c == '_'
 \end{code}
 
 Sizes of the CharLike and IntLike closures that are arranged as arrays
@@ -495,3 +498,62 @@ mutArrPtrsFrozen_info = sStLitLbl SLIT("MUT_ARR_PTRS_FROZEN_info")
 charLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
 intLikeSize  = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
 \end{code}
+
+
+\begin{code}
+save_thread_state 
+   = getUniqueUs   `thenUs` \tso_uq -> 
+     let tso = StReg (StixTemp tso_uq ThreadIdRep) in
+     returnUs (\xs ->
+       StAssign ThreadIdRep tso stgCurrentTSO :
+       StAssign PtrRep
+          (StInd PtrRep (StPrim IntAddOp 
+               [tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]))
+          stgSp :
+       StAssign PtrRep 
+          (StInd PtrRep (StPrim IntAddOp 
+               [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))]))
+          stgSu :
+       StAssign PtrRep 
+          (StInd PtrRep (StPrim IntAddOp 
+               [tso, StInt (toInteger (TSO_SPLIM*BYTES_PER_WORD))]))
+          stgSpLim :
+       StAssign PtrRep
+          (StInd PtrRep (StPrim IntAddOp
+               [stgCurrentNursery, 
+                StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]))
+          (StPrim IntAddOp [stgHp, StInt (toInteger (1 * BYTES_PER_WORD))]) :
+       xs
+     )
+
+load_thread_state 
+   = getUniqueUs   `thenUs` \tso_uq -> 
+     let tso = StReg (StixTemp tso_uq ThreadIdRep) in
+     returnUs (\xs ->
+       StAssign ThreadIdRep tso stgCurrentTSO :
+       StAssign PtrRep stgSp
+          (StInd PtrRep (StPrim IntAddOp 
+               [tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])) :
+       StAssign PtrRep stgSu
+          (StInd PtrRep (StPrim IntAddOp 
+               [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))])) :
+       StAssign PtrRep stgSpLim
+          (StInd PtrRep (StPrim IntAddOp 
+               [tso, StInt (toInteger (TSO_SPLIM*BYTES_PER_WORD))])) :
+       StAssign PtrRep stgHp
+          (StPrim IntSubOp [
+             StInd PtrRep (StPrim IntAddOp
+               [stgCurrentNursery, 
+                StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]),
+             StInt (toInteger (1 * BYTES_PER_WORD))
+           ]) :
+       StAssign PtrRep stgHpLim
+          (StPrim IntAddOp [
+             StInd PtrRep (StPrim IntAddOp
+               [stgCurrentNursery, 
+                StInt (toInteger (BDESCR_START * BYTES_PER_WORD))]),
+             StInt (toInteger (bLOCK_SIZE - (1 * BYTES_PER_WORD)))
+           ]) :
+       xs
+     )
+\end{code}