2 % (c) The AQUA Project, Glasgow University, 1993-1998
6 module StixPrim ( amodeToStix, amodeToStix', foreignCallCode )
9 #include "HsVersions.h"
14 import PprAbsC ( pprAmode )
15 import AbsCSyn hiding ( spRel )
16 import AbsCUtils ( getAmodeRep, mixedTypeLocn )
17 import SMRep ( fixedHdrSize )
18 import Literal ( Literal(..), word2IntLit )
19 import MachOp ( MachOp(..) )
20 import PrimRep ( PrimRep(..), getPrimRepSizeInBytes )
21 import UniqSupply ( returnUs, thenUs, getUniqueUs, UniqSM )
22 import Constants ( mIN_INTLIKE, mIN_CHARLIKE, bLOCK_SIZE,
23 rESERVED_STACK_WORDS )
24 import CLabel ( mkIntlikeClosureLabel, mkCharlikeClosureLabel,
26 import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..),
27 CCallConv(..), playSafe, playThreadSafe )
29 import Util ( notNull )
37 The main honchos here are primCode and foreignCallCode, which handle the guts of COpStmts.
41 :: [CAddrMode] -- results
43 -> [CAddrMode] -- args
44 -> UniqSM StixStmtList
47 %************************************************************************
49 \subsubsection{Code for foreign calls}
51 %************************************************************************
53 First, the dreaded @ccall@.
55 Usually, this compiles to an assignment, but when the left-hand side
56 is empty, we just perform the call and ignore the result.
58 ToDo: saving/restoring of volatile regs around ccalls.
60 JRS, 001113: always do the call of suspendThread and resumeThread as a ccall
61 rather than inheriting the calling convention of the thing which we're really
65 foreignCallCode lhs call@(CCall (CCallSpec ctarget cconv safety)) rhs
67 | not (playSafe safety)
68 = returnUs (\xs -> ccall : xs)
71 = save_thread_state `thenUs` \ save ->
72 load_thread_state `thenUs` \ load ->
73 getUniqueUs `thenUs` \ uniq ->
75 id = StixTemp (StixVReg uniq IntRep)
78 | playThreadSafe safety = 1
81 suspend = StAssignReg IntRep id
82 (StCall (Left FSLIT("suspendThread")) {-no:cconv-} CCallConv
83 IntRep [StReg stgBaseReg, StInt is_threadSafe ])
85 (StCall (Left FSLIT("resumeThread")) {-no:cconv-} CCallConv
86 VoidRep [StReg id, StInt is_threadSafe ])
88 returnUs (\xs -> save (suspend : ccall : resume : load xs))
93 StaticTarget nm -> (rhs, Left nm)
94 DynamicTarget | notNull rhs -- an assertion
95 -> (tail rhs, Right (amodeToStix (head rhs)))
97 stix_args = map amodeToStix' cargs
100 [] -> StVoidable (StCall stix_target cconv VoidRep stix_args)
101 [lhs] -> mkStAssign pk lhs' (StCall stix_target cconv pk stix_args)
103 lhs' = amodeToStix lhs
104 pk = case getAmodeRep lhs of
106 DoubleRep -> DoubleRep
108 Word64Rep -> Word64Rep
111 -- a bit late to catch this here..
112 foreignCallCode _ DNCall{} _
113 = panic "foreignCallCode: .NET interop not supported via NCG; compile with -fvia-C"
116 %************************************************************************
118 \subsubsection{Code for @CAddrMode@s}
120 %************************************************************************
122 When a character is fetched from a mixed type location, we have to do
123 an extra cast. This is reflected in amodeCode', which is for rhs
124 amodes that might possibly need the extra cast.
127 amodeToStix, amodeToStix' :: CAddrMode -> StixExpr
129 amodeToStix'{-'-} am@(CVal rr CharRep)
130 | mixedTypeLocn am = StMachOp MO_NatS_to_32U [amodeToStix am]
131 | otherwise = amodeToStix am
136 amodeToStix am@(CVal rr CharRep)
138 = StInd IntRep (amodeToStix (CAddr rr))
140 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
142 amodeToStix (CAddr (SpRel off))
143 = StIndex PtrRep (StReg stgSp) (StInt (toInteger (iBox off)))
145 amodeToStix (CAddr (HpRel off))
146 = StIndex IntRep (StReg stgHp) (StInt (toInteger (- (iBox off))))
148 amodeToStix (CAddr (NodeRel off))
149 = StIndex IntRep (StReg stgNode) (StInt (toInteger (iBox off)))
151 amodeToStix (CAddr (CIndex base off pk))
152 = StIndex pk (amodeToStix base) (amodeToStix off)
154 amodeToStix (CReg magic) = StReg (StixMagicId magic)
155 amodeToStix (CTemp uniq pk) = StReg (StixTemp (StixVReg uniq pk))
157 amodeToStix (CLbl lbl _) = StCLbl lbl
159 -- For CharLike and IntLike, we attempt some trivial constant-folding here.
161 amodeToStix (CCharLike (CLit (MachChar c)))
162 = StIndex Word8Rep cHARLIKE_closure (StInt (toInteger off))
164 off = charLikeSize * (ord c - mIN_CHARLIKE)
166 amodeToStix (CCharLike x)
167 = panic "amodeToStix.CCharLike"
169 amodeToStix (CIntLike (CLit (MachInt i)))
170 = StIndex Word8Rep iNTLIKE_closure (StInt (toInteger off))
172 off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
174 amodeToStix (CIntLike x)
175 = panic "amodeToStix.CIntLike"
177 amodeToStix (CLit core)
179 MachChar c -> StInt (toInteger (ord c))
180 MachStr s -> StString s
181 MachNullAddr -> StInt 0
183 MachWord w -> case word2IntLit core of MachInt iw -> StInt iw
184 -- dreadful, but rare.
185 MachLabel l (Just x) -> StCLbl (mkForeignLabel (mkFastString (unpackFS l ++ '@':show x)) False)
186 MachLabel l _ -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-})
187 MachFloat d -> StFloat d
188 MachDouble d -> StDouble d
189 _ -> panic "amodeToStix:core literal"
191 amodeToStix (CMacroExpr _ macro [arg])
193 arg_amode = amodeToStix arg
196 ENTRY_CODE -> arg_amode
197 ARG_TAG -> arg_amode -- just an integer no. of words
199 #ifdef WORDS_BIGENDIAN
201 [StInd WordRep (StIndex PtrRep arg_amode
202 (StInt (toInteger (-1)))),
206 [StInd WordRep (StIndex PtrRep arg_amode
207 (StInt (toInteger (-1)))),
210 BYTE_ARR_CTS -> StIndex IntRep arg_amode arrWordsHS
211 PTRS_ARR_CTS -> StIndex PtrRep arg_amode arrPtrsHS
212 ForeignObj_CLOSURE_DATA -> StInd PtrRep (StIndex PtrRep arg_amode fixedHS)
216 = pprPanic "StixPrim.amodeToStix" (pprAmode other)
219 Sizes of the CharLike and IntLike closures that are arranged as arrays
220 in the data segment. (These are in bytes.)
223 -- The INTLIKE base pointer
225 iNTLIKE_closure :: StixExpr
226 iNTLIKE_closure = StCLbl mkIntlikeClosureLabel
230 cHARLIKE_closure :: StixExpr
231 cHARLIKE_closure = StCLbl mkCharlikeClosureLabel
233 -- these are the sizes of charLike and intLike closures, in _bytes_.
234 charLikeSize = (fixedHdrSize + 1) * (getPrimRepSizeInBytes PtrRep)
235 intLikeSize = (fixedHdrSize + 1) * (getPrimRepSizeInBytes PtrRep)
241 = getUniqueUs `thenUs` \ tso_uq ->
242 let tso = StixTemp (StixVReg tso_uq PtrRep) in
244 StAssignReg PtrRep tso (StReg stgCurrentTSO)
247 [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])
251 [StReg stgCurrentNursery,
252 StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))])
254 [StReg stgHp, StInt (toInteger (1 * BYTES_PER_WORD))])
259 = getUniqueUs `thenUs` \ tso_uq ->
260 let tso = StixTemp (StixVReg tso_uq PtrRep) in
262 StAssignReg PtrRep tso (StReg stgCurrentTSO)
267 [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]))
272 StInt (toInteger ((TSO_STACK + rESERVED_STACK_WORDS)
279 [StReg stgCurrentNursery,
280 StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]),
281 StInt (toInteger (1 * BYTES_PER_WORD))
287 (StIndex PtrRep (StReg stgCurrentNursery)
288 (StInt (toInteger BDESCR_START))
292 [StMachOp MO_NatU_Mul
294 (StIndex PtrRep (StReg stgCurrentNursery)
295 (StInt (toInteger BDESCR_BLOCKS))),
296 StInt (toInteger bLOCK_SIZE{-in bytes-})
298 StInt (1 * BYTES_PER_WORD)