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 )
36 The main honchos here are primCode and foreignCallCode, which handle the guts of COpStmts.
40 :: [CAddrMode] -- results
42 -> [CAddrMode] -- args
43 -> UniqSM StixStmtList
46 %************************************************************************
48 \subsubsection{Code for foreign calls}
50 %************************************************************************
52 First, the dreaded @ccall@.
54 Usually, this compiles to an assignment, but when the left-hand side
55 is empty, we just perform the call and ignore the result.
57 ToDo: saving/restoring of volatile regs around ccalls.
59 JRS, 001113: always do the call of suspendThread and resumeThread as a ccall
60 rather than inheriting the calling convention of the thing which we're really
64 foreignCallCode lhs call@(CCall (CCallSpec ctarget cconv safety)) rhs
66 | not (playSafe safety)
67 = returnUs (\xs -> ccall : xs)
70 = save_thread_state `thenUs` \ save ->
71 load_thread_state `thenUs` \ load ->
72 getUniqueUs `thenUs` \ uniq ->
74 id = StixTemp (StixVReg uniq IntRep)
77 | playThreadSafe safety = 1
80 suspend = StAssignReg IntRep id
81 (StCall (Left FSLIT("suspendThread")) {-no:cconv-} CCallConv
82 IntRep [StReg stgBaseReg, StInt is_threadSafe ])
84 (StCall (Left FSLIT("resumeThread")) {-no:cconv-} CCallConv
85 VoidRep [StReg id, StInt is_threadSafe ])
87 returnUs (\xs -> save (suspend : ccall : resume : load xs))
92 StaticTarget nm -> (rhs, Left nm)
93 DynamicTarget | notNull rhs -- an assertion
94 -> (tail rhs, Right (amodeToStix (head rhs)))
96 stix_args = map amodeToStix' cargs
99 [] -> StVoidable (StCall stix_target cconv VoidRep stix_args)
100 [lhs] -> mkStAssign pk lhs' (StCall stix_target cconv pk stix_args)
102 lhs' = amodeToStix lhs
103 pk = case getAmodeRep lhs of
105 DoubleRep -> DoubleRep
107 Word64Rep -> Word64Rep
110 -- a bit late to catch this here..
111 foreignCallCode _ DNCall{} _
112 = panic "foreignCallCode: .NET interop not supported via NCG; compile with -fvia-C"
115 %************************************************************************
117 \subsubsection{Code for @CAddrMode@s}
119 %************************************************************************
121 When a character is fetched from a mixed type location, we have to do
122 an extra cast. This is reflected in amodeCode', which is for rhs
123 amodes that might possibly need the extra cast.
126 amodeToStix, amodeToStix' :: CAddrMode -> StixExpr
128 amodeToStix'{-'-} am@(CVal rr CharRep)
129 | mixedTypeLocn am = StMachOp MO_NatS_to_32U [amodeToStix am]
130 | otherwise = amodeToStix am
135 amodeToStix am@(CVal rr CharRep)
137 = StInd IntRep (amodeToStix (CAddr rr))
139 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
141 amodeToStix (CAddr (SpRel off))
142 = StIndex PtrRep (StReg stgSp) (StInt (toInteger (iBox off)))
144 amodeToStix (CAddr (HpRel off))
145 = StIndex IntRep (StReg stgHp) (StInt (toInteger (- (iBox off))))
147 amodeToStix (CAddr (NodeRel off))
148 = StIndex IntRep (StReg stgNode) (StInt (toInteger (iBox off)))
150 amodeToStix (CAddr (CIndex base off pk))
151 = StIndex pk (amodeToStix base) (amodeToStix off)
153 amodeToStix (CReg magic) = StReg (StixMagicId magic)
154 amodeToStix (CTemp uniq pk) = StReg (StixTemp (StixVReg uniq pk))
156 amodeToStix (CLbl lbl _) = StCLbl lbl
158 -- For CharLike and IntLike, we attempt some trivial constant-folding here.
160 amodeToStix (CCharLike (CLit (MachChar c)))
161 = StIndex Word8Rep cHARLIKE_closure (StInt (toInteger off))
163 off = charLikeSize * (c - mIN_CHARLIKE)
165 amodeToStix (CCharLike x)
166 = panic "amodeToStix.CCharLike"
168 amodeToStix (CIntLike (CLit (MachInt i)))
169 = StIndex Word8Rep iNTLIKE_closure (StInt (toInteger off))
171 off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
173 amodeToStix (CIntLike x)
174 = panic "amodeToStix.CIntLike"
176 amodeToStix (CLit core)
178 MachChar c -> StInt (toInteger c)
179 MachStr s -> StString s
180 MachNullAddr -> StInt 0
182 MachWord w -> case word2IntLit core of MachInt iw -> StInt iw
183 -- dreadful, but rare.
184 MachLabel l (Just x) -> StCLbl (mkForeignLabel (mkFastString (unpackFS l ++ '@':show x)) False)
185 MachLabel l _ -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-})
186 MachFloat d -> StFloat d
187 MachDouble d -> StDouble d
188 _ -> panic "amodeToStix:core literal"
190 amodeToStix (CMacroExpr _ macro [arg])
192 arg_amode = amodeToStix arg
195 ENTRY_CODE -> arg_amode
196 ARG_TAG -> arg_amode -- just an integer no. of words
198 #ifdef WORDS_BIGENDIAN
200 [StInd WordRep (StIndex PtrRep arg_amode
201 (StInt (toInteger (-1)))),
205 [StInd WordRep (StIndex PtrRep arg_amode
206 (StInt (toInteger (-1)))),
209 BYTE_ARR_CTS -> StIndex IntRep arg_amode arrWordsHS
210 PTRS_ARR_CTS -> StIndex PtrRep arg_amode arrPtrsHS
211 ForeignObj_CLOSURE_DATA -> StInd PtrRep (StIndex PtrRep arg_amode fixedHS)
215 = pprPanic "StixPrim.amodeToStix" (pprAmode other)
218 Sizes of the CharLike and IntLike closures that are arranged as arrays
219 in the data segment. (These are in bytes.)
222 -- The INTLIKE base pointer
224 iNTLIKE_closure :: StixExpr
225 iNTLIKE_closure = StCLbl mkIntlikeClosureLabel
229 cHARLIKE_closure :: StixExpr
230 cHARLIKE_closure = StCLbl mkCharlikeClosureLabel
232 -- these are the sizes of charLike and intLike closures, in _bytes_.
233 charLikeSize = (fixedHdrSize + 1) * (getPrimRepSizeInBytes PtrRep)
234 intLikeSize = (fixedHdrSize + 1) * (getPrimRepSizeInBytes PtrRep)
240 = getUniqueUs `thenUs` \ tso_uq ->
241 let tso = StixTemp (StixVReg tso_uq PtrRep) in
243 StAssignReg PtrRep tso (StReg stgCurrentTSO)
246 [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])
250 [StReg stgCurrentNursery,
251 StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))])
253 [StReg stgHp, StInt (toInteger (1 * BYTES_PER_WORD))])
258 = getUniqueUs `thenUs` \ tso_uq ->
259 let tso = StixTemp (StixVReg tso_uq PtrRep) in
261 StAssignReg PtrRep tso (StReg stgCurrentTSO)
266 [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]))
271 StInt (toInteger ((TSO_STACK + rESERVED_STACK_WORDS)
278 [StReg stgCurrentNursery,
279 StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]),
280 StInt (toInteger (1 * BYTES_PER_WORD))
286 (StIndex PtrRep (StReg stgCurrentNursery)
287 (StInt (toInteger BDESCR_START))
291 [StMachOp MO_NatU_Mul
293 (StIndex PtrRep (StReg stgCurrentNursery)
294 (StInt (toInteger BDESCR_BLOCKS))),
295 StInt (toInteger bLOCK_SIZE{-in bytes-})
297 StInt (1 * BYTES_PER_WORD)