2 % (c) The AQUA Project, Glasgow University, 1993-1998
6 module StixPrim ( primCode, amodeToStix, amodeToStix' ) where
8 #include "HsVersions.h"
14 import AbsCSyn hiding ( spRel )
15 import AbsCUtils ( getAmodeRep, mixedTypeLocn )
16 import SMRep ( fixedHdrSize )
17 import Literal ( Literal(..), word2IntLit )
18 import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) )
19 import PrimRep ( PrimRep(..), getPrimRepSizeInBytes )
20 import UniqSupply ( returnUs, thenUs, getUniqueUs, UniqSM )
21 import Constants ( mIN_INTLIKE, mIN_CHARLIKE, uF_UPDATEE, bLOCK_SIZE,
22 rESERVED_STACK_WORDS )
23 import CLabel ( mkIntlikeClosureLabel, mkCharlikeClosureLabel,
24 mkMAP_FROZEN_infoLabel, mkEMPTY_MVAR_infoLabel,
26 import CallConv ( cCallConv )
33 The main honcho here is primCode, which handles the guts of COpStmts.
37 :: [CAddrMode] -- results
39 -> [CAddrMode] -- args
40 -> UniqSM StixTreeList
43 First, the dreaded @ccall@. We can't handle @casm@s.
45 Usually, this compiles to an assignment, but when the left-hand side
46 is empty, we just perform the call and ignore the result.
48 btw Why not let programmer use casm to provide assembly code instead
51 The (MP) integer operations are a true nightmare. Since we don't have
52 a convenient abstract way of allocating temporary variables on the (C)
53 stack, we use the space just below HpLim for the @MP_INT@ structures,
54 and modify our heap check accordingly.
57 -- NB: ordering of clauses somewhere driven by
58 -- the desire to getting sane patt-matching behavior
60 primCode [res] IntegerCmpOp args@[sa1,da1, sa2,da2]
61 = gmpCompare res (sa1,da1, sa2,da2)
63 primCode [res] IntegerCmpIntOp args@[sa1,da1,ai]
64 = gmpCompareInt res (sa1,da1,ai)
66 primCode [res] Integer2IntOp arg@[sa,da]
67 = gmpInteger2Int res (sa,da)
69 primCode [res] Integer2WordOp arg@[sa,da]
70 = gmpInteger2Word res (sa,da)
72 primCode [res] Int2AddrOp [arg]
73 = simpleCoercion AddrRep res arg
75 primCode [res] Addr2IntOp [arg]
76 = simpleCoercion IntRep res arg
78 primCode [res] Int2WordOp [arg]
79 = simpleCoercion IntRep{-WordRep?-} res arg
81 primCode [res] Word2IntOp [arg]
82 = simpleCoercion IntRep res arg
84 primCode [res] AddrToHValueOp [arg]
85 = simpleCoercion PtrRep res arg
87 primCode [res] IntToInt8Op [arg]
88 = narrowingCoercion IntRep Int8Rep res arg
89 primCode [res] IntToInt16Op [arg]
90 = narrowingCoercion IntRep Int16Rep res arg
91 primCode [res] IntToInt32Op [arg]
92 = narrowingCoercion IntRep Int32Rep res arg
94 primCode [res] WordToWord8Op [arg]
95 = narrowingCoercion WordRep Word8Rep res arg
96 primCode [res] WordToWord16Op [arg]
97 = narrowingCoercion WordRep Word16Rep res arg
98 primCode [res] WordToWord32Op [arg]
99 = narrowingCoercion WordRep Word32Rep res arg
103 primCode [res] SameMutableArrayOp args
105 compare = StPrim AddrEqOp (map amodeToStix args)
106 assign = StAssign IntRep (amodeToStix res) compare
108 returnUs (\xs -> assign : xs)
110 primCode res@[_] SameMutableByteArrayOp args
111 = primCode res SameMutableArrayOp args
113 primCode res@[_] SameMutVarOp args
114 = primCode res SameMutableArrayOp args
118 primCode res@[_] SameMVarOp args
119 = primCode res SameMutableArrayOp args
121 -- #define isEmptyMVarzh(r,a) \
122 -- r =(I_)((GET_INFO((StgMVar*)(a))) == &stg_EMPTY_MVAR_info )
123 primCode [res] IsEmptyMVarOp [arg]
124 = let res' = amodeToStix res
125 arg' = amodeToStix arg
126 arg_info = StInd PtrRep arg'
127 em_info = StCLbl mkEMPTY_MVAR_infoLabel
128 same = StPrim IntEqOp [arg_info, em_info]
129 assign = StAssign IntRep res' same
131 returnUs (\xs -> assign : xs)
133 -- #define myThreadIdzh(t) (t = CurrentTSO)
134 primCode [res] MyThreadIdOp []
135 = let res' = amodeToStix res
136 in returnUs (\xs -> StAssign ThreadIdRep res' stgCurrentTSO : xs)
140 Freezing an array of pointers is a double assignment. We fix the
141 header of the ``new'' closure because the lhs is probably a better
142 addressing mode for the indirection (most likely, it's a VanillaReg).
146 primCode [lhs] UnsafeFreezeArrayOp [rhs]
148 lhs' = amodeToStix lhs
149 rhs' = amodeToStix rhs
150 header = StInd PtrRep lhs'
151 assign = StAssign PtrRep lhs' rhs'
152 freeze = StAssign PtrRep header mutArrPtrsFrozen_info
154 returnUs (\xs -> assign : freeze : xs)
156 primCode [lhs] UnsafeFreezeByteArrayOp [rhs]
157 = simpleCoercion PtrRep lhs rhs
160 Returning the size of (mutable) byte arrays is just
161 an indexing operation.
164 primCode [lhs] SizeofByteArrayOp [rhs]
166 lhs' = amodeToStix lhs
167 rhs' = amodeToStix rhs
168 sz = StIndex IntRep rhs' fixedHS
169 assign = StAssign IntRep lhs' (StInd IntRep sz)
171 returnUs (\xs -> assign : xs)
173 primCode [lhs] SizeofMutableByteArrayOp [rhs]
175 lhs' = amodeToStix lhs
176 rhs' = amodeToStix rhs
177 sz = StIndex IntRep rhs' fixedHS
178 assign = StAssign IntRep lhs' (StInd IntRep sz)
180 returnUs (\xs -> assign : xs)
184 Most other array primitives translate to simple indexing.
187 primCode lhs@[_] IndexArrayOp args
188 = primCode lhs ReadArrayOp args
190 primCode [lhs] ReadArrayOp [obj, ix]
192 lhs' = amodeToStix lhs
193 obj' = amodeToStix obj
195 base = StIndex IntRep obj' arrPtrsHS
196 assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
198 returnUs (\xs -> assign : xs)
200 primCode [] WriteArrayOp [obj, ix, v]
202 obj' = amodeToStix obj
205 base = StIndex IntRep obj' arrPtrsHS
206 assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
208 returnUs (\xs -> assign : xs)
210 primCode [] WriteForeignObjOp [obj, v]
212 obj' = amodeToStix obj
214 obj'' = StIndex AddrRep obj' (StInt 4711) -- fixedHS
215 assign = StAssign AddrRep (StInd AddrRep obj'') v'
217 returnUs (\xs -> assign : xs)
219 -- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
220 primCode ls IndexByteArrayOp_Char rs = primCode_ReadByteArrayOp Word8Rep ls rs
221 primCode ls IndexByteArrayOp_WideChar rs = primCode_ReadByteArrayOp CharRep ls rs
222 primCode ls IndexByteArrayOp_Int rs = primCode_ReadByteArrayOp IntRep ls rs
223 primCode ls IndexByteArrayOp_Word rs = primCode_ReadByteArrayOp WordRep ls rs
224 primCode ls IndexByteArrayOp_Addr rs = primCode_ReadByteArrayOp AddrRep ls rs
225 primCode ls IndexByteArrayOp_Float rs = primCode_ReadByteArrayOp FloatRep ls rs
226 primCode ls IndexByteArrayOp_Double rs = primCode_ReadByteArrayOp DoubleRep ls rs
227 primCode ls IndexByteArrayOp_StablePtr rs = primCode_ReadByteArrayOp StablePtrRep ls rs
228 primCode ls IndexByteArrayOp_Int8 rs = primCode_ReadByteArrayOp Int8Rep ls rs
229 primCode ls IndexByteArrayOp_Int16 rs = primCode_ReadByteArrayOp Int16Rep ls rs
230 primCode ls IndexByteArrayOp_Int32 rs = primCode_ReadByteArrayOp Int32Rep ls rs
231 primCode ls IndexByteArrayOp_Int64 rs = primCode_ReadByteArrayOp Int64Rep ls rs
232 primCode ls IndexByteArrayOp_Word8 rs = primCode_ReadByteArrayOp Word8Rep ls rs
233 primCode ls IndexByteArrayOp_Word16 rs = primCode_ReadByteArrayOp Word16Rep ls rs
234 primCode ls IndexByteArrayOp_Word32 rs = primCode_ReadByteArrayOp Word32Rep ls rs
235 primCode ls IndexByteArrayOp_Word64 rs = primCode_ReadByteArrayOp Word64Rep ls rs
237 primCode ls ReadByteArrayOp_Char rs = primCode_ReadByteArrayOp Word8Rep ls rs
238 primCode ls ReadByteArrayOp_WideChar rs = primCode_ReadByteArrayOp CharRep ls rs
239 primCode ls ReadByteArrayOp_Int rs = primCode_ReadByteArrayOp IntRep ls rs
240 primCode ls ReadByteArrayOp_Word rs = primCode_ReadByteArrayOp WordRep ls rs
241 primCode ls ReadByteArrayOp_Addr rs = primCode_ReadByteArrayOp AddrRep ls rs
242 primCode ls ReadByteArrayOp_Float rs = primCode_ReadByteArrayOp FloatRep ls rs
243 primCode ls ReadByteArrayOp_Double rs = primCode_ReadByteArrayOp DoubleRep ls rs
244 primCode ls ReadByteArrayOp_StablePtr rs = primCode_ReadByteArrayOp StablePtrRep ls rs
245 primCode ls ReadByteArrayOp_Int8 rs = primCode_ReadByteArrayOp Int8Rep ls rs
246 primCode ls ReadByteArrayOp_Int16 rs = primCode_ReadByteArrayOp Int16Rep ls rs
247 primCode ls ReadByteArrayOp_Int32 rs = primCode_ReadByteArrayOp Int32Rep ls rs
248 primCode ls ReadByteArrayOp_Int64 rs = primCode_ReadByteArrayOp Int64Rep ls rs
249 primCode ls ReadByteArrayOp_Word8 rs = primCode_ReadByteArrayOp Word8Rep ls rs
250 primCode ls ReadByteArrayOp_Word16 rs = primCode_ReadByteArrayOp Word16Rep ls rs
251 primCode ls ReadByteArrayOp_Word32 rs = primCode_ReadByteArrayOp Word32Rep ls rs
252 primCode ls ReadByteArrayOp_Word64 rs = primCode_ReadByteArrayOp Word64Rep ls rs
254 primCode ls WriteByteArrayOp_Char rs = primCode_WriteByteArrayOp Word8Rep ls rs
255 primCode ls WriteByteArrayOp_WideChar rs = primCode_WriteByteArrayOp CharRep ls rs
256 primCode ls WriteByteArrayOp_Int rs = primCode_WriteByteArrayOp IntRep ls rs
257 primCode ls WriteByteArrayOp_Word rs = primCode_WriteByteArrayOp WordRep ls rs
258 primCode ls WriteByteArrayOp_Addr rs = primCode_WriteByteArrayOp AddrRep ls rs
259 primCode ls WriteByteArrayOp_Float rs = primCode_WriteByteArrayOp FloatRep ls rs
260 primCode ls WriteByteArrayOp_Double rs = primCode_WriteByteArrayOp DoubleRep ls rs
261 primCode ls WriteByteArrayOp_StablePtr rs = primCode_WriteByteArrayOp StablePtrRep ls rs
262 primCode ls WriteByteArrayOp_Int8 rs = primCode_WriteByteArrayOp Int8Rep ls rs
263 primCode ls WriteByteArrayOp_Int16 rs = primCode_WriteByteArrayOp Int16Rep ls rs
264 primCode ls WriteByteArrayOp_Int32 rs = primCode_WriteByteArrayOp Int32Rep ls rs
265 primCode ls WriteByteArrayOp_Int64 rs = primCode_WriteByteArrayOp Int64Rep ls rs
266 primCode ls WriteByteArrayOp_Word8 rs = primCode_WriteByteArrayOp Word8Rep ls rs
267 primCode ls WriteByteArrayOp_Word16 rs = primCode_WriteByteArrayOp Word16Rep ls rs
268 primCode ls WriteByteArrayOp_Word32 rs = primCode_WriteByteArrayOp Word32Rep ls rs
269 primCode ls WriteByteArrayOp_Word64 rs = primCode_WriteByteArrayOp Word64Rep ls rs
271 primCode ls IndexOffAddrOp_Char rs = primCode_IndexOffAddrOp Word8Rep ls rs
272 primCode ls IndexOffAddrOp_WideChar rs = primCode_IndexOffAddrOp CharRep ls rs
273 primCode ls IndexOffAddrOp_Int rs = primCode_IndexOffAddrOp IntRep ls rs
274 primCode ls IndexOffAddrOp_Word rs = primCode_IndexOffAddrOp WordRep ls rs
275 primCode ls IndexOffAddrOp_Addr rs = primCode_IndexOffAddrOp AddrRep ls rs
276 primCode ls IndexOffAddrOp_Float rs = primCode_IndexOffAddrOp FloatRep ls rs
277 primCode ls IndexOffAddrOp_Double rs = primCode_IndexOffAddrOp DoubleRep ls rs
278 primCode ls IndexOffAddrOp_StablePtr rs = primCode_IndexOffAddrOp StablePtrRep ls rs
279 primCode ls IndexOffAddrOp_Int8 rs = primCode_IndexOffAddrOp Int8Rep ls rs
280 primCode ls IndexOffAddrOp_Int16 rs = primCode_IndexOffAddrOp Int16Rep ls rs
281 primCode ls IndexOffAddrOp_Int32 rs = primCode_IndexOffAddrOp Int32Rep ls rs
282 primCode ls IndexOffAddrOp_Int64 rs = primCode_IndexOffAddrOp Int64Rep ls rs
283 primCode ls IndexOffAddrOp_Word8 rs = primCode_IndexOffAddrOp Word8Rep ls rs
284 primCode ls IndexOffAddrOp_Word16 rs = primCode_IndexOffAddrOp Word16Rep ls rs
285 primCode ls IndexOffAddrOp_Word32 rs = primCode_IndexOffAddrOp Word32Rep ls rs
286 primCode ls IndexOffAddrOp_Word64 rs = primCode_IndexOffAddrOp Word64Rep ls rs
288 primCode ls IndexOffForeignObjOp_Char rs = primCode_IndexOffForeignObjOp Word8Rep ls rs
289 primCode ls IndexOffForeignObjOp_WideChar rs = primCode_IndexOffForeignObjOp CharRep ls rs
290 primCode ls IndexOffForeignObjOp_Int rs = primCode_IndexOffForeignObjOp IntRep ls rs
291 primCode ls IndexOffForeignObjOp_Word rs = primCode_IndexOffForeignObjOp WordRep ls rs
292 primCode ls IndexOffForeignObjOp_Addr rs = primCode_IndexOffForeignObjOp AddrRep ls rs
293 primCode ls IndexOffForeignObjOp_Float rs = primCode_IndexOffForeignObjOp FloatRep ls rs
294 primCode ls IndexOffForeignObjOp_Double rs = primCode_IndexOffForeignObjOp DoubleRep ls rs
295 primCode ls IndexOffForeignObjOp_StablePtr rs = primCode_IndexOffForeignObjOp StablePtrRep ls rs
296 primCode ls IndexOffForeignObjOp_Int8 rs = primCode_IndexOffForeignObjOp Int8Rep ls rs
297 primCode ls IndexOffForeignObjOp_Int16 rs = primCode_IndexOffForeignObjOp Int16Rep ls rs
298 primCode ls IndexOffForeignObjOp_Int32 rs = primCode_IndexOffForeignObjOp Int32Rep ls rs
299 primCode ls IndexOffForeignObjOp_Int64 rs = primCode_IndexOffForeignObjOp Int64Rep ls rs
300 primCode ls IndexOffForeignObjOp_Word8 rs = primCode_IndexOffForeignObjOp Word8Rep ls rs
301 primCode ls IndexOffForeignObjOp_Word16 rs = primCode_IndexOffForeignObjOp Word16Rep ls rs
302 primCode ls IndexOffForeignObjOp_Word32 rs = primCode_IndexOffForeignObjOp Word32Rep ls rs
303 primCode ls IndexOffForeignObjOp_Word64 rs = primCode_IndexOffForeignObjOp Word64Rep ls rs
305 primCode ls ReadOffAddrOp_Char rs = primCode_IndexOffAddrOp Word8Rep ls rs
306 primCode ls ReadOffAddrOp_WideChar rs = primCode_IndexOffAddrOp CharRep ls rs
307 primCode ls ReadOffAddrOp_Int rs = primCode_IndexOffAddrOp IntRep ls rs
308 primCode ls ReadOffAddrOp_Word rs = primCode_IndexOffAddrOp WordRep ls rs
309 primCode ls ReadOffAddrOp_Addr rs = primCode_IndexOffAddrOp AddrRep ls rs
310 primCode ls ReadOffAddrOp_Float rs = primCode_IndexOffAddrOp FloatRep ls rs
311 primCode ls ReadOffAddrOp_Double rs = primCode_IndexOffAddrOp DoubleRep ls rs
312 primCode ls ReadOffAddrOp_StablePtr rs = primCode_IndexOffAddrOp StablePtrRep ls rs
313 primCode ls ReadOffAddrOp_Int8 rs = primCode_IndexOffAddrOp Int8Rep ls rs
314 primCode ls ReadOffAddrOp_Int16 rs = primCode_IndexOffAddrOp Int16Rep ls rs
315 primCode ls ReadOffAddrOp_Int32 rs = primCode_IndexOffAddrOp Int32Rep ls rs
316 primCode ls ReadOffAddrOp_Int64 rs = primCode_IndexOffAddrOp Int64Rep ls rs
317 primCode ls ReadOffAddrOp_Word8 rs = primCode_IndexOffAddrOp Word8Rep ls rs
318 primCode ls ReadOffAddrOp_Word16 rs = primCode_IndexOffAddrOp Word16Rep ls rs
319 primCode ls ReadOffAddrOp_Word32 rs = primCode_IndexOffAddrOp Word32Rep ls rs
320 primCode ls ReadOffAddrOp_Word64 rs = primCode_IndexOffAddrOp Word64Rep ls rs
322 primCode ls WriteOffAddrOp_Char rs = primCode_WriteOffAddrOp Word8Rep ls rs
323 primCode ls WriteOffAddrOp_WideChar rs = primCode_WriteOffAddrOp CharRep ls rs
324 primCode ls WriteOffAddrOp_Int rs = primCode_WriteOffAddrOp IntRep ls rs
325 primCode ls WriteOffAddrOp_Word rs = primCode_WriteOffAddrOp WordRep ls rs
326 primCode ls WriteOffAddrOp_Addr rs = primCode_WriteOffAddrOp AddrRep ls rs
327 primCode ls WriteOffAddrOp_Float rs = primCode_WriteOffAddrOp FloatRep ls rs
328 primCode ls WriteOffAddrOp_Double rs = primCode_WriteOffAddrOp DoubleRep ls rs
329 primCode ls WriteOffAddrOp_StablePtr rs = primCode_WriteOffAddrOp StablePtrRep ls rs
330 primCode ls WriteOffAddrOp_Int8 rs = primCode_WriteOffAddrOp Int8Rep ls rs
331 primCode ls WriteOffAddrOp_Int16 rs = primCode_WriteOffAddrOp Int16Rep ls rs
332 primCode ls WriteOffAddrOp_Int32 rs = primCode_WriteOffAddrOp Int32Rep ls rs
333 primCode ls WriteOffAddrOp_Int64 rs = primCode_WriteOffAddrOp Int64Rep ls rs
334 primCode ls WriteOffAddrOp_Word8 rs = primCode_WriteOffAddrOp Word8Rep ls rs
335 primCode ls WriteOffAddrOp_Word16 rs = primCode_WriteOffAddrOp Word16Rep ls rs
336 primCode ls WriteOffAddrOp_Word32 rs = primCode_WriteOffAddrOp Word32Rep ls rs
337 primCode ls WriteOffAddrOp_Word64 rs = primCode_WriteOffAddrOp Word64Rep ls rs
341 ToDo: saving/restoring of volatile regs around ccalls.
343 JRS, 001113: always do the call of suspendThread and resumeThread as a ccall
344 rather than inheriting the calling convention of the thing which we're really
348 primCode lhs (CCallOp (CCall (StaticTarget fn) is_asm may_gc cconv)) rhs
349 | is_asm = error "ERROR: Native code generator can't handle casm"
350 | not may_gc = returnUs (\xs -> ccall : xs)
352 save_thread_state `thenUs` \ save ->
353 load_thread_state `thenUs` \ load ->
354 getUniqueUs `thenUs` \ uniq ->
356 id = StReg (StixTemp uniq IntRep)
358 suspend = StAssign IntRep id
359 (StCall SLIT("suspendThread") {-no:cconv-} cCallConv
361 resume = StCall SLIT("resumeThread") {-no:cconv-} cCallConv
364 returnUs (\xs -> save (suspend : ccall : resume : load xs))
367 args = map amodeCodeForCCall rhs
368 amodeCodeForCCall x =
369 let base = amodeToStix' x
371 case getAmodeRep x of
372 ArrayRep -> StIndex PtrRep base arrPtrsHS
373 ByteArrayRep -> StIndex IntRep base arrWordsHS
374 ForeignObjRep -> StInd PtrRep (StIndex PtrRep base fixedHS)
378 [] -> StCall fn cconv VoidRep args
380 let lhs' = amodeToStix lhs
381 pk = case getAmodeRep lhs of
383 DoubleRep -> DoubleRep
386 StAssign pk lhs' (StCall fn cconv pk args)
389 DataToTagOp won't work for 64-bit archs, as it is.
392 primCode [lhs] DataToTagOp [arg]
393 = let lhs' = amodeToStix lhs
394 arg' = amodeToStix arg
395 infoptr = StInd PtrRep arg'
396 word_32 = StInd WordRep (StIndex PtrRep infoptr (StInt (-1)))
397 masked_le32 = StPrim SrlOp [word_32, StInt 16]
398 masked_be32 = StPrim AndOp [word_32, StInt 65535]
399 #ifdef WORDS_BIGENDIAN
404 assign = StAssign IntRep lhs' masked
406 returnUs (\xs -> assign : xs)
409 MutVars are pretty simple.
410 #define writeMutVarzh(a,v) (P_)(((StgMutVar *)(a))->var)=(v)
413 primCode [] WriteMutVarOp [aa,vv]
414 = let aa_s = amodeToStix aa
415 vv_s = amodeToStix vv
416 var_field = StIndex PtrRep aa_s fixedHS
417 assign = StAssign PtrRep (StInd PtrRep var_field) vv_s
419 returnUs (\xs -> assign : xs)
421 primCode [rr] ReadMutVarOp [aa]
422 = let aa_s = amodeToStix aa
423 rr_s = amodeToStix rr
424 var_field = StIndex PtrRep aa_s fixedHS
425 assign = StAssign PtrRep rr_s (StInd PtrRep var_field)
427 returnUs (\xs -> assign : xs)
433 primCode [rr] ForeignObjToAddrOp [fo]
434 = let code = StAssign AddrRep (amodeToStix rr)
436 (StIndex PtrRep (amodeToStix fo) fixedHS))
438 returnUs (\xs -> code : xs)
440 primCode [] TouchOp [_] = returnUs id
443 Now the more mundane operations.
448 lhs' = map amodeToStix lhs
449 rhs' = map amodeToStix' rhs
450 pk = getAmodeRep (head lhs)
452 returnUs (\ xs -> simplePrim pk lhs' op rhs' : xs)
455 Helper fns for some array ops.
458 primCode_ReadByteArrayOp pk [lhs] [obj, ix]
460 lhs' = amodeToStix lhs
461 obj' = amodeToStix obj
463 base = StIndex IntRep obj' arrWordsHS
464 assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
466 returnUs (\xs -> assign : xs)
469 primCode_IndexOffAddrOp pk [lhs] [obj, ix]
471 lhs' = amodeToStix lhs
472 obj' = amodeToStix obj
474 assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
476 returnUs (\xs -> assign : xs)
479 primCode_IndexOffForeignObjOp pk [lhs] [obj, ix]
481 lhs' = amodeToStix lhs
482 obj' = amodeToStix obj
484 obj'' = StIndex AddrRep obj' fixedHS
485 assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix'))
487 returnUs (\xs -> assign : xs)
490 primCode_WriteOffAddrOp pk [] [obj, ix, v]
492 obj' = amodeToStix obj
495 assign = StAssign pk (StInd pk (StIndex pk obj' ix')) v'
497 returnUs (\xs -> assign : xs)
500 primCode_WriteByteArrayOp pk [] [obj, ix, v]
502 obj' = amodeToStix obj
505 base = StIndex IntRep obj' arrWordsHS
506 assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
508 returnUs (\xs -> assign : xs)
517 -> UniqSM StixTreeList
519 simpleCoercion pk lhs rhs
520 = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
523 -- Rewrite a narrowing coercion into a pair of shifts.
525 :: PrimRep -> PrimRep
526 -> CAddrMode -> CAddrMode
527 -> UniqSM StixTreeList
529 narrowingCoercion pks pkd dst src
531 = panic "StixPrim.narrowingCoercion"
533 = returnUs (\xs -> StAssign pkd dst' src' : xs)
535 = returnUs (\xs -> assign : xs)
537 szs = getPrimRepSizeInBytes pks
538 szd = getPrimRepSizeInBytes pkd
539 src' = amodeToStix src
540 dst' = amodeToStix dst
541 shift_amt = fromIntegral (8 * (szs - szd))
545 (StPrim (if signed then ISraOp else SrlOp)
546 [StPrim SllOp [src', StInt shift_amt],
550 Int8Rep -> True; Int16Rep -> True
551 Int32Rep -> True; Int64Rep -> True; IntRep -> True
552 Word8Rep -> False; Word16Rep -> False
553 Word32Rep -> False; Word64Rep -> False; WordRep -> False
554 other -> pprPanic "StixPrim.narrowingCoercion" (ppr pkd)
557 Here we try to rewrite primitives into a form the code generator can
558 understand. Any primitives not handled here must be handled at the
559 level of the specific code generator.
563 :: PrimRep -- Rep of first destination
564 -> [StixTree] -- Destinations
570 Now look for something more conventional.
573 simplePrim pk [lhs] op rest = StAssign pk lhs (StPrim op rest)
574 simplePrim pk as op bs = simplePrim_error op
577 = error ("ERROR: primitive operation `"++show op++"'cannot be handled\nby the native-code generator. Workaround: use -fvia-C.\n(Perhaps you should report it as a GHC bug, also.)\n")
580 %---------------------------------------------------------------------
582 Here we generate the Stix code for CAddrModes.
584 When a character is fetched from a mixed type location, we have to do
585 an extra cast. This is reflected in amodeCode', which is for rhs
586 amodes that might possibly need the extra cast.
589 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
591 amodeToStix'{-'-} am@(CVal rr CharRep)
592 | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
593 | otherwise = amodeToStix am
595 amodeToStix' am = amodeToStix am
598 amodeToStix am@(CVal rr CharRep)
600 = StInd IntRep (amodeToStix (CAddr rr))
602 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
604 amodeToStix (CAddr (SpRel off))
605 = StIndex PtrRep stgSp (StInt (toInteger (iBox off)))
607 amodeToStix (CAddr (HpRel off))
608 = StIndex IntRep stgHp (StInt (toInteger (- (iBox off))))
610 amodeToStix (CAddr (NodeRel off))
611 = StIndex IntRep stgNode (StInt (toInteger (iBox off)))
613 amodeToStix (CAddr (CIndex base off pk))
614 = StIndex pk (amodeToStix base) (amodeToStix off)
616 amodeToStix (CReg magic) = StReg (StixMagicId magic)
617 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
619 amodeToStix (CLbl lbl _) = StCLbl lbl
621 -- For CharLike and IntLike, we attempt some trivial constant-folding here.
623 amodeToStix (CCharLike (CLit (MachChar c)))
624 = StIndex Word8Rep cHARLIKE_closure (StInt (toInteger off))
626 off = charLikeSize * (c - mIN_CHARLIKE)
628 amodeToStix (CCharLike x)
631 amodeToStix (CIntLike (CLit (MachInt i)))
632 = StIndex Word8Rep iNTLIKE_closure (StInt (toInteger off))
634 off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
636 amodeToStix (CIntLike x)
639 amodeToStix (CLit core)
641 MachChar c -> StInt (toInteger c)
642 MachStr s -> StString s
643 MachAddr a -> StInt a
645 MachWord w -> case word2IntLit core of MachInt iw -> StInt iw
646 MachLitLit s _ -> litLitErr
647 MachLabel l -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-})
648 MachFloat d -> StFloat d
649 MachDouble d -> StDouble d
650 _ -> panic "amodeToStix:core literal"
652 amodeToStix (CMacroExpr _ macro [arg])
654 ENTRY_CODE -> amodeToStix arg
655 ARG_TAG -> amodeToStix arg -- just an integer no. of words
657 #ifdef WORDS_BIGENDIAN
659 [StInd WordRep (StIndex PtrRep (amodeToStix arg)
660 (StInt (toInteger (-1)))),
664 [StInd WordRep (StIndex PtrRep (amodeToStix arg)
665 (StInt (toInteger (-1)))),
669 -> StInd PtrRep (StIndex PtrRep (amodeToStix arg)
670 (StInt (toInteger uF_UPDATEE)))
673 panic "native code generator can't compile lit-lits, use -fvia-C"
676 Sizes of the CharLike and IntLike closures that are arranged as arrays
677 in the data segment. (These are in bytes.)
680 -- The INTLIKE base pointer
682 iNTLIKE_closure :: StixTree
683 iNTLIKE_closure = StCLbl mkIntlikeClosureLabel
687 cHARLIKE_closure :: StixTree
688 cHARLIKE_closure = StCLbl mkCharlikeClosureLabel
690 mutArrPtrsFrozen_info = StCLbl mkMAP_FROZEN_infoLabel
692 -- these are the sizes of charLike and intLike closures, in _bytes_.
693 charLikeSize = (fixedHdrSize + 1) * (sizeOf PtrRep)
694 intLikeSize = (fixedHdrSize + 1) * (sizeOf PtrRep)
700 = getUniqueUs `thenUs` \tso_uq ->
701 let tso = StReg (StixTemp tso_uq ThreadIdRep) in
703 StAssign ThreadIdRep tso stgCurrentTSO :
705 (StInd PtrRep (StPrim IntAddOp
706 [tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]))
709 (StInd PtrRep (StPrim IntAddOp
710 [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))]))
713 (StInd PtrRep (StPrim IntAddOp
715 StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]))
716 (StPrim IntAddOp [stgHp, StInt (toInteger (1 * BYTES_PER_WORD))]) :
721 = getUniqueUs `thenUs` \tso_uq ->
722 let tso = StReg (StixTemp tso_uq ThreadIdRep) in
724 StAssign ThreadIdRep tso stgCurrentTSO :
725 StAssign PtrRep stgSp
726 (StInd PtrRep (StPrim IntAddOp
727 [tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])) :
728 StAssign PtrRep stgSu
729 (StInd PtrRep (StPrim IntAddOp
730 [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))])) :
731 StAssign PtrRep stgSpLim
732 (StPrim IntAddOp [tso,
733 StInt (toInteger ((TSO_STACK + rESERVED_STACK_WORDS)
734 *BYTES_PER_WORD))]) :
735 StAssign PtrRep stgHp
737 StInd PtrRep (StPrim IntAddOp
739 StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]),
740 StInt (toInteger (1 * BYTES_PER_WORD))
742 StAssign PtrRep stgHpLim
744 StInd PtrRep (StPrim IntAddOp
746 StInt (toInteger (BDESCR_START * BYTES_PER_WORD))]),
747 StInt (toInteger (bLOCK_SIZE - (1 * BYTES_PER_WORD)))