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(..), getPrimRepArrayElemSize )
21 import UniqSupply ( returnUs, thenUs, getUniqueUs, UniqSM )
22 import Constants ( wORD_SIZE,
23 mIN_INTLIKE, mIN_CHARLIKE, uF_UPDATEE, bLOCK_SIZE,
24 rESERVED_STACK_WORDS )
25 import CLabel ( mkIntlikeClosureLabel, mkCharlikeClosureLabel,
26 mkMAP_FROZEN_infoLabel, mkEMPTY_MVAR_infoLabel,
28 import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..),
29 CCallConv(..), playSafe )
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@. We can't handle @casm@s.
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 btw Why not let programmer use casm to provide assembly code instead
60 ToDo: saving/restoring of volatile regs around ccalls.
62 JRS, 001113: always do the call of suspendThread and resumeThread as a ccall
63 rather than inheriting the calling convention of the thing which we're really
67 foreignCallCode lhs call@(CCall (CCallSpec ctarget cconv safety)) rhs
69 | not (playSafe safety)
70 = returnUs (\xs -> ccall : xs)
73 = save_thread_state `thenUs` \ save ->
74 load_thread_state `thenUs` \ load ->
75 getUniqueUs `thenUs` \ uniq ->
77 id = StixTemp (StixVReg uniq IntRep)
79 suspend = StAssignReg IntRep id
80 (StCall (Left SLIT("suspendThread")) {-no:cconv-} CCallConv
81 IntRep [StReg stgBaseReg])
83 (StCall (Left SLIT("resumeThread")) {-no:cconv-} CCallConv
86 returnUs (\xs -> save (suspend : ccall : resume : load xs))
91 StaticTarget nm -> (rhs, Left nm)
92 DynamicTarget | not (null rhs) -- an assertion
93 -> (tail rhs, Right (amodeToStix (head rhs)))
95 -> ncgPrimopMoan "Native code generator can't handle foreign call"
98 stix_args = map amodeCodeForCCall cargs
100 let base = amodeToStix' x
102 case getAmodeRep x of
103 ArrayRep -> StIndex PtrRep base arrPtrsHS
104 ByteArrayRep -> StIndex IntRep base arrWordsHS
105 ForeignObjRep -> StInd PtrRep (StIndex PtrRep base fixedHS)
109 [] -> StVoidable (StCall stix_target cconv VoidRep stix_args)
110 [lhs] -> mkStAssign pk lhs' (StCall stix_target cconv pk stix_args)
112 lhs' = amodeToStix lhs
113 pk = case getAmodeRep lhs of
115 DoubleRep -> DoubleRep
117 Word64Rep -> Word64Rep
121 %************************************************************************
123 \subsubsection{Code for @CAddrMode@s}
125 %************************************************************************
127 When a character is fetched from a mixed type location, we have to do
128 an extra cast. This is reflected in amodeCode', which is for rhs
129 amodes that might possibly need the extra cast.
132 amodeToStix, amodeToStix' :: CAddrMode -> StixExpr
134 amodeToStix'{-'-} am@(CVal rr CharRep)
135 | mixedTypeLocn am = StMachOp MO_NatS_to_32U [amodeToStix am]
136 | otherwise = amodeToStix am
141 amodeToStix am@(CVal rr CharRep)
143 = StInd IntRep (amodeToStix (CAddr rr))
145 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
147 amodeToStix CBytesPerWord
148 = StInt (toInteger wORD_SIZE)
150 amodeToStix (CAddr (SpRel off))
151 = StIndex PtrRep (StReg stgSp) (StInt (toInteger (iBox off)))
153 amodeToStix (CAddr (HpRel off))
154 = StIndex IntRep (StReg stgHp) (StInt (toInteger (- (iBox off))))
156 amodeToStix (CAddr (NodeRel off))
157 = StIndex IntRep (StReg stgNode) (StInt (toInteger (iBox off)))
159 amodeToStix (CAddr (CIndex base off pk))
160 = StIndex pk (amodeToStix base) (amodeToStix off)
162 amodeToStix (CReg magic) = StReg (StixMagicId magic)
163 amodeToStix (CTemp uniq pk) = StReg (StixTemp (StixVReg uniq pk))
165 amodeToStix (CLbl lbl _) = StCLbl lbl
167 -- For CharLike and IntLike, we attempt some trivial constant-folding here.
169 amodeToStix (CCharLike (CLit (MachChar c)))
170 = StIndex Word8Rep cHARLIKE_closure (StInt (toInteger off))
172 off = charLikeSize * (c - mIN_CHARLIKE)
174 amodeToStix (CCharLike x)
175 = panic "amodeToStix.CCharLike"
177 amodeToStix (CIntLike (CLit (MachInt i)))
178 = StIndex Word8Rep iNTLIKE_closure (StInt (toInteger off))
180 off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
182 amodeToStix (CIntLike x)
183 = panic "amodeToStix.CIntLike"
185 amodeToStix (CLit core)
187 MachChar c -> StInt (toInteger c)
188 MachStr s -> StString s
189 MachAddr a -> StInt a
191 MachWord w -> case word2IntLit core of MachInt iw -> StInt iw
192 MachLitLit s _ -> litLitErr
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 ENTRY_CODE -> amodeToStix arg
201 ARG_TAG -> amodeToStix arg -- just an integer no. of words
203 #ifdef WORDS_BIGENDIAN
205 [StInd WordRep (StIndex PtrRep (amodeToStix arg)
206 (StInt (toInteger (-1)))),
210 [StInd WordRep (StIndex PtrRep (amodeToStix arg)
211 (StInt (toInteger (-1)))),
215 -> StInd PtrRep (StIndex PtrRep (amodeToStix arg)
216 (StInt (toInteger uF_UPDATEE)))
219 = pprPanic "StixPrim.amodeToStix" (pprAmode other)
222 = ncgPrimopMoan "native code generator can't handle lit-lits" empty
225 Sizes of the CharLike and IntLike closures that are arranged as arrays
226 in the data segment. (These are in bytes.)
229 -- The INTLIKE base pointer
231 iNTLIKE_closure :: StixExpr
232 iNTLIKE_closure = StCLbl mkIntlikeClosureLabel
236 cHARLIKE_closure :: StixExpr
237 cHARLIKE_closure = StCLbl mkCharlikeClosureLabel
239 mutArrPtrsFrozen_info = StCLbl mkMAP_FROZEN_infoLabel
241 -- these are the sizes of charLike and intLike closures, in _bytes_.
242 charLikeSize = (fixedHdrSize + 1) * (getPrimRepArrayElemSize PtrRep)
243 intLikeSize = (fixedHdrSize + 1) * (getPrimRepArrayElemSize PtrRep)
249 = getUniqueUs `thenUs` \ tso_uq ->
250 let tso = StixTemp (StixVReg tso_uq ThreadIdRep) in
252 StAssignReg ThreadIdRep tso (StReg stgCurrentTSO)
255 [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])
259 [StReg tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))])
263 [StReg stgCurrentNursery,
264 StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))])
266 [StReg stgHp, StInt (toInteger (1 * BYTES_PER_WORD))])
271 = getUniqueUs `thenUs` \ tso_uq ->
272 let tso = StixTemp (StixVReg tso_uq ThreadIdRep) in
274 StAssignReg ThreadIdRep tso (StReg stgCurrentTSO)
279 [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]))
284 [StReg tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))]))
289 StInt (toInteger ((TSO_STACK + rESERVED_STACK_WORDS)
296 [StReg stgCurrentNursery,
297 StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]),
298 StInt (toInteger (1 * BYTES_PER_WORD))
304 (StIndex PtrRep (StReg stgCurrentNursery)
305 (StInt (toInteger BDESCR_START))
309 [StMachOp MO_NatU_Mul
311 (StIndex PtrRep (StReg stgCurrentNursery)
312 (StInt (toInteger BDESCR_BLOCKS))),
313 StInt (toInteger bLOCK_SIZE{-in bytes-})
315 StInt (1 * BYTES_PER_WORD)