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 Constants ( uF_UPDATEE )
18 import SMRep ( fixedHdrSize )
19 import Const ( Literal(..) )
20 import CallConv ( cCallConv )
21 import PrimOp ( PrimOp(..) )
22 import PrimRep ( PrimRep(..), isFloatingRep )
23 import UniqSupply ( returnUs, thenUs, UniqSM )
24 import Constants ( mIN_INTLIKE )
30 The main honcho here is primCode, which handles the guts of COpStmts.
34 :: [CAddrMode] -- results
36 -> [CAddrMode] -- args
37 -> UniqSM StixTreeList
40 First, the dreaded @ccall@. We can't handle @casm@s.
42 Usually, this compiles to an assignment, but when the left-hand side
43 is empty, we just perform the call and ignore the result.
45 btw Why not let programmer use casm to provide assembly code instead
48 The (MP) integer operations are a true nightmare. Since we don't have
49 a convenient abstract way of allocating temporary variables on the (C)
50 stack, we use the space just below HpLim for the @MP_INT@ structures,
51 and modify our heap check accordingly.
54 -- NB: ordering of clauses somewhere driven by
55 -- the desire to getting sane patt-matching behavior
56 primCode res@[sr,dr] IntegerNegOp arg@[sa,da]
57 = gmpNegate (sr,dr) (sa,da)
59 primCode [res] IntegerCmpOp args@[sa1,da1, sa2,da2]
60 = gmpCompare res (sa1,da1, sa2,da2)
62 primCode [res] IntegerCmpIntOp args@[sa1,da1,ai]
63 = gmpCompareInt res (sa1,da1,ai)
65 primCode [res] Integer2IntOp arg@[sa,da]
66 = gmpInteger2Int res (sa,da)
68 primCode [res] Integer2WordOp arg@[sa,da]
69 = gmpInteger2Word res (sa,da)
71 primCode [res] Int2AddrOp [arg]
72 = simpleCoercion AddrRep res arg
74 primCode [res] Addr2IntOp [arg]
75 = simpleCoercion IntRep res arg
77 primCode [res] Int2WordOp [arg]
78 = simpleCoercion IntRep{-WordRep?-} res arg
80 primCode [res] Word2IntOp [arg]
81 = simpleCoercion IntRep res arg
85 primCode [res] SameMutableArrayOp args
87 compare = StPrim AddrEqOp (map amodeToStix args)
88 assign = StAssign IntRep (amodeToStix res) compare
90 returnUs (\xs -> assign : xs)
92 primCode res@[_] SameMutableByteArrayOp args
93 = primCode res SameMutableArrayOp args
96 Freezing an array of pointers is a double assignment. We fix the
97 header of the ``new'' closure because the lhs is probably a better
98 addressing mode for the indirection (most likely, it's a VanillaReg).
102 primCode [lhs] UnsafeFreezeArrayOp [rhs]
104 lhs' = amodeToStix lhs
105 rhs' = amodeToStix rhs
106 header = StInd PtrRep lhs'
107 assign = StAssign PtrRep lhs' rhs'
108 freeze = StAssign PtrRep header mutArrPtrsFrozen_info
110 returnUs (\xs -> assign : freeze : xs)
112 primCode [lhs] UnsafeFreezeByteArrayOp [rhs]
113 = simpleCoercion PtrRep lhs rhs
116 Returning the size of (mutable) byte arrays is just
117 an indexing operation.
120 primCode [lhs] SizeofByteArrayOp [rhs]
122 lhs' = amodeToStix lhs
123 rhs' = amodeToStix rhs
124 sz = StIndex IntRep rhs' fixedHS
125 assign = StAssign IntRep lhs' (StInd IntRep sz)
127 returnUs (\xs -> assign : xs)
129 primCode [lhs] SizeofMutableByteArrayOp [rhs]
131 lhs' = amodeToStix lhs
132 rhs' = amodeToStix rhs
133 sz = StIndex IntRep rhs' fixedHS
134 assign = StAssign IntRep lhs' (StInd IntRep sz)
136 returnUs (\xs -> assign : xs)
140 Most other array primitives translate to simple indexing.
143 primCode lhs@[_] IndexArrayOp args
144 = primCode lhs ReadArrayOp args
146 primCode [lhs] ReadArrayOp [obj, ix]
148 lhs' = amodeToStix lhs
149 obj' = amodeToStix obj
151 base = StIndex IntRep obj' arrPtrsHS
152 assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
154 returnUs (\xs -> assign : xs)
156 primCode [] WriteArrayOp [obj, ix, v]
158 obj' = amodeToStix obj
161 base = StIndex IntRep obj' arrPtrsHS
162 assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
164 returnUs (\xs -> assign : xs)
166 primCode lhs@[_] (IndexByteArrayOp pk) args
167 = primCode lhs (ReadByteArrayOp pk) args
169 -- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
171 primCode [lhs] (ReadByteArrayOp pk) [obj, ix]
173 lhs' = amodeToStix lhs
174 obj' = amodeToStix obj
176 base = StIndex IntRep obj' arrWordsHS
177 assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
179 returnUs (\xs -> assign : xs)
181 primCode lhs@[_] (ReadOffAddrOp pk) args
182 = primCode lhs (IndexOffAddrOp pk) args
184 primCode [lhs] (IndexOffAddrOp pk) [obj, ix]
186 lhs' = amodeToStix lhs
187 obj' = amodeToStix obj
189 assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
191 returnUs (\xs -> assign : xs)
193 primCode [lhs] (IndexOffForeignObjOp pk) [obj, ix]
195 lhs' = amodeToStix lhs
196 obj' = amodeToStix obj
198 obj'' = StIndex PtrRep obj' fixedHS
199 assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix'))
201 returnUs (\xs -> assign : xs)
203 primCode [] (WriteByteArrayOp pk) [obj, ix, v]
205 obj' = amodeToStix obj
208 base = StIndex IntRep obj' arrWordsHS
209 assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
211 returnUs (\xs -> assign : xs)
215 --primCode lhs (CCallOp fn is_asm may_gc) rhs
216 primCode lhs (CCallOp (Left fn) is_asm may_gc cconv) rhs
217 | is_asm = error "ERROR: Native code generator can't handle casm"
218 | may_gc = error "ERROR: Native code generator can't handle _ccall_GC_\n"
221 [] -> returnUs (\xs -> (StCall fn cconv VoidRep args) : xs)
223 let lhs' = amodeToStix lhs
224 pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
225 call = StAssign pk lhs' (StCall fn cconv pk args)
227 returnUs (\xs -> call : xs)
229 args = map amodeCodeForCCall rhs
230 amodeCodeForCCall x =
231 let base = amodeToStix' x
233 case getAmodeRep x of
234 ArrayRep -> StIndex PtrRep base arrPtrsHS
235 ByteArrayRep -> StIndex IntRep base arrWordsHS
236 ForeignObjRep -> StIndex PtrRep base fixedHS
240 DataToTagOp won't work for 64-bit archs, as it is.
243 primCode [lhs] DataToTagOp [arg]
244 = let lhs' = amodeToStix lhs
245 arg' = amodeToStix arg
246 infoptr = StInd PtrRep arg'
247 word_32 = StInd WordRep (StIndex PtrRep infoptr (StInt (-1)))
248 masked_le32 = StPrim SrlOp [word_32, StInt 16]
249 masked_be32 = StPrim AndOp [word_32, StInt 65535]
250 #ifdef WORDS_BIGENDIAN
255 assign = StAssign IntRep lhs' masked
257 returnUs (\xs -> assign : xs)
260 MutVars are pretty simple.
261 #define writeMutVarzh(a,v) (P_)(((StgMutVar *)(a))->var)=(v)
264 primCode [] WriteMutVarOp [aa,vv]
265 = let aa_s = amodeToStix aa
266 vv_s = amodeToStix vv
267 var_field = StIndex PtrRep aa_s fixedHS
268 assign = StAssign PtrRep (StInd PtrRep var_field) vv_s
270 returnUs (\xs -> assign : xs)
272 primCode [rr] ReadMutVarOp [aa]
273 = let aa_s = amodeToStix aa
274 rr_s = amodeToStix rr
275 var_field = StIndex PtrRep aa_s fixedHS
276 assign = StAssign PtrRep rr_s (StInd PtrRep var_field)
278 returnUs (\xs -> assign : xs)
281 Now the more mundane operations.
286 lhs' = map amodeToStix lhs
287 rhs' = map amodeToStix' rhs
288 pk = getAmodeRep (head lhs)
290 returnUs (\ xs -> simplePrim pk lhs' op rhs' : xs)
298 -> UniqSM StixTreeList
300 simpleCoercion pk lhs rhs
301 = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
304 Here we try to rewrite primitives into a form the code generator can
305 understand. Any primitives not handled here must be handled at the
306 level of the specific code generator.
310 :: PrimRep -- Rep of first destination
311 -> [StixTree] -- Destinations
317 Now look for something more conventional.
320 simplePrim pk [lhs] op rest = StAssign pk lhs (StPrim op rest)
321 simplePrim pk as op bs = simplePrim_error op
324 = 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")
327 %---------------------------------------------------------------------
329 Here we generate the Stix code for CAddrModes.
331 When a character is fetched from a mixed type location, we have to do
332 an extra cast. This is reflected in amodeCode', which is for rhs
333 amodes that might possibly need the extra cast.
336 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
338 amodeToStix'{-'-} am@(CVal rr CharRep)
339 | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
340 | otherwise = amodeToStix am
342 amodeToStix' am = amodeToStix am
345 amodeToStix am@(CVal rr CharRep)
347 = StInd IntRep (amodeToStix (CAddr rr))
349 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
351 amodeToStix (CAddr (SpRel off))
352 = StIndex PtrRep stgSp (StInt (toInteger IBOX(off)))
354 amodeToStix (CAddr (HpRel off))
355 = StIndex IntRep stgHp (StInt (toInteger (- IBOX(off))))
357 amodeToStix (CAddr (NodeRel off))
358 = StIndex IntRep stgNode (StInt (toInteger IBOX(off)))
360 amodeToStix (CAddr (CIndex base off pk))
361 = StIndex pk (amodeToStix base) (amodeToStix off)
363 amodeToStix (CReg magic) = StReg (StixMagicId magic)
364 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
366 amodeToStix (CLbl lbl _) = StCLbl lbl
368 -- For CharLike and IntLike, we attempt some trivial constant-folding here.
370 amodeToStix (CCharLike (CLit (MachChar c)))
371 = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closure+")) (int off))
373 off = charLikeSize * ord c
375 amodeToStix (CCharLike x)
376 = StIndex CharRep charLike off
378 off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
380 amodeToStix (CIntLike (CLit (MachInt i _)))
381 = StLitLbl ((<>) (ptext SLIT("INTLIKE_closure+")) (int off))
383 off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
385 amodeToStix (CIntLike x)
388 amodeToStix (CLit core)
390 MachChar c -> StInt (toInteger (ord c))
391 MachStr s -> StString s
392 MachAddr a -> StInt a
393 MachInt i _ -> StInt (toInteger i)
394 MachLitLit s _ -> {-trace (_UNPK_ s ++ "\n")-} (litLitToStix (_UNPK_ s))
395 MachFloat d -> StDouble d
396 MachDouble d -> StDouble d
397 _ -> panic "amodeToStix:core literal"
399 amodeToStix (CLitLit s _)
400 = litLitToStix (_UNPK_ s)
402 amodeToStix (CMacroExpr _ macro [arg])
404 ENTRY_CODE -> amodeToStix arg
405 ARG_TAG -> amodeToStix arg -- just an integer no. of words
407 #ifdef WORDS_BIGENDIAN
409 [StInd WordRep (StIndex PtrRep (amodeToStix arg)
410 (StInt (toInteger (-1)))),
414 [StInd WordRep (StIndex PtrRep (amodeToStix arg)
415 (StInt (toInteger (-1)))),
419 -> StInd PtrRep (StIndex PtrRep (amodeToStix arg)
420 (StInt (toInteger uF_UPDATEE)))
422 -- GET_TAG(info_ptr) is supposed to be get_itbl(info_ptr)->srt_len,
423 -- which we've had to hand-code here.
425 litLitToStix :: String -> StixTree
428 "stdout" -> stixFor_stdout
429 "stderr" -> stixFor_stderr
430 "stdin" -> stixFor_stdin
431 other -> error ("\nlitLitToStix: can't handle `" ++ nm ++ "'\n"
432 ++ "suggested workaround: use flag -fvia-C\n")
435 Sizes of the CharLike and IntLike closures that are arranged as arrays
436 in the data segment. (These are in bytes.)
439 -- The INTLIKE base pointer
441 intLikePtr :: StixTree
443 intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closure"))
449 charLike = sStLitLbl SLIT("CHARLIKE_closure")
451 -- Trees for the ErrorIOPrimOp
453 topClosure, errorIO :: StixTree
455 topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
456 errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))
458 mutArrPtrsFrozen_info = sStLitLbl SLIT("MUT_ARR_PTRS_FROZEN_info")
460 charLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
461 intLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))