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 (CCall (CCallSpec (StaticTarget fn) 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 SLIT("suspendThread") {-no:cconv-} CCallConv
81 IntRep [StReg stgBaseReg])
83 (StCall SLIT("resumeThread") {-no:cconv-} CCallConv
86 returnUs (\xs -> save (suspend : ccall : resume : load xs))
89 args = map amodeCodeForCCall rhs
91 let base = amodeToStix' x
94 ArrayRep -> StIndex PtrRep base arrPtrsHS
95 ByteArrayRep -> StIndex IntRep base arrWordsHS
96 ForeignObjRep -> StInd PtrRep (StIndex PtrRep base fixedHS)
100 [] -> StVoidable (StCall fn cconv VoidRep args)
101 [lhs] -> mkStAssign pk lhs' (StCall fn cconv pk args)
103 lhs' = amodeToStix lhs
104 pk = case getAmodeRep lhs of
106 DoubleRep -> DoubleRep
108 Word64Rep -> Word64Rep
111 foreignCallCode lhs call rhs
112 = ncgPrimopMoan "Native code generator can't handle foreign call" (ppr call)
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 CBytesPerWord
142 = StInt (toInteger wORD_SIZE)
144 amodeToStix (CMem pk addr) = StInd pk (amodeToStix addr)
146 amodeToStix (CAddr (SpRel off))
147 = StIndex PtrRep (StReg stgSp) (StInt (toInteger (iBox off)))
149 amodeToStix (CAddr (HpRel off))
150 = StIndex IntRep (StReg stgHp) (StInt (toInteger (- (iBox off))))
152 amodeToStix (CAddr (NodeRel off))
153 = StIndex IntRep (StReg stgNode) (StInt (toInteger (iBox off)))
155 amodeToStix (CAddr (CIndex base off pk))
156 = StIndex pk (amodeToStix base) (amodeToStix off)
158 amodeToStix (CReg magic) = StReg (StixMagicId magic)
159 amodeToStix (CTemp uniq pk) = StReg (StixTemp (StixVReg uniq pk))
161 amodeToStix (CLbl lbl _) = StCLbl lbl
163 -- For CharLike and IntLike, we attempt some trivial constant-folding here.
165 amodeToStix (CCharLike (CLit (MachChar c)))
166 = StIndex Word8Rep cHARLIKE_closure (StInt (toInteger off))
168 off = charLikeSize * (c - mIN_CHARLIKE)
170 amodeToStix (CCharLike x)
171 = panic "amodeToStix.CCharLike"
173 amodeToStix (CIntLike (CLit (MachInt i)))
174 = StIndex Word8Rep iNTLIKE_closure (StInt (toInteger off))
176 off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
178 amodeToStix (CIntLike x)
179 = panic "amodeToStix.CIntLike"
181 amodeToStix (CLit core)
183 MachChar c -> StInt (toInteger c)
184 MachStr s -> StString s
185 MachAddr a -> StInt a
187 MachWord w -> case word2IntLit core of MachInt iw -> StInt iw
188 MachLitLit s _ -> litLitErr
189 MachLabel l -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-})
190 MachFloat d -> StFloat d
191 MachDouble d -> StDouble d
192 _ -> panic "amodeToStix:core literal"
194 amodeToStix (CMacroExpr _ macro [arg])
196 ENTRY_CODE -> amodeToStix arg
197 ARG_TAG -> amodeToStix arg -- just an integer no. of words
199 #ifdef WORDS_BIGENDIAN
201 [StInd WordRep (StIndex PtrRep (amodeToStix arg)
202 (StInt (toInteger (-1)))),
206 [StInd WordRep (StIndex PtrRep (amodeToStix arg)
207 (StInt (toInteger (-1)))),
211 -> StInd PtrRep (StIndex PtrRep (amodeToStix arg)
212 (StInt (toInteger uF_UPDATEE)))
215 = pprPanic "StixPrim.amodeToStix" (pprAmode other)
218 = ncgPrimopMoan "native code generator can't handle lit-lits" empty
221 Sizes of the CharLike and IntLike closures that are arranged as arrays
222 in the data segment. (These are in bytes.)
225 -- The INTLIKE base pointer
227 iNTLIKE_closure :: StixExpr
228 iNTLIKE_closure = StCLbl mkIntlikeClosureLabel
232 cHARLIKE_closure :: StixExpr
233 cHARLIKE_closure = StCLbl mkCharlikeClosureLabel
235 mutArrPtrsFrozen_info = StCLbl mkMAP_FROZEN_infoLabel
237 -- these are the sizes of charLike and intLike closures, in _bytes_.
238 charLikeSize = (fixedHdrSize + 1) * (getPrimRepArrayElemSize PtrRep)
239 intLikeSize = (fixedHdrSize + 1) * (getPrimRepArrayElemSize PtrRep)
245 = getUniqueUs `thenUs` \ tso_uq ->
246 let tso = StixTemp (StixVReg tso_uq ThreadIdRep) in
248 StAssignReg ThreadIdRep tso (StReg stgCurrentTSO)
251 [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])
255 [StReg tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))])
259 [StReg stgCurrentNursery,
260 StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))])
262 [StReg stgHp, StInt (toInteger (1 * BYTES_PER_WORD))])
267 = getUniqueUs `thenUs` \ tso_uq ->
268 let tso = StixTemp (StixVReg tso_uq ThreadIdRep) in
270 StAssignReg ThreadIdRep tso (StReg stgCurrentTSO)
275 [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]))
280 [StReg tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))]))
285 StInt (toInteger ((TSO_STACK + rESERVED_STACK_WORDS)
292 [StReg stgCurrentNursery,
293 StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]),
294 StInt (toInteger (1 * BYTES_PER_WORD))
301 [StReg stgCurrentNursery,
302 StInt (toInteger (BDESCR_START * BYTES_PER_WORD))]),
303 StInt (toInteger (bLOCK_SIZE - (1 * BYTES_PER_WORD)))