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 )
24 import CLabel ( mkIntlikeClosureLabel, mkCharlikeClosureLabel,
25 mkTopClosureLabel, mkErrorIO_innardsLabel,
26 mkMAP_FROZEN_infoLabel )
29 import Char ( ord, isAlphaNum )
34 The main honcho here is primCode, which handles the guts of COpStmts.
38 :: [CAddrMode] -- results
40 -> [CAddrMode] -- args
41 -> UniqSM StixTreeList
44 First, the dreaded @ccall@. We can't handle @casm@s.
46 Usually, this compiles to an assignment, but when the left-hand side
47 is empty, we just perform the call and ignore the result.
49 btw Why not let programmer use casm to provide assembly code instead
52 The (MP) integer operations are a true nightmare. Since we don't have
53 a convenient abstract way of allocating temporary variables on the (C)
54 stack, we use the space just below HpLim for the @MP_INT@ structures,
55 and modify our heap check accordingly.
58 -- NB: ordering of clauses somewhere driven by
59 -- the desire to getting sane patt-matching behavior
60 primCode res@[sr,dr] IntegerNegOp arg@[sa,da]
61 = gmpNegate (sr,dr) (sa,da)
63 primCode [res] IntegerCmpOp args@[sa1,da1, sa2,da2]
64 = gmpCompare res (sa1,da1, sa2,da2)
66 primCode [res] IntegerCmpIntOp args@[sa1,da1,ai]
67 = gmpCompareInt res (sa1,da1,ai)
69 primCode [res] Integer2IntOp arg@[sa,da]
70 = gmpInteger2Int res (sa,da)
72 primCode [res] Integer2WordOp arg@[sa,da]
73 = gmpInteger2Word res (sa,da)
75 primCode [res] Int2AddrOp [arg]
76 = simpleCoercion AddrRep res arg
78 primCode [res] Addr2IntOp [arg]
79 = simpleCoercion IntRep res arg
81 primCode [res] Int2WordOp [arg]
82 = simpleCoercion IntRep{-WordRep?-} res arg
84 primCode [res] Word2IntOp [arg]
85 = simpleCoercion IntRep res arg
89 primCode [res] SameMutableArrayOp args
91 compare = StPrim AddrEqOp (map amodeToStix args)
92 assign = StAssign IntRep (amodeToStix res) compare
94 returnUs (\xs -> assign : xs)
96 primCode res@[_] SameMutableByteArrayOp args
97 = primCode res SameMutableArrayOp args
99 primCode res@[_] SameMutVarOp args
100 = primCode res SameMutableArrayOp args
102 primCode res@[_] SameMVarOp args
103 = primCode res SameMutableArrayOp args
106 Freezing an array of pointers is a double assignment. We fix the
107 header of the ``new'' closure because the lhs is probably a better
108 addressing mode for the indirection (most likely, it's a VanillaReg).
112 primCode [lhs] UnsafeFreezeArrayOp [rhs]
114 lhs' = amodeToStix lhs
115 rhs' = amodeToStix rhs
116 header = StInd PtrRep lhs'
117 assign = StAssign PtrRep lhs' rhs'
118 freeze = StAssign PtrRep header mutArrPtrsFrozen_info
120 returnUs (\xs -> assign : freeze : xs)
122 primCode [lhs] UnsafeFreezeByteArrayOp [rhs]
123 = simpleCoercion PtrRep lhs rhs
126 Returning the size of (mutable) byte arrays is just
127 an indexing operation.
130 primCode [lhs] SizeofByteArrayOp [rhs]
132 lhs' = amodeToStix lhs
133 rhs' = amodeToStix rhs
134 sz = StIndex IntRep rhs' fixedHS
135 assign = StAssign IntRep lhs' (StInd IntRep sz)
137 returnUs (\xs -> assign : xs)
139 primCode [lhs] SizeofMutableByteArrayOp [rhs]
141 lhs' = amodeToStix lhs
142 rhs' = amodeToStix rhs
143 sz = StIndex IntRep rhs' fixedHS
144 assign = StAssign IntRep lhs' (StInd IntRep sz)
146 returnUs (\xs -> assign : xs)
150 Most other array primitives translate to simple indexing.
153 primCode lhs@[_] IndexArrayOp args
154 = primCode lhs ReadArrayOp args
156 primCode [lhs] ReadArrayOp [obj, ix]
158 lhs' = amodeToStix lhs
159 obj' = amodeToStix obj
161 base = StIndex IntRep obj' arrPtrsHS
162 assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
164 returnUs (\xs -> assign : xs)
166 primCode [] WriteArrayOp [obj, ix, v]
168 obj' = amodeToStix obj
171 base = StIndex IntRep obj' arrPtrsHS
172 assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
174 returnUs (\xs -> assign : xs)
176 primCode lhs@[_] (IndexByteArrayOp pk) args
177 = primCode lhs (ReadByteArrayOp pk) args
179 -- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
181 primCode [lhs] (ReadByteArrayOp pk) [obj, ix]
183 lhs' = amodeToStix lhs
184 obj' = amodeToStix obj
186 base = StIndex IntRep obj' arrWordsHS
187 assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
189 returnUs (\xs -> assign : xs)
191 primCode lhs@[_] (ReadOffAddrOp pk) args
192 = primCode lhs (IndexOffAddrOp pk) args
194 primCode [lhs] (IndexOffAddrOp pk) [obj, ix]
196 lhs' = amodeToStix lhs
197 obj' = amodeToStix obj
199 assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
201 returnUs (\xs -> assign : xs)
203 primCode [lhs] (IndexOffForeignObjOp pk) [obj, ix]
205 lhs' = amodeToStix lhs
206 obj' = amodeToStix obj
208 obj'' = StIndex AddrRep obj' fixedHS
209 assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix'))
211 returnUs (\xs -> assign : xs)
213 primCode [] (WriteOffAddrOp pk) [obj, ix, v]
215 obj' = amodeToStix obj
218 assign = StAssign pk (StInd pk (StIndex pk obj' ix')) v'
220 returnUs (\xs -> assign : xs)
222 primCode [] (WriteByteArrayOp pk) [obj, ix, v]
224 obj' = amodeToStix obj
227 base = StIndex IntRep obj' arrWordsHS
228 assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
230 returnUs (\xs -> assign : xs)
232 primCode [] WriteForeignObjOp [obj, v]
234 obj' = amodeToStix obj
236 obj'' = StIndex AddrRep obj' (StInt 4711) -- fixedHS
237 assign = StAssign AddrRep (StInd AddrRep obj'') v'
239 returnUs (\xs -> assign : xs)
242 ToDo: saving/restoring of volatile regs around ccalls.
245 primCode lhs (CCallOp (CCall (StaticTarget fn) is_asm may_gc cconv)) rhs
246 | is_asm = error "ERROR: Native code generator can't handle casm"
247 | not may_gc = returnUs (\xs -> ccall : xs)
249 save_thread_state `thenUs` \ save ->
250 load_thread_state `thenUs` \ load ->
251 getUniqueUs `thenUs` \ uniq ->
253 id = StReg (StixTemp uniq IntRep)
255 suspend = StAssign IntRep id
256 (StCall SLIT("suspendThread") cconv IntRep [stgBaseReg])
257 resume = StCall SLIT("resumeThread") cconv VoidRep [id]
259 returnUs (\xs -> save (suspend : ccall : resume : load xs))
262 args = map amodeCodeForCCall rhs
263 amodeCodeForCCall x =
264 let base = amodeToStix' x
266 case getAmodeRep x of
267 ArrayRep -> StIndex PtrRep base arrPtrsHS
268 ByteArrayRep -> StIndex IntRep base arrWordsHS
269 ForeignObjRep -> StIndex PtrRep base fixedHS
273 [] -> StCall fn cconv VoidRep args
275 let lhs' = amodeToStix lhs
276 pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
278 StAssign pk lhs' (StCall fn cconv pk args)
281 DataToTagOp won't work for 64-bit archs, as it is.
284 primCode [lhs] DataToTagOp [arg]
285 = let lhs' = amodeToStix lhs
286 arg' = amodeToStix arg
287 infoptr = StInd PtrRep arg'
288 word_32 = StInd WordRep (StIndex PtrRep infoptr (StInt (-1)))
289 masked_le32 = StPrim SrlOp [word_32, StInt 16]
290 masked_be32 = StPrim AndOp [word_32, StInt 65535]
291 #ifdef WORDS_BIGENDIAN
296 assign = StAssign IntRep lhs' masked
298 returnUs (\xs -> assign : xs)
301 MutVars are pretty simple.
302 #define writeMutVarzh(a,v) (P_)(((StgMutVar *)(a))->var)=(v)
305 primCode [] WriteMutVarOp [aa,vv]
306 = let aa_s = amodeToStix aa
307 vv_s = amodeToStix vv
308 var_field = StIndex PtrRep aa_s fixedHS
309 assign = StAssign PtrRep (StInd PtrRep var_field) vv_s
311 returnUs (\xs -> assign : xs)
313 primCode [rr] ReadMutVarOp [aa]
314 = let aa_s = amodeToStix aa
315 rr_s = amodeToStix rr
316 var_field = StIndex PtrRep aa_s fixedHS
317 assign = StAssign PtrRep rr_s (StInd PtrRep var_field)
319 returnUs (\xs -> assign : xs)
322 Now the more mundane operations.
327 lhs' = map amodeToStix lhs
328 rhs' = map amodeToStix' rhs
329 pk = getAmodeRep (head lhs)
331 returnUs (\ xs -> simplePrim pk lhs' op rhs' : xs)
339 -> UniqSM StixTreeList
341 simpleCoercion pk lhs rhs
342 = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
345 Here we try to rewrite primitives into a form the code generator can
346 understand. Any primitives not handled here must be handled at the
347 level of the specific code generator.
351 :: PrimRep -- Rep of first destination
352 -> [StixTree] -- Destinations
358 Now look for something more conventional.
361 simplePrim pk [lhs] op rest = StAssign pk lhs (StPrim op rest)
362 simplePrim pk as op bs = simplePrim_error op
365 = 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")
368 %---------------------------------------------------------------------
370 Here we generate the Stix code for CAddrModes.
372 When a character is fetched from a mixed type location, we have to do
373 an extra cast. This is reflected in amodeCode', which is for rhs
374 amodes that might possibly need the extra cast.
377 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
379 amodeToStix'{-'-} am@(CVal rr CharRep)
380 | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
381 | otherwise = amodeToStix am
383 amodeToStix' am = amodeToStix am
386 amodeToStix am@(CVal rr CharRep)
388 = StInd IntRep (amodeToStix (CAddr rr))
390 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
392 amodeToStix (CAddr (SpRel off))
393 = StIndex PtrRep stgSp (StInt (toInteger IBOX(off)))
395 amodeToStix (CAddr (HpRel off))
396 = StIndex IntRep stgHp (StInt (toInteger (- IBOX(off))))
398 amodeToStix (CAddr (NodeRel off))
399 = StIndex IntRep stgNode (StInt (toInteger IBOX(off)))
401 amodeToStix (CAddr (CIndex base off pk))
402 = StIndex pk (amodeToStix base) (amodeToStix off)
404 amodeToStix (CReg magic) = StReg (StixMagicId magic)
405 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
407 amodeToStix (CLbl lbl _) = StCLbl lbl
409 -- For CharLike and IntLike, we attempt some trivial constant-folding here.
411 amodeToStix (CCharLike (CLit (MachChar c)))
412 = StIndex CharRep cHARLIKE_closure (StInt (toInteger off))
414 off = charLikeSize * ord c
416 amodeToStix (CCharLike x)
417 = StIndex CharRep cHARLIKE_closure off
419 off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
421 amodeToStix (CIntLike (CLit (MachInt i)))
422 = StIndex CharRep{-yes,really-} iNTLIKE_closure (StInt (toInteger off))
424 off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
426 amodeToStix (CIntLike x)
429 amodeToStix (CLit core)
431 MachChar c -> StInt (toInteger (ord c))
432 MachStr s -> StString s
433 MachAddr a -> StInt a
435 MachWord w -> case word2IntLit core of MachInt iw -> StInt iw
436 MachLitLit s _ -> litLitToStix (_UNPK_ s)
437 MachFloat d -> StDouble d
438 MachDouble d -> StDouble d
439 _ -> panic "amodeToStix:core literal"
441 amodeToStix (CLitLit s _)
442 = litLitToStix (_UNPK_ s)
444 amodeToStix (CMacroExpr _ macro [arg])
446 ENTRY_CODE -> amodeToStix arg
447 ARG_TAG -> amodeToStix arg -- just an integer no. of words
449 #ifdef WORDS_BIGENDIAN
451 [StInd WordRep (StIndex PtrRep (amodeToStix arg)
452 (StInt (toInteger (-1)))),
456 [StInd WordRep (StIndex PtrRep (amodeToStix arg)
457 (StInt (toInteger (-1)))),
461 -> StInd PtrRep (StIndex PtrRep (amodeToStix arg)
462 (StInt (toInteger uF_UPDATEE)))
464 = error ("\nlitLitToStix: can't handle `" ++ nm ++ "'\n"
465 ++ "suggested workaround: use flag -fvia-C\n")
468 Sizes of the CharLike and IntLike closures that are arranged as arrays
469 in the data segment. (These are in bytes.)
472 -- The INTLIKE base pointer
474 iNTLIKE_closure :: StixTree
475 iNTLIKE_closure = StCLbl mkIntlikeClosureLabel
479 cHARLIKE_closure :: StixTree
480 cHARLIKE_closure = StCLbl mkCharlikeClosureLabel
482 -- Trees for the ErrorIOPrimOp
484 topClosure, errorIO :: StixTree
486 topClosure = StInd PtrRep (StCLbl mkTopClosureLabel)
487 errorIO = StJump (StInd PtrRep (StCLbl mkErrorIO_innardsLabel))
489 mutArrPtrsFrozen_info = StCLbl mkMAP_FROZEN_infoLabel
491 -- these are the sizes of charLike and intLike closures, in _bytes_.
492 charLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
493 intLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
499 = getUniqueUs `thenUs` \tso_uq ->
500 let tso = StReg (StixTemp tso_uq ThreadIdRep) in
502 StAssign ThreadIdRep tso stgCurrentTSO :
504 (StInd PtrRep (StPrim IntAddOp
505 [tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]))
508 (StInd PtrRep (StPrim IntAddOp
509 [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))]))
512 (StInd PtrRep (StPrim IntAddOp
513 [tso, StInt (toInteger (TSO_SPLIM*BYTES_PER_WORD))]))
516 (StInd PtrRep (StPrim IntAddOp
518 StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]))
519 (StPrim IntAddOp [stgHp, StInt (toInteger (1 * BYTES_PER_WORD))]) :
524 = getUniqueUs `thenUs` \tso_uq ->
525 let tso = StReg (StixTemp tso_uq ThreadIdRep) in
527 StAssign ThreadIdRep tso stgCurrentTSO :
528 StAssign PtrRep stgSp
529 (StInd PtrRep (StPrim IntAddOp
530 [tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])) :
531 StAssign PtrRep stgSu
532 (StInd PtrRep (StPrim IntAddOp
533 [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))])) :
534 StAssign PtrRep stgSpLim
535 (StInd PtrRep (StPrim IntAddOp
536 [tso, StInt (toInteger (TSO_SPLIM*BYTES_PER_WORD))])) :
537 StAssign PtrRep stgHp
539 StInd PtrRep (StPrim IntAddOp
541 StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]),
542 StInt (toInteger (1 * BYTES_PER_WORD))
544 StAssign PtrRep stgHpLim
546 StInd PtrRep (StPrim IntAddOp
548 StInt (toInteger (BDESCR_START * BYTES_PER_WORD))]),
549 StInt (toInteger (bLOCK_SIZE - (1 * BYTES_PER_WORD)))