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, UniqSM )
-import Constants ( mIN_INTLIKE )
+import UniqSupply ( returnUs, thenUs, getUniqueUs, UniqSM )
+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.
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
lhs' = amodeToStix lhs
obj' = amodeToStix obj
ix' = amodeToStix ix
- obj'' = StIndex PtrRep obj' fixedHS
+ 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
assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
in
returnUs (\xs -> assign : xs)
+
+primCode [] WriteForeignObjOp [obj, v]
+ = let
+ obj' = amodeToStix obj
+ v' = amodeToStix v
+ obj'' = StIndex AddrRep obj' (StInt 4711) -- fixedHS
+ assign = StAssign AddrRep (StInd AddrRep obj'') v'
+ in
+ returnUs (\xs -> assign : xs)
\end{code}
+ToDo: saving/restoring of volatile regs around ccalls.
+
\begin{code}
---primCode lhs (CCallOp fn is_asm may_gc) 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") cconv IntRep [stgBaseReg])
+ resume = StCall SLIT("resumeThread") cconv VoidRep [id]
+ in
+ returnUs (\xs -> save (suspend : ccall : resume : load xs))
+
where
args = map amodeCodeForCCall rhs
amodeCodeForCCall x =
ByteArrayRep -> StIndex IntRep base arrWordsHS
ForeignObjRep -> StIndex PtrRep base fixedHS
_ -> base
+
+ ccall = case lhs of
+ [] -> StCall fn cconv VoidRep args
+ [lhs] ->
+ let lhs' = amodeToStix lhs
+ pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
+ in
+ StAssign pk lhs' (StCall fn cconv pk args)
\end{code}
DataToTagOp won't work for 64-bit archs, as it is.
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
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