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, uF_UPDATEE, bLOCK_SIZE,
23 rESERVED_STACK_WORDS )
24 import CLabel ( mkIntlikeClosureLabel, mkCharlikeClosureLabel,
25 mkMAP_FROZEN_infoLabel,
27 import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..),
28 CCallConv(..), playSafe, playThreadSafe )
30 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@. We can't handle @casm@s.
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 btw Why not let programmer use casm to provide assembly code instead
61 ToDo: saving/restoring of volatile regs around ccalls.
63 JRS, 001113: always do the call of suspendThread and resumeThread as a ccall
64 rather than inheriting the calling convention of the thing which we're really
68 foreignCallCode lhs call@(CCall (CCallSpec ctarget cconv safety)) rhs
70 | not (playSafe safety)
71 = returnUs (\xs -> ccall : xs)
74 = save_thread_state `thenUs` \ save ->
75 load_thread_state `thenUs` \ load ->
76 getUniqueUs `thenUs` \ uniq ->
78 id = StixTemp (StixVReg uniq IntRep)
81 | playThreadSafe safety = 1
84 suspend = StAssignReg IntRep id
85 (StCall (Left FSLIT("suspendThread")) {-no:cconv-} CCallConv
86 IntRep [StReg stgBaseReg, StInt is_threadSafe ])
88 (StCall (Left FSLIT("resumeThread")) {-no:cconv-} CCallConv
89 VoidRep [StReg id, StInt is_threadSafe ])
91 returnUs (\xs -> save (suspend : ccall : resume : load xs))
96 StaticTarget nm -> (rhs, Left nm)
97 DynamicTarget | notNull rhs -- an assertion
98 -> (tail rhs, Right (amodeToStix (head rhs)))
100 -> ncgPrimopMoan "Native code generator can't handle foreign call"
103 stix_args = map amodeToStix' cargs
106 [] -> StVoidable (StCall stix_target cconv VoidRep stix_args)
107 [lhs] -> mkStAssign pk lhs' (StCall stix_target cconv pk stix_args)
109 lhs' = amodeToStix lhs
110 pk = case getAmodeRep lhs of
112 DoubleRep -> DoubleRep
114 Word64Rep -> Word64Rep
117 -- a bit late to catch this here..
118 foreignCallCode _ DNCall{} _
119 = panic "foreignCallCode: .NET interop not supported via NCG; compile with -fvia-C"
122 %************************************************************************
124 \subsubsection{Code for @CAddrMode@s}
126 %************************************************************************
128 When a character is fetched from a mixed type location, we have to do
129 an extra cast. This is reflected in amodeCode', which is for rhs
130 amodes that might possibly need the extra cast.
133 amodeToStix, amodeToStix' :: CAddrMode -> StixExpr
135 amodeToStix'{-'-} am@(CVal rr CharRep)
136 | mixedTypeLocn am = StMachOp MO_NatS_to_32U [amodeToStix am]
137 | otherwise = amodeToStix am
142 amodeToStix am@(CVal rr CharRep)
144 = StInd IntRep (amodeToStix (CAddr rr))
146 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
148 amodeToStix (CAddr (SpRel off))
149 = StIndex PtrRep (StReg stgSp) (StInt (toInteger (iBox off)))
151 amodeToStix (CAddr (HpRel off))
152 = StIndex IntRep (StReg stgHp) (StInt (toInteger (- (iBox off))))
154 amodeToStix (CAddr (NodeRel off))
155 = StIndex IntRep (StReg stgNode) (StInt (toInteger (iBox off)))
157 amodeToStix (CAddr (CIndex base off pk))
158 = StIndex pk (amodeToStix base) (amodeToStix off)
160 amodeToStix (CReg magic) = StReg (StixMagicId magic)
161 amodeToStix (CTemp uniq pk) = StReg (StixTemp (StixVReg uniq pk))
163 amodeToStix (CLbl lbl _) = StCLbl lbl
165 -- For CharLike and IntLike, we attempt some trivial constant-folding here.
167 amodeToStix (CCharLike (CLit (MachChar c)))
168 = StIndex Word8Rep cHARLIKE_closure (StInt (toInteger off))
170 off = charLikeSize * (c - mIN_CHARLIKE)
172 amodeToStix (CCharLike x)
173 = panic "amodeToStix.CCharLike"
175 amodeToStix (CIntLike (CLit (MachInt i)))
176 = StIndex Word8Rep iNTLIKE_closure (StInt (toInteger off))
178 off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
180 amodeToStix (CIntLike x)
181 = panic "amodeToStix.CIntLike"
183 amodeToStix (CLit core)
185 MachChar c -> StInt (toInteger c)
186 MachStr s -> StString s
187 MachNullAddr -> StInt 0
189 MachWord w -> case word2IntLit core of MachInt iw -> StInt iw
190 MachLitLit s _ -> litLitErr
191 -- dreadful, but rare.
192 MachLabel l (Just x) -> StCLbl (mkForeignLabel (mkFastString (unpackFS l ++ '@':show x)) False)
193 MachLabel l _ -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-})
194 MachFloat d -> StFloat d
195 MachDouble d -> StDouble d
196 _ -> panic "amodeToStix:core literal"
198 amodeToStix (CMacroExpr _ macro [arg])
200 arg_amode = amodeToStix arg
203 ENTRY_CODE -> arg_amode
204 ARG_TAG -> arg_amode -- just an integer no. of words
206 #ifdef WORDS_BIGENDIAN
208 [StInd WordRep (StIndex PtrRep arg_amode
209 (StInt (toInteger (-1)))),
213 [StInd WordRep (StIndex PtrRep arg_amode
214 (StInt (toInteger (-1)))),
218 -> StInd PtrRep (StIndex PtrRep arg_amode
219 (StInt (toInteger uF_UPDATEE)))
221 BYTE_ARR_CTS -> StIndex IntRep arg_amode arrWordsHS
222 PTRS_ARR_CTS -> StIndex PtrRep arg_amode arrPtrsHS
223 ForeignObj_CLOSURE_DATA -> StInd PtrRep (StIndex PtrRep arg_amode fixedHS)
227 = pprPanic "StixPrim.amodeToStix" (pprAmode other)
230 = ncgPrimopMoan "native code generator can't handle lit-lits" empty
233 Sizes of the CharLike and IntLike closures that are arranged as arrays
234 in the data segment. (These are in bytes.)
237 -- The INTLIKE base pointer
239 iNTLIKE_closure :: StixExpr
240 iNTLIKE_closure = StCLbl mkIntlikeClosureLabel
244 cHARLIKE_closure :: StixExpr
245 cHARLIKE_closure = StCLbl mkCharlikeClosureLabel
247 mutArrPtrsFrozen_info = StCLbl mkMAP_FROZEN_infoLabel
249 -- these are the sizes of charLike and intLike closures, in _bytes_.
250 charLikeSize = (fixedHdrSize + 1) * (getPrimRepSizeInBytes PtrRep)
251 intLikeSize = (fixedHdrSize + 1) * (getPrimRepSizeInBytes PtrRep)
257 = getUniqueUs `thenUs` \ tso_uq ->
258 let tso = StixTemp (StixVReg tso_uq PtrRep) in
260 StAssignReg PtrRep tso (StReg stgCurrentTSO)
263 [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])
267 [StReg stgCurrentNursery,
268 StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))])
270 [StReg stgHp, StInt (toInteger (1 * BYTES_PER_WORD))])
275 = getUniqueUs `thenUs` \ tso_uq ->
276 let tso = StixTemp (StixVReg tso_uq PtrRep) in
278 StAssignReg PtrRep tso (StReg stgCurrentTSO)
283 [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]))
288 StInt (toInteger ((TSO_STACK + rESERVED_STACK_WORDS)
295 [StReg stgCurrentNursery,
296 StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]),
297 StInt (toInteger (1 * BYTES_PER_WORD))
303 (StIndex PtrRep (StReg stgCurrentNursery)
304 (StInt (toInteger BDESCR_START))
308 [StMachOp MO_NatU_Mul
310 (StIndex PtrRep (StReg stgCurrentNursery)
311 (StInt (toInteger BDESCR_BLOCKS))),
312 StInt (toInteger bLOCK_SIZE{-in bytes-})
314 StInt (1 * BYTES_PER_WORD)