From 0b3dcf9dd504c2db156d08f1908e906e00e66c7a Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Mon, 15 May 2000 15:03:36 +0000
Subject: [PATCH] [project @ 2000-05-15 15:03:36 by simonmar] I lied earlier.
_ccall_GC_ should work now.
---
ghc/compiler/absCSyn/AbsCSyn.lhs | 5 +-
ghc/compiler/absCSyn/AbsCUtils.lhs | 2 +
ghc/compiler/absCSyn/CLabel.lhs | 4 +-
ghc/compiler/nativeGen/MachRegs.lhs | 14 +++++
ghc/compiler/nativeGen/RegAllocInfo.lhs | 4 +-
ghc/compiler/nativeGen/Stix.lhs | 5 +-
ghc/compiler/nativeGen/StixMacro.lhs | 2 +-
ghc/compiler/nativeGen/StixPrim.lhs | 82 ++++++++++++++++++++++---
8 files changed, 101 insertions(+), 17 deletions(-)
diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs
index 3cf44fa3f3f2..d21f785588f6 100644
--- 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 e7a563e058ac..07a91bf4335b 100644
--- 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 523fc096b89d..705da7442201 100644
--- 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 bd72d6b4484c..81ff7724f9ef 100644
--- 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 2f3f5da6aa69..d5d35022504f 100644
--- 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 c521ad9e3505..04e1e198b093 100644
--- 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 522aceb97c7a..8eee4e54bf9a 100644
--- 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 49dc68bdf4b0..034e6410259c 100644
--- 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}
--
GitLab