X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FStixPrim.lhs;h=accb9fe1d0bf429bec1b11e6655fc68b5d887486;hb=7752abc1008b633fdc7a0b9f283ceca40747b609;hp=2d8643969244991f6828e5fc1245c8b446b3f8bd;hpb=8252a068d95fa49040f6c55ed170f9155416e8ac;p=ghc-hetmet.git

diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs
index 2d86439..accb9fe 100644
--- a/ghc/compiler/nativeGen/StixPrim.lhs
+++ b/ghc/compiler/nativeGen/StixPrim.lhs
@@ -8,23 +8,25 @@ module StixPrim ( primCode, amodeToStix, amodeToStix' ) where
 #include "HsVersions.h"
 
 import MachMisc
-import MachRegs
 import Stix
 import StixInteger
 
 import AbsCSyn 		hiding ( spRel )
 import AbsCUtils	( getAmodeRep, mixedTypeLocn )
-import Constants	( uF_UPDATEE )
 import SMRep		( fixedHdrSize )
-import Const		( Literal(..) )
+import Literal		( Literal(..), word2IntLit )
+import PrimOp		( PrimOp(..), CCall(..), CCallTarget(..) )
+import PrimRep		( PrimRep(..) )
+import UniqSupply	( returnUs, thenUs, getUniqueUs, UniqSM )
+import Constants	( mIN_INTLIKE, mIN_CHARLIKE, uF_UPDATEE, bLOCK_SIZE,
+			  rESERVED_STACK_WORDS )
+import CLabel		( mkIntlikeClosureLabel, mkCharlikeClosureLabel,
+			  mkMAP_FROZEN_infoLabel, mkForeignLabel )
 import CallConv		( cCallConv )
-import PrimOp		( PrimOp(..) )
-import PrimRep		( PrimRep(..), isFloatingRep )
-import UniqSupply	( returnUs, thenUs, UniqSM )
-import Constants	( mIN_INTLIKE )
 import Outputable
+import FastTypes
 
-import Char	       	( ord )
+#include "NCG.h"
 \end{code}
 
 The main honcho here is primCode, which handles the guts of COpStmts.
@@ -91,6 +93,12 @@ primCode [res] SameMutableArrayOp args
 
 primCode res@[_] SameMutableByteArrayOp args
   = primCode res SameMutableArrayOp args
+
+primCode res@[_] SameMutVarOp args
+  = primCode res SameMutableArrayOp args
+
+primCode res@[_] SameMVarOp args
+  = primCode res SameMutableArrayOp args
 \end{code}
 
 Freezing an array of pointers is a double assignment.  We fix the
@@ -111,8 +119,6 @@ primCode [lhs] UnsafeFreezeArrayOp [rhs]
 
 primCode [lhs] UnsafeFreezeByteArrayOp [rhs]
   = simpleCoercion PtrRep lhs rhs
-primCode [lhs] UnsafeThawByteArrayOp [rhs]
-  = simpleCoercion PtrRep lhs rhs
 \end{code}
 
 Returning the size of (mutable) byte arrays is just
@@ -165,65 +171,113 @@ primCode [] WriteArrayOp [obj, ix, v]
     in
     returnUs (\xs -> assign : xs)
 
-primCode lhs@[_] (IndexByteArrayOp pk) args
-  = primCode lhs (ReadByteArrayOp pk) args
-
--- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
-
-primCode [lhs] (ReadByteArrayOp pk) [obj, ix]
-  = let
-	lhs' = amodeToStix lhs
-    	obj' = amodeToStix obj
-    	ix' = amodeToStix ix
-    	base = StIndex IntRep obj' arrWordsHS
-    	assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
-    in
-    returnUs (\xs -> assign : xs)
-
-primCode [lhs] (IndexOffAddrOp pk) [obj, ix]
+primCode [] WriteForeignObjOp [obj, v]
   = let
-	lhs' = amodeToStix lhs
     	obj' = amodeToStix obj
-    	ix' = amodeToStix ix
-    	assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
+    	v' = amodeToStix v
+	obj'' = StIndex AddrRep obj' (StInt 4711) -- fixedHS
+    	assign = StAssign AddrRep (StInd AddrRep obj'') v'
     in
     returnUs (\xs -> assign : xs)
 
-primCode [lhs] (IndexOffForeignObjOp pk) [obj, ix]
-  = let
-	lhs' = amodeToStix lhs
-    	obj' = amodeToStix obj
-    	ix' = amodeToStix ix
-	obj'' = StIndex PtrRep obj' fixedHS
-    	assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix'))
-    in
-    returnUs (\xs -> assign : xs)
+-- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
+primCode ls IndexByteArrayOp_Char      rs = primCode_ReadByteArrayOp Int8Rep      ls rs
+primCode ls IndexByteArrayOp_Int       rs = primCode_ReadByteArrayOp IntRep       ls rs
+primCode ls IndexByteArrayOp_Word      rs = primCode_ReadByteArrayOp WordRep      ls rs
+primCode ls IndexByteArrayOp_Addr      rs = primCode_ReadByteArrayOp AddrRep      ls rs
+primCode ls IndexByteArrayOp_Float     rs = primCode_ReadByteArrayOp FloatRep     ls rs
+primCode ls IndexByteArrayOp_Double    rs = primCode_ReadByteArrayOp DoubleRep    ls rs
+primCode ls IndexByteArrayOp_StablePtr rs = primCode_ReadByteArrayOp StablePtrRep ls rs
+primCode ls IndexByteArrayOp_Int64     rs = primCode_ReadByteArrayOp Int64Rep     ls rs
+primCode ls IndexByteArrayOp_Word64    rs = primCode_ReadByteArrayOp Word64Rep    ls rs
+
+primCode ls ReadByteArrayOp_Char      rs = primCode_ReadByteArrayOp Int8Rep      ls rs
+primCode ls ReadByteArrayOp_Int       rs = primCode_ReadByteArrayOp IntRep       ls rs
+primCode ls ReadByteArrayOp_Word      rs = primCode_ReadByteArrayOp WordRep      ls rs
+primCode ls ReadByteArrayOp_Addr      rs = primCode_ReadByteArrayOp AddrRep      ls rs
+primCode ls ReadByteArrayOp_Float     rs = primCode_ReadByteArrayOp FloatRep     ls rs
+primCode ls ReadByteArrayOp_Double    rs = primCode_ReadByteArrayOp DoubleRep    ls rs
+primCode ls ReadByteArrayOp_StablePtr rs = primCode_ReadByteArrayOp StablePtrRep ls rs
+primCode ls ReadByteArrayOp_Int64     rs = primCode_ReadByteArrayOp Int64Rep     ls rs
+primCode ls ReadByteArrayOp_Word64    rs = primCode_ReadByteArrayOp Word64Rep    ls rs
+
+primCode ls ReadOffAddrOp_Char      rs = primCode_IndexOffAddrOp Int8Rep      ls rs
+primCode ls ReadOffAddrOp_Int       rs = primCode_IndexOffAddrOp IntRep       ls rs
+primCode ls ReadOffAddrOp_Word      rs = primCode_IndexOffAddrOp WordRep      ls rs
+primCode ls ReadOffAddrOp_Addr      rs = primCode_IndexOffAddrOp AddrRep      ls rs
+primCode ls ReadOffAddrOp_Float     rs = primCode_IndexOffAddrOp FloatRep     ls rs
+primCode ls ReadOffAddrOp_Double    rs = primCode_IndexOffAddrOp DoubleRep    ls rs
+primCode ls ReadOffAddrOp_StablePtr rs = primCode_IndexOffAddrOp StablePtrRep ls rs
+primCode ls ReadOffAddrOp_Int64     rs = primCode_IndexOffAddrOp Int64Rep     ls rs
+primCode ls ReadOffAddrOp_Word64    rs = primCode_IndexOffAddrOp Word64Rep    ls rs
+
+primCode ls IndexOffAddrOp_Char      rs = primCode_IndexOffAddrOp Int8Rep      ls rs
+primCode ls IndexOffAddrOp_Int       rs = primCode_IndexOffAddrOp IntRep       ls rs
+primCode ls IndexOffAddrOp_Word      rs = primCode_IndexOffAddrOp WordRep      ls rs
+primCode ls IndexOffAddrOp_Addr      rs = primCode_IndexOffAddrOp AddrRep      ls rs
+primCode ls IndexOffAddrOp_Float     rs = primCode_IndexOffAddrOp FloatRep     ls rs
+primCode ls IndexOffAddrOp_Double    rs = primCode_IndexOffAddrOp DoubleRep    ls rs
+primCode ls IndexOffAddrOp_StablePtr rs = primCode_IndexOffAddrOp StablePtrRep ls rs
+primCode ls IndexOffAddrOp_Int64     rs = primCode_IndexOffAddrOp Int64Rep     ls rs
+primCode ls IndexOffAddrOp_Word64    rs = primCode_IndexOffAddrOp Word64Rep    ls rs
+
+primCode ls IndexOffForeignObjOp_Char      rs = primCode_IndexOffForeignObjOp Int8Rep      ls rs
+primCode ls IndexOffForeignObjOp_Int       rs = primCode_IndexOffForeignObjOp IntRep       ls rs
+primCode ls IndexOffForeignObjOp_Word      rs = primCode_IndexOffForeignObjOp WordRep      ls rs
+primCode ls IndexOffForeignObjOp_Addr      rs = primCode_IndexOffForeignObjOp AddrRep      ls rs
+primCode ls IndexOffForeignObjOp_Float     rs = primCode_IndexOffForeignObjOp FloatRep     ls rs
+primCode ls IndexOffForeignObjOp_Double    rs = primCode_IndexOffForeignObjOp DoubleRep    ls rs
+primCode ls IndexOffForeignObjOp_StablePtr rs = primCode_IndexOffForeignObjOp StablePtrRep ls rs
+primCode ls IndexOffForeignObjOp_Int64     rs = primCode_IndexOffForeignObjOp Int64Rep     ls rs
+primCode ls IndexOffForeignObjOp_Word64    rs = primCode_IndexOffForeignObjOp Word64Rep    ls rs
+
+primCode ls WriteOffAddrOp_Char      rs = primCode_WriteOffAddrOp Int8Rep      ls rs
+primCode ls WriteOffAddrOp_Int       rs = primCode_WriteOffAddrOp IntRep       ls rs
+primCode ls WriteOffAddrOp_Word      rs = primCode_WriteOffAddrOp WordRep      ls rs
+primCode ls WriteOffAddrOp_Addr      rs = primCode_WriteOffAddrOp AddrRep      ls rs
+primCode ls WriteOffAddrOp_Float     rs = primCode_WriteOffAddrOp FloatRep     ls rs
+primCode ls WriteOffAddrOp_Double    rs = primCode_WriteOffAddrOp DoubleRep    ls rs
+primCode ls WriteOffAddrOp_StablePtr rs = primCode_WriteOffAddrOp StablePtrRep ls rs
+primCode ls WriteOffAddrOp_Int64     rs = primCode_WriteOffAddrOp Int64Rep     ls rs
+primCode ls WriteOffAddrOp_Word64    rs = primCode_WriteOffAddrOp Word64Rep    ls rs
+
+primCode ls WriteByteArrayOp_Char      rs = primCode_WriteByteArrayOp Int8Rep      ls rs
+primCode ls WriteByteArrayOp_Int       rs = primCode_WriteByteArrayOp IntRep       ls rs
+primCode ls WriteByteArrayOp_Word      rs = primCode_WriteByteArrayOp WordRep      ls rs
+primCode ls WriteByteArrayOp_Addr      rs = primCode_WriteByteArrayOp AddrRep      ls rs
+primCode ls WriteByteArrayOp_Float     rs = primCode_WriteByteArrayOp FloatRep     ls rs
+primCode ls WriteByteArrayOp_Double    rs = primCode_WriteByteArrayOp DoubleRep    ls rs
+primCode ls WriteByteArrayOp_StablePtr rs = primCode_WriteByteArrayOp StablePtrRep ls rs
+primCode ls WriteByteArrayOp_Int64     rs = primCode_WriteByteArrayOp Int64Rep     ls rs
+primCode ls WriteByteArrayOp_Word64    rs = primCode_WriteByteArrayOp Word64Rep    ls rs
 
-primCode [] (WriteByteArrayOp pk) [obj, ix, v]
-  = let
-	obj' = amodeToStix obj
-    	ix' = amodeToStix ix
-    	v' = amodeToStix v
-    	base = StIndex IntRep obj' arrWordsHS
-    	assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
-    in
-    returnUs (\xs -> assign : xs)
 \end{code}
 
+ToDo: saving/restoring of volatile regs around ccalls.
+
+JRS, 001113: always do the call of suspendThread and resumeThread as a ccall
+rather than inheriting the calling convention of the thing which we're really
+calling.
+
 \begin{code}
---primCode lhs (CCallOp fn is_asm may_gc) rhs
-primCode lhs (CCallOp (Left fn) is_asm may_gc cconv) rhs
+primCode lhs (CCallOp (CCall (StaticTarget fn) is_asm may_gc cconv)) rhs
   | is_asm = error "ERROR: Native code generator can't handle casm"
-  | may_gc = error "ERROR: Native code generator can't handle _ccall_GC_\n"
-  | otherwise
-  = case lhs of
-      [] -> 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 cconv pk args)
-	  in
-	      returnUs (\xs -> call : xs)
+  | 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)
+
+    	   suspend = StAssign IntRep id 
+			(StCall SLIT("suspendThread") {-no:cconv-} cCallConv
+                                IntRep [stgBaseReg])
+	   resume  = StCall SLIT("resumeThread") {-no:cconv-} cCallConv
+                            VoidRep [id]
+	in
+	returnUs (\xs -> save (suspend : ccall : resume : load xs))
+
   where
     args = map amodeCodeForCCall rhs
     amodeCodeForCCall x =
@@ -232,8 +286,19 @@ primCode lhs (CCallOp (Left fn) is_asm may_gc cconv) rhs
 	    case getAmodeRep x of
 	      ArrayRep      -> StIndex PtrRep base arrPtrsHS
 	      ByteArrayRep  -> StIndex IntRep base arrWordsHS
-	      ForeignObjRep -> StIndex PtrRep base fixedHS
+	      ForeignObjRep -> StInd PtrRep (StIndex PtrRep base fixedHS)
 	      _ -> base
+
+    ccall = case lhs of
+      [] -> StCall fn cconv VoidRep args
+      [lhs] ->
+	  let lhs' = amodeToStix lhs
+	      pk   = case getAmodeRep lhs of
+                        FloatRep  -> FloatRep
+                        DoubleRep -> DoubleRep
+                        other     -> IntRep
+	  in
+	      StAssign pk lhs' (StCall fn cconv pk args)
 \end{code}
 
 DataToTagOp won't work for 64-bit archs, as it is.
@@ -256,6 +321,40 @@ primCode [lhs] DataToTagOp [arg]
     returnUs (\xs -> assign : xs)
 \end{code}
 
+MutVars are pretty simple.
+#define writeMutVarzh(a,v)       (P_)(((StgMutVar *)(a))->var)=(v)
+
+\begin{code}
+primCode [] WriteMutVarOp [aa,vv]
+   = let aa_s      = amodeToStix aa
+         vv_s      = amodeToStix vv
+         var_field = StIndex PtrRep aa_s fixedHS
+         assign    = StAssign PtrRep (StInd PtrRep var_field) vv_s
+     in
+     returnUs (\xs -> assign : xs)
+
+primCode [rr] ReadMutVarOp [aa]
+   = let aa_s      = amodeToStix aa
+         rr_s      = amodeToStix rr
+         var_field = StIndex PtrRep aa_s fixedHS
+         assign    = StAssign PtrRep rr_s (StInd PtrRep var_field)
+     in
+     returnUs (\xs -> assign : xs)
+\end{code}
+
+ForeignObj# primops.
+
+\begin{code}
+primCode [rr] ForeignObjToAddrOp [fo]
+  = let code =  StAssign AddrRep (amodeToStix rr)
+		   (StInd AddrRep 
+			(StIndex PtrRep (amodeToStix fo) fixedHS))
+    in
+    returnUs (\xs -> code : xs)
+
+primCode [] TouchOp [_] = returnUs id
+\end{code}
+
 Now the more mundane operations.
 
 \begin{code}
@@ -268,6 +367,63 @@ primCode lhs op rhs
     returnUs (\ xs -> simplePrim pk lhs' op rhs' : xs)
 \end{code}
 
+Helper fns for some array ops.
+
+\begin{code}
+primCode_ReadByteArrayOp pk [lhs] [obj, ix]
+  = let
+	lhs' = amodeToStix lhs
+    	obj' = amodeToStix obj
+    	ix' = amodeToStix ix
+    	base = StIndex IntRep obj' arrWordsHS
+    	assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
+    in
+    returnUs (\xs -> assign : xs)
+
+
+primCode_IndexOffAddrOp pk [lhs] [obj, ix]
+  = let
+	lhs' = amodeToStix lhs
+    	obj' = amodeToStix obj
+    	ix' = amodeToStix ix
+    	assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
+    in
+    returnUs (\xs -> assign : xs)
+
+
+primCode_IndexOffForeignObjOp pk [lhs] [obj, ix]
+  = let
+	lhs' = amodeToStix lhs
+    	obj' = amodeToStix obj
+    	ix' = amodeToStix ix
+	obj'' = StIndex AddrRep obj' fixedHS
+    	assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix'))
+    in
+    returnUs (\xs -> assign : xs)
+
+
+primCode_WriteOffAddrOp pk [] [obj, ix, v]
+  = let
+	obj' = amodeToStix obj
+    	ix' = amodeToStix ix
+    	v' = amodeToStix v
+    	assign = StAssign pk (StInd pk (StIndex pk obj' ix')) v'
+    in
+    returnUs (\xs -> assign : xs)
+
+
+primCode_WriteByteArrayOp pk [] [obj, ix, v]
+  = let
+	obj' = amodeToStix obj
+    	ix' = amodeToStix ix
+    	v' = amodeToStix v
+    	base = StIndex IntRep obj' arrWordsHS
+    	assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
+    in
+    returnUs (\xs -> assign : xs)
+
+\end{code}
+
 \begin{code}
 simpleCoercion
       :: PrimRep
@@ -327,13 +483,13 @@ amodeToStix am@(CVal rr CharRep)
 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
 
 amodeToStix (CAddr (SpRel off))
-  = StIndex PtrRep stgSp (StInt (toInteger IBOX(off)))
+  = StIndex PtrRep stgSp (StInt (toInteger (iBox off)))
 
 amodeToStix (CAddr (HpRel off))
-  = StIndex IntRep stgHp (StInt (toInteger (- IBOX(off))))
+  = StIndex IntRep stgHp (StInt (toInteger (- (iBox off))))
 
 amodeToStix (CAddr (NodeRel off))
-  = StIndex IntRep stgNode (StInt (toInteger IBOX(off)))
+  = StIndex IntRep stgNode (StInt (toInteger (iBox off)))
 
 amodeToStix (CAddr (CIndex base off pk))
   = StIndex pk (amodeToStix base) (amodeToStix off)
@@ -346,17 +502,15 @@ amodeToStix (CLbl      lbl _) = StCLbl lbl
  -- For CharLike and IntLike, we attempt some trivial constant-folding here.
 
 amodeToStix (CCharLike (CLit (MachChar c)))
-  = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closure+")) (int off))
+  = StIndex Int8Rep cHARLIKE_closure (StInt (toInteger off))
   where
-    off = charLikeSize * ord c
+    off = charLikeSize * (c - mIN_CHARLIKE)
 
 amodeToStix (CCharLike x)
-  = StIndex CharRep charLike off
-  where
-    off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
+  = panic "CCharLike"
 
-amodeToStix (CIntLike (CLit (MachInt i _)))
-  = StLitLbl ((<>) (ptext SLIT("INTLIKE_closure+")) (int off))
+amodeToStix (CIntLike (CLit (MachInt i)))
+  = StIndex Int8Rep iNTLIKE_closure (StInt (toInteger off))
   where
     off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
 
@@ -365,18 +519,17 @@ amodeToStix (CIntLike x)
 
 amodeToStix (CLit core)
   = case core of
-      MachChar c     -> StInt (toInteger (ord c))
+      MachChar c     -> StInt (toInteger c)
       MachStr s	     -> StString s
       MachAddr a     -> StInt a
-      MachInt i _    -> StInt (toInteger i)
-      MachLitLit s _ -> {-trace (_UNPK_ s ++ "\n")-} (litLitToStix (_UNPK_ s))
-      MachFloat d    -> StDouble d
+      MachInt i      -> StInt i
+      MachWord w     -> case word2IntLit core of MachInt iw -> StInt iw
+      MachLitLit s _ -> litLitErr
+      MachLabel l    -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-})
+      MachFloat d    -> StFloat d
       MachDouble d   -> StDouble d
       _ -> panic "amodeToStix:core literal"
 
-amodeToStix (CLitLit s _)
-   = litLitToStix (_UNPK_ s)
-
 amodeToStix (CMacroExpr _ macro [arg])
   = case macro of
       ENTRY_CODE -> amodeToStix arg
@@ -396,18 +549,9 @@ amodeToStix (CMacroExpr _ macro [arg])
       UPD_FRAME_UPDATEE
          -> StInd PtrRep (StIndex PtrRep (amodeToStix arg) 
                                          (StInt (toInteger uF_UPDATEE)))
--- XXX!!!
--- GET_TAG(info_ptr) is supposed to be  get_itbl(info_ptr)->srt_len,
--- which we've had to hand-code here.
-
-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" 
-                           ++ "suggested workaround: use flag -fvia-C\n")
+
+litLitErr = 
+  panic "native code generator can't compile lit-lits, use -fvia-C"
 \end{code}
 
 Sizes of the CharLike and IntLike closures that are arranged as arrays
@@ -416,25 +560,73 @@ in the data segment.  (These are in bytes.)
 \begin{code}
 -- The INTLIKE base pointer
 
-intLikePtr :: StixTree
-
-intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closure"))
+iNTLIKE_closure :: StixTree
+iNTLIKE_closure = StCLbl mkIntlikeClosureLabel
 
 -- The CHARLIKE base
 
-charLike :: StixTree
-
-charLike = sStLitLbl SLIT("CHARLIKE_closure")
+cHARLIKE_closure :: StixTree
+cHARLIKE_closure = StCLbl mkCharlikeClosureLabel
 
--- Trees for the ErrorIOPrimOp
-
-topClosure, errorIO :: StixTree
-
-topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
-errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))
-
-mutArrPtrsFrozen_info = sStLitLbl SLIT("MUT_ARR_PTRS_FROZEN_info")
+mutArrPtrsFrozen_info = StCLbl mkMAP_FROZEN_infoLabel
 
+-- these are the sizes of charLike and intLike closures, in _bytes_.
 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
+		[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
+	   (StPrim IntAddOp [tso, 
+			     StInt (toInteger ((TSO_STACK + rESERVED_STACK_WORDS)
+					       *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}