2 % (c) The AQUA Project, Glasgow University, 1993-1998
6 module StixPrim ( primCode, amodeToStix, amodeToStix' ) where
8 #include "HsVersions.h"
15 import AbsCSyn hiding ( spRel )
16 import AbsCUtils ( getAmodeRep, mixedTypeLocn )
17 import SMRep ( fixedHdrSize )
18 import Literal ( Literal(..), word2IntLit )
19 import CallConv ( cCallConv )
20 import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) )
21 import PrimRep ( PrimRep(..), isFloatingRep )
22 import UniqSupply ( returnUs, thenUs, getUniqueUs, UniqSM )
23 import Constants ( mIN_INTLIKE, uF_UPDATEE, bLOCK_SIZE )
26 import Char ( ord, isAlphaNum )
31 The main honcho here is primCode, which handles the guts of COpStmts.
35 :: [CAddrMode] -- results
37 -> [CAddrMode] -- args
38 -> UniqSM StixTreeList
41 First, the dreaded @ccall@. We can't handle @casm@s.
43 Usually, this compiles to an assignment, but when the left-hand side
44 is empty, we just perform the call and ignore the result.
46 btw Why not let programmer use casm to provide assembly code instead
49 The (MP) integer operations are a true nightmare. Since we don't have
50 a convenient abstract way of allocating temporary variables on the (C)
51 stack, we use the space just below HpLim for the @MP_INT@ structures,
52 and modify our heap check accordingly.
55 -- NB: ordering of clauses somewhere driven by
56 -- the desire to getting sane patt-matching behavior
57 primCode res@[sr,dr] IntegerNegOp arg@[sa,da]
58 = gmpNegate (sr,dr) (sa,da)
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
86 primCode [res] SameMutableArrayOp args
88 compare = StPrim AddrEqOp (map amodeToStix args)
89 assign = StAssign IntRep (amodeToStix res) compare
91 returnUs (\xs -> assign : xs)
93 primCode res@[_] SameMutableByteArrayOp args
94 = primCode res SameMutableArrayOp args
96 primCode res@[_] SameMutVarOp args
97 = primCode res SameMutableArrayOp args
99 primCode res@[_] SameMVarOp args
100 = primCode res SameMutableArrayOp args
103 Freezing an array of pointers is a double assignment. We fix the
104 header of the ``new'' closure because the lhs is probably a better
105 addressing mode for the indirection (most likely, it's a VanillaReg).
109 primCode [lhs] UnsafeFreezeArrayOp [rhs]
111 lhs' = amodeToStix lhs
112 rhs' = amodeToStix rhs
113 header = StInd PtrRep lhs'
114 assign = StAssign PtrRep lhs' rhs'
115 freeze = StAssign PtrRep header mutArrPtrsFrozen_info
117 returnUs (\xs -> assign : freeze : xs)
119 primCode [lhs] UnsafeFreezeByteArrayOp [rhs]
120 = simpleCoercion PtrRep lhs rhs
123 Returning the size of (mutable) byte arrays is just
124 an indexing operation.
127 primCode [lhs] SizeofByteArrayOp [rhs]
129 lhs' = amodeToStix lhs
130 rhs' = amodeToStix rhs
131 sz = StIndex IntRep rhs' fixedHS
132 assign = StAssign IntRep lhs' (StInd IntRep sz)
134 returnUs (\xs -> assign : xs)
136 primCode [lhs] SizeofMutableByteArrayOp [rhs]
138 lhs' = amodeToStix lhs
139 rhs' = amodeToStix rhs
140 sz = StIndex IntRep rhs' fixedHS
141 assign = StAssign IntRep lhs' (StInd IntRep sz)
143 returnUs (\xs -> assign : xs)
147 Most other array primitives translate to simple indexing.
150 primCode lhs@[_] IndexArrayOp args
151 = primCode lhs ReadArrayOp args
153 primCode [lhs] ReadArrayOp [obj, ix]
155 lhs' = amodeToStix lhs
156 obj' = amodeToStix obj
158 base = StIndex IntRep obj' arrPtrsHS
159 assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
161 returnUs (\xs -> assign : xs)
163 primCode [] WriteArrayOp [obj, ix, v]
165 obj' = amodeToStix obj
168 base = StIndex IntRep obj' arrPtrsHS
169 assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
171 returnUs (\xs -> assign : xs)
173 primCode lhs@[_] (IndexByteArrayOp pk) args
174 = primCode lhs (ReadByteArrayOp pk) args
176 -- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
178 primCode [lhs] (ReadByteArrayOp pk) [obj, ix]
180 lhs' = amodeToStix lhs
181 obj' = amodeToStix obj
183 base = StIndex IntRep obj' arrWordsHS
184 assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
186 returnUs (\xs -> assign : xs)
188 primCode lhs@[_] (ReadOffAddrOp pk) args
189 = primCode lhs (IndexOffAddrOp pk) args
191 primCode [lhs] (IndexOffAddrOp pk) [obj, ix]
193 lhs' = amodeToStix lhs
194 obj' = amodeToStix obj
196 assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
198 returnUs (\xs -> assign : xs)
200 primCode [lhs] (IndexOffForeignObjOp pk) [obj, ix]
202 lhs' = amodeToStix lhs
203 obj' = amodeToStix obj
205 obj'' = StIndex AddrRep obj' fixedHS
206 assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix'))
208 returnUs (\xs -> assign : xs)
210 primCode [] (WriteOffAddrOp pk) [obj, ix, v]
212 obj' = amodeToStix obj
215 assign = StAssign pk (StInd pk (StIndex pk obj' ix')) v'
217 returnUs (\xs -> assign : xs)
219 primCode [] (WriteByteArrayOp pk) [obj, ix, v]
221 obj' = amodeToStix obj
224 base = StIndex IntRep obj' arrWordsHS
225 assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
227 returnUs (\xs -> assign : xs)
229 primCode [] WriteForeignObjOp [obj, v]
231 obj' = amodeToStix obj
233 obj'' = StIndex AddrRep obj' (StInt 4711) -- fixedHS
234 assign = StAssign AddrRep (StInd AddrRep obj'') v'
236 returnUs (\xs -> assign : xs)
239 ToDo: saving/restoring of volatile regs around ccalls.
242 primCode lhs (CCallOp (CCall (StaticTarget fn) is_asm may_gc cconv)) rhs
243 | is_asm = error "ERROR: Native code generator can't handle casm"
244 | not may_gc = returnUs (\xs -> ccall : xs)
246 save_thread_state `thenUs` \ save ->
247 load_thread_state `thenUs` \ load ->
248 getUniqueUs `thenUs` \ uniq ->
250 id = StReg (StixTemp uniq IntRep)
252 suspend = StAssign IntRep id
253 (StCall SLIT("suspendThread") cconv IntRep [stgBaseReg])
254 resume = StCall SLIT("resumeThread") cconv VoidRep [id]
256 returnUs (\xs -> save (suspend : ccall : resume : load xs))
259 args = map amodeCodeForCCall rhs
260 amodeCodeForCCall x =
261 let base = amodeToStix' x
263 case getAmodeRep x of
264 ArrayRep -> StIndex PtrRep base arrPtrsHS
265 ByteArrayRep -> StIndex IntRep base arrWordsHS
266 ForeignObjRep -> StIndex PtrRep base fixedHS
270 [] -> StCall fn cconv VoidRep args
272 let lhs' = amodeToStix lhs
273 pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
275 StAssign pk lhs' (StCall fn cconv pk args)
278 DataToTagOp won't work for 64-bit archs, as it is.
281 primCode [lhs] DataToTagOp [arg]
282 = let lhs' = amodeToStix lhs
283 arg' = amodeToStix arg
284 infoptr = StInd PtrRep arg'
285 word_32 = StInd WordRep (StIndex PtrRep infoptr (StInt (-1)))
286 masked_le32 = StPrim SrlOp [word_32, StInt 16]
287 masked_be32 = StPrim AndOp [word_32, StInt 65535]
288 #ifdef WORDS_BIGENDIAN
293 assign = StAssign IntRep lhs' masked
295 returnUs (\xs -> assign : xs)
298 MutVars are pretty simple.
299 #define writeMutVarzh(a,v) (P_)(((StgMutVar *)(a))->var)=(v)
302 primCode [] WriteMutVarOp [aa,vv]
303 = let aa_s = amodeToStix aa
304 vv_s = amodeToStix vv
305 var_field = StIndex PtrRep aa_s fixedHS
306 assign = StAssign PtrRep (StInd PtrRep var_field) vv_s
308 returnUs (\xs -> assign : xs)
310 primCode [rr] ReadMutVarOp [aa]
311 = let aa_s = amodeToStix aa
312 rr_s = amodeToStix rr
313 var_field = StIndex PtrRep aa_s fixedHS
314 assign = StAssign PtrRep rr_s (StInd PtrRep var_field)
316 returnUs (\xs -> assign : xs)
319 Now the more mundane operations.
324 lhs' = map amodeToStix lhs
325 rhs' = map amodeToStix' rhs
326 pk = getAmodeRep (head lhs)
328 returnUs (\ xs -> simplePrim pk lhs' op rhs' : xs)
336 -> UniqSM StixTreeList
338 simpleCoercion pk lhs rhs
339 = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
342 Here we try to rewrite primitives into a form the code generator can
343 understand. Any primitives not handled here must be handled at the
344 level of the specific code generator.
348 :: PrimRep -- Rep of first destination
349 -> [StixTree] -- Destinations
355 Now look for something more conventional.
358 simplePrim pk [lhs] op rest = StAssign pk lhs (StPrim op rest)
359 simplePrim pk as op bs = simplePrim_error op
362 = 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")
365 %---------------------------------------------------------------------
367 Here we generate the Stix code for CAddrModes.
369 When a character is fetched from a mixed type location, we have to do
370 an extra cast. This is reflected in amodeCode', which is for rhs
371 amodes that might possibly need the extra cast.
374 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
376 amodeToStix'{-'-} am@(CVal rr CharRep)
377 | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
378 | otherwise = amodeToStix am
380 amodeToStix' am = amodeToStix am
383 amodeToStix am@(CVal rr CharRep)
385 = StInd IntRep (amodeToStix (CAddr rr))
387 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
389 amodeToStix (CAddr (SpRel off))
390 = StIndex PtrRep stgSp (StInt (toInteger IBOX(off)))
392 amodeToStix (CAddr (HpRel off))
393 = StIndex IntRep stgHp (StInt (toInteger (- IBOX(off))))
395 amodeToStix (CAddr (NodeRel off))
396 = StIndex IntRep stgNode (StInt (toInteger IBOX(off)))
398 amodeToStix (CAddr (CIndex base off pk))
399 = StIndex pk (amodeToStix base) (amodeToStix off)
401 amodeToStix (CReg magic) = StReg (StixMagicId magic)
402 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
404 amodeToStix (CLbl lbl _) = StCLbl lbl
406 -- For CharLike and IntLike, we attempt some trivial constant-folding here.
408 amodeToStix (CCharLike (CLit (MachChar c)))
409 = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closure+")) (int off))
411 off = charLikeSize * ord c
413 amodeToStix (CCharLike x)
414 = StIndex CharRep charLike off
416 off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
418 amodeToStix (CIntLike (CLit (MachInt i)))
419 = StLitLbl ((<>) (ptext SLIT("INTLIKE_closure+")) (int off))
421 off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
423 amodeToStix (CIntLike x)
426 amodeToStix (CLit core)
428 MachChar c -> StInt (toInteger (ord c))
429 MachStr s -> StString s
430 MachAddr a -> StInt a
432 MachWord w -> case word2IntLit core of MachInt iw -> StInt iw
433 MachLitLit s _ -> litLitToStix (_UNPK_ s)
434 MachFloat d -> StDouble d
435 MachDouble d -> StDouble d
436 _ -> panic "amodeToStix:core literal"
438 amodeToStix (CLitLit s _)
439 = litLitToStix (_UNPK_ s)
441 amodeToStix (CMacroExpr _ macro [arg])
443 ENTRY_CODE -> amodeToStix arg
444 ARG_TAG -> amodeToStix arg -- just an integer no. of words
446 #ifdef WORDS_BIGENDIAN
448 [StInd WordRep (StIndex PtrRep (amodeToStix arg)
449 (StInt (toInteger (-1)))),
453 [StInd WordRep (StIndex PtrRep (amodeToStix arg)
454 (StInt (toInteger (-1)))),
458 -> StInd PtrRep (StIndex PtrRep (amodeToStix arg)
459 (StInt (toInteger uF_UPDATEE)))
461 -- GET_TAG(info_ptr) is supposed to be get_itbl(info_ptr)->srt_len,
462 -- which we've had to hand-code here.
464 litLitToStix :: String -> StixTree
466 | all is_id nm = StLitLbl (text nm)
467 | otherwise = error ("\nlitLitToStix: can't handle `" ++ nm ++ "'\n"
468 ++ "suggested workaround: use flag -fvia-C\n")
470 where is_id c = isAlphaNum c || c == '_'
473 Sizes of the CharLike and IntLike closures that are arranged as arrays
474 in the data segment. (These are in bytes.)
477 -- The INTLIKE base pointer
479 intLikePtr :: StixTree
481 intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closure"))
487 charLike = sStLitLbl SLIT("CHARLIKE_closure")
489 -- Trees for the ErrorIOPrimOp
491 topClosure, errorIO :: StixTree
493 topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
494 errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))
496 mutArrPtrsFrozen_info = sStLitLbl SLIT("MUT_ARR_PTRS_FROZEN_info")
498 charLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
499 intLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
505 = getUniqueUs `thenUs` \tso_uq ->
506 let tso = StReg (StixTemp tso_uq ThreadIdRep) in
508 StAssign ThreadIdRep tso stgCurrentTSO :
510 (StInd PtrRep (StPrim IntAddOp
511 [tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]))
514 (StInd PtrRep (StPrim IntAddOp
515 [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))]))
518 (StInd PtrRep (StPrim IntAddOp
519 [tso, StInt (toInteger (TSO_SPLIM*BYTES_PER_WORD))]))
522 (StInd PtrRep (StPrim IntAddOp
524 StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]))
525 (StPrim IntAddOp [stgHp, StInt (toInteger (1 * BYTES_PER_WORD))]) :
530 = getUniqueUs `thenUs` \tso_uq ->
531 let tso = StReg (StixTemp tso_uq ThreadIdRep) in
533 StAssign ThreadIdRep tso stgCurrentTSO :
534 StAssign PtrRep stgSp
535 (StInd PtrRep (StPrim IntAddOp
536 [tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])) :
537 StAssign PtrRep stgSu
538 (StInd PtrRep (StPrim IntAddOp
539 [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))])) :
540 StAssign PtrRep stgSpLim
541 (StInd PtrRep (StPrim IntAddOp
542 [tso, StInt (toInteger (TSO_SPLIM*BYTES_PER_WORD))])) :
543 StAssign PtrRep stgHp
545 StInd PtrRep (StPrim IntAddOp
547 StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]),
548 StInt (toInteger (1 * BYTES_PER_WORD))
550 StAssign PtrRep stgHpLim
552 StInd PtrRep (StPrim IntAddOp
554 StInt (toInteger (BDESCR_START * BYTES_PER_WORD))]),
555 StInt (toInteger (bLOCK_SIZE - (1 * BYTES_PER_WORD)))