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, playThreadSafe )
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)
80 | playThreadSafe safety = 1
83 suspend = StAssignReg IntRep id
84 (StCall (Left SLIT("suspendThread")) {-no:cconv-} CCallConv
85 IntRep [StReg stgBaseReg, StInt is_threadSafe ])
87 (StCall (Left SLIT("resumeThread")) {-no:cconv-} CCallConv
88 VoidRep [StReg id, StInt is_threadSafe ])
90 returnUs (\xs -> save (suspend : ccall : resume : load xs))
95 StaticTarget nm -> (rhs, Left nm)
96 DynamicTarget | not (null rhs) -- an assertion
97 -> (tail rhs, Right (amodeToStix (head rhs)))
99 -> ncgPrimopMoan "Native code generator can't handle foreign call"
102 stix_args = map amodeCodeForCCall cargs
103 amodeCodeForCCall x =
104 let base = amodeToStix' x
106 case getAmodeRep x of
107 ArrayRep -> StIndex PtrRep base arrPtrsHS
108 ByteArrayRep -> StIndex IntRep base arrWordsHS
109 ForeignObjRep -> StInd PtrRep (StIndex PtrRep base fixedHS)
113 [] -> StVoidable (StCall stix_target cconv VoidRep stix_args)
114 [lhs] -> mkStAssign pk lhs' (StCall stix_target cconv pk stix_args)
116 lhs' = amodeToStix lhs
117 pk = case getAmodeRep lhs of
119 DoubleRep -> DoubleRep
121 Word64Rep -> Word64Rep
125 %************************************************************************
127 \subsubsection{Code for @CAddrMode@s}
129 %************************************************************************
131 When a character is fetched from a mixed type location, we have to do
132 an extra cast. This is reflected in amodeCode', which is for rhs
133 amodes that might possibly need the extra cast.
136 amodeToStix, amodeToStix' :: CAddrMode -> StixExpr
138 amodeToStix'{-'-} am@(CVal rr CharRep)
139 | mixedTypeLocn am = StMachOp MO_NatS_to_32U [amodeToStix am]
140 | otherwise = amodeToStix am
145 amodeToStix am@(CVal rr CharRep)
147 = StInd IntRep (amodeToStix (CAddr rr))
149 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
151 amodeToStix CBytesPerWord
152 = StInt (toInteger wORD_SIZE)
154 amodeToStix (CAddr (SpRel off))
155 = StIndex PtrRep (StReg stgSp) (StInt (toInteger (iBox off)))
157 amodeToStix (CAddr (HpRel off))
158 = StIndex IntRep (StReg stgHp) (StInt (toInteger (- (iBox off))))
160 amodeToStix (CAddr (NodeRel off))
161 = StIndex IntRep (StReg stgNode) (StInt (toInteger (iBox off)))
163 amodeToStix (CAddr (CIndex base off pk))
164 = StIndex pk (amodeToStix base) (amodeToStix off)
166 amodeToStix (CReg magic) = StReg (StixMagicId magic)
167 amodeToStix (CTemp uniq pk) = StReg (StixTemp (StixVReg uniq pk))
169 amodeToStix (CLbl lbl _) = StCLbl lbl
171 -- For CharLike and IntLike, we attempt some trivial constant-folding here.
173 amodeToStix (CCharLike (CLit (MachChar c)))
174 = StIndex Word8Rep cHARLIKE_closure (StInt (toInteger off))
176 off = charLikeSize * (c - mIN_CHARLIKE)
178 amodeToStix (CCharLike x)
179 = panic "amodeToStix.CCharLike"
181 amodeToStix (CIntLike (CLit (MachInt i)))
182 = StIndex Word8Rep iNTLIKE_closure (StInt (toInteger off))
184 off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
186 amodeToStix (CIntLike x)
187 = panic "amodeToStix.CIntLike"
189 amodeToStix (CLit core)
191 MachChar c -> StInt (toInteger c)
192 MachStr s -> StString s
193 MachAddr a -> StInt a
195 MachWord w -> case word2IntLit core of MachInt iw -> StInt iw
196 MachLitLit s _ -> litLitErr
197 MachLabel l -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-})
198 MachFloat d -> StFloat d
199 MachDouble d -> StDouble d
200 _ -> panic "amodeToStix:core literal"
202 amodeToStix (CMacroExpr _ macro [arg])
204 ENTRY_CODE -> amodeToStix arg
205 ARG_TAG -> amodeToStix arg -- just an integer no. of words
207 #ifdef WORDS_BIGENDIAN
209 [StInd WordRep (StIndex PtrRep (amodeToStix arg)
210 (StInt (toInteger (-1)))),
214 [StInd WordRep (StIndex PtrRep (amodeToStix arg)
215 (StInt (toInteger (-1)))),
219 -> StInd PtrRep (StIndex PtrRep (amodeToStix arg)
220 (StInt (toInteger uF_UPDATEE)))
223 = pprPanic "StixPrim.amodeToStix" (pprAmode other)
226 = ncgPrimopMoan "native code generator can't handle lit-lits" empty
229 Sizes of the CharLike and IntLike closures that are arranged as arrays
230 in the data segment. (These are in bytes.)
233 -- The INTLIKE base pointer
235 iNTLIKE_closure :: StixExpr
236 iNTLIKE_closure = StCLbl mkIntlikeClosureLabel
240 cHARLIKE_closure :: StixExpr
241 cHARLIKE_closure = StCLbl mkCharlikeClosureLabel
243 mutArrPtrsFrozen_info = StCLbl mkMAP_FROZEN_infoLabel
245 -- these are the sizes of charLike and intLike closures, in _bytes_.
246 charLikeSize = (fixedHdrSize + 1) * (getPrimRepArrayElemSize PtrRep)
247 intLikeSize = (fixedHdrSize + 1) * (getPrimRepArrayElemSize PtrRep)
253 = getUniqueUs `thenUs` \ tso_uq ->
254 let tso = StixTemp (StixVReg tso_uq ThreadIdRep) in
256 StAssignReg ThreadIdRep tso (StReg stgCurrentTSO)
259 [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])
263 [StReg tso, StInt (toInteger (TSO_SU*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 ThreadIdRep) in
278 StAssignReg ThreadIdRep tso (StReg stgCurrentTSO)
283 [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]))
288 [StReg tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))]))
293 StInt (toInteger ((TSO_STACK + rESERVED_STACK_WORDS)
300 [StReg stgCurrentNursery,
301 StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]),
302 StInt (toInteger (1 * BYTES_PER_WORD))
308 (StIndex PtrRep (StReg stgCurrentNursery)
309 (StInt (toInteger BDESCR_START))
313 [StMachOp MO_NatU_Mul
315 (StIndex PtrRep (StReg stgCurrentNursery)
316 (StInt (toInteger BDESCR_BLOCKS))),
317 StInt (toInteger bLOCK_SIZE{-in bytes-})
319 StInt (1 * BYTES_PER_WORD)