#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 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 CLabel ( mkIntlikeClosureLabel, mkCharlikeClosureLabel,
+ mkMAP_FROZEN_infoLabel, mkForeignLabel )
import Outputable
-import Char ( ord )
+import Char ( ord, isAlpha, isDigit )
+
+#include "NCG.h"
\end{code}
The main honcho here is primCode, which handles the guts of COpStmts.
| 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
-- For CharLike and IntLike, we attempt some trivial constant-folding here.
amodeToStix (CCharLike (CLit (MachChar c)))
- = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closure+")) (int off))
+ = StIndex CharRep cHARLIKE_closure (StInt (toInteger off))
where
off = charLikeSize * ord c
amodeToStix (CCharLike x)
- = StIndex CharRep charLike off
+ = StIndex CharRep cHARLIKE_closure off
where
off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
amodeToStix (CIntLike (CLit (MachInt i)))
- = StLitLbl ((<>) (ptext SLIT("INTLIKE_closure+")) (int off))
+ = StIndex CharRep{-yes,really-} iNTLIKE_closure (StInt (toInteger off))
where
off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
MachAddr a -> StInt a
MachInt i -> StInt i
MachWord w -> case word2IntLit core of MachInt iw -> StInt iw
- MachLitLit s _ -> litLitToStix (_UNPK_ s)
+ MachLitLit s _ -> litLitErr
+ MachLabel l -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-})
MachFloat d -> StDouble 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
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
\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")
-
--- Trees for the ErrorIOPrimOp
+cHARLIKE_closure :: StixTree
+cHARLIKE_closure = StCLbl mkCharlikeClosureLabel
-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
+ [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}
projects / ghc-hetmet.git / blobdiff