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 Literal ( Literal(..), word2IntLit )
20 import CallConv ( cCallConv )
21 import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) )
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
95 primCode res@[_] SameMutVarOp args
96 = primCode res SameMutableArrayOp args
98 primCode res@[_] SameMVarOp args
99 = primCode res SameMutableArrayOp args
102 Freezing an array of pointers is a double assignment. We fix the
103 header of the ``new'' closure because the lhs is probably a better
104 addressing mode for the indirection (most likely, it's a VanillaReg).
108 primCode [lhs] UnsafeFreezeArrayOp [rhs]
110 lhs' = amodeToStix lhs
111 rhs' = amodeToStix rhs
112 header = StInd PtrRep lhs'
113 assign = StAssign PtrRep lhs' rhs'
114 freeze = StAssign PtrRep header mutArrPtrsFrozen_info
116 returnUs (\xs -> assign : freeze : xs)
118 primCode [lhs] UnsafeFreezeByteArrayOp [rhs]
119 = simpleCoercion PtrRep lhs rhs
122 Returning the size of (mutable) byte arrays is just
123 an indexing operation.
126 primCode [lhs] SizeofByteArrayOp [rhs]
128 lhs' = amodeToStix lhs
129 rhs' = amodeToStix rhs
130 sz = StIndex IntRep rhs' fixedHS
131 assign = StAssign IntRep lhs' (StInd IntRep sz)
133 returnUs (\xs -> assign : xs)
135 primCode [lhs] SizeofMutableByteArrayOp [rhs]
137 lhs' = amodeToStix lhs
138 rhs' = amodeToStix rhs
139 sz = StIndex IntRep rhs' fixedHS
140 assign = StAssign IntRep lhs' (StInd IntRep sz)
142 returnUs (\xs -> assign : xs)
146 Most other array primitives translate to simple indexing.
149 primCode lhs@[_] IndexArrayOp args
150 = primCode lhs ReadArrayOp args
152 primCode [lhs] ReadArrayOp [obj, ix]
154 lhs' = amodeToStix lhs
155 obj' = amodeToStix obj
157 base = StIndex IntRep obj' arrPtrsHS
158 assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
160 returnUs (\xs -> assign : xs)
162 primCode [] WriteArrayOp [obj, ix, v]
164 obj' = amodeToStix obj
167 base = StIndex IntRep obj' arrPtrsHS
168 assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
170 returnUs (\xs -> assign : xs)
172 primCode lhs@[_] (IndexByteArrayOp pk) args
173 = primCode lhs (ReadByteArrayOp pk) args
175 -- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
177 primCode [lhs] (ReadByteArrayOp pk) [obj, ix]
179 lhs' = amodeToStix lhs
180 obj' = amodeToStix obj
182 base = StIndex IntRep obj' arrWordsHS
183 assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
185 returnUs (\xs -> assign : xs)
187 primCode lhs@[_] (ReadOffAddrOp pk) args
188 = primCode lhs (IndexOffAddrOp pk) args
190 primCode [lhs] (IndexOffAddrOp pk) [obj, ix]
192 lhs' = amodeToStix lhs
193 obj' = amodeToStix obj
195 assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
197 returnUs (\xs -> assign : xs)
199 primCode [lhs] (IndexOffForeignObjOp pk) [obj, ix]
201 lhs' = amodeToStix lhs
202 obj' = amodeToStix obj
204 obj'' = StIndex AddrRep obj' fixedHS
205 assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix'))
207 returnUs (\xs -> assign : xs)
209 primCode [] (WriteOffAddrOp pk) [obj, ix, v]
211 obj' = amodeToStix obj
214 assign = StAssign pk (StInd pk (StIndex pk obj' ix')) v'
216 returnUs (\xs -> assign : xs)
218 primCode [] (WriteByteArrayOp pk) [obj, ix, v]
220 obj' = amodeToStix obj
223 base = StIndex IntRep obj' arrWordsHS
224 assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
226 returnUs (\xs -> assign : xs)
228 primCode [] WriteForeignObjOp [obj, v]
230 obj' = amodeToStix obj
232 obj'' = StIndex AddrRep obj' (StInt 4711) -- fixedHS
233 assign = StAssign AddrRep (StInd AddrRep obj'') v'
235 returnUs (\xs -> assign : xs)
239 --primCode lhs (CCallOp fn is_asm may_gc) rhs
240 primCode lhs (CCallOp (CCall (StaticTarget fn) is_asm may_gc cconv)) rhs
241 | is_asm = error "ERROR: Native code generator can't handle casm"
242 | may_gc = error "ERROR: Native code generator can't handle _ccall_GC_\n"
245 [] -> returnUs (\xs -> (StCall fn cconv VoidRep args) : xs)
247 let lhs' = amodeToStix lhs
248 pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
249 call = StAssign pk lhs' (StCall fn cconv pk args)
251 returnUs (\xs -> call : xs)
253 args = map amodeCodeForCCall rhs
254 amodeCodeForCCall x =
255 let base = amodeToStix' x
257 case getAmodeRep x of
258 ArrayRep -> StIndex PtrRep base arrPtrsHS
259 ByteArrayRep -> StIndex IntRep base arrWordsHS
260 ForeignObjRep -> StIndex PtrRep base fixedHS
264 DataToTagOp won't work for 64-bit archs, as it is.
267 primCode [lhs] DataToTagOp [arg]
268 = let lhs' = amodeToStix lhs
269 arg' = amodeToStix arg
270 infoptr = StInd PtrRep arg'
271 word_32 = StInd WordRep (StIndex PtrRep infoptr (StInt (-1)))
272 masked_le32 = StPrim SrlOp [word_32, StInt 16]
273 masked_be32 = StPrim AndOp [word_32, StInt 65535]
274 #ifdef WORDS_BIGENDIAN
279 assign = StAssign IntRep lhs' masked
281 returnUs (\xs -> assign : xs)
284 MutVars are pretty simple.
285 #define writeMutVarzh(a,v) (P_)(((StgMutVar *)(a))->var)=(v)
288 primCode [] WriteMutVarOp [aa,vv]
289 = let aa_s = amodeToStix aa
290 vv_s = amodeToStix vv
291 var_field = StIndex PtrRep aa_s fixedHS
292 assign = StAssign PtrRep (StInd PtrRep var_field) vv_s
294 returnUs (\xs -> assign : xs)
296 primCode [rr] ReadMutVarOp [aa]
297 = let aa_s = amodeToStix aa
298 rr_s = amodeToStix rr
299 var_field = StIndex PtrRep aa_s fixedHS
300 assign = StAssign PtrRep rr_s (StInd PtrRep var_field)
302 returnUs (\xs -> assign : xs)
305 Now the more mundane operations.
310 lhs' = map amodeToStix lhs
311 rhs' = map amodeToStix' rhs
312 pk = getAmodeRep (head lhs)
314 returnUs (\ xs -> simplePrim pk lhs' op rhs' : xs)
322 -> UniqSM StixTreeList
324 simpleCoercion pk lhs rhs
325 = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
328 Here we try to rewrite primitives into a form the code generator can
329 understand. Any primitives not handled here must be handled at the
330 level of the specific code generator.
334 :: PrimRep -- Rep of first destination
335 -> [StixTree] -- Destinations
341 Now look for something more conventional.
344 simplePrim pk [lhs] op rest = StAssign pk lhs (StPrim op rest)
345 simplePrim pk as op bs = simplePrim_error op
348 = 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")
351 %---------------------------------------------------------------------
353 Here we generate the Stix code for CAddrModes.
355 When a character is fetched from a mixed type location, we have to do
356 an extra cast. This is reflected in amodeCode', which is for rhs
357 amodes that might possibly need the extra cast.
360 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
362 amodeToStix'{-'-} am@(CVal rr CharRep)
363 | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
364 | otherwise = amodeToStix am
366 amodeToStix' am = amodeToStix am
369 amodeToStix am@(CVal rr CharRep)
371 = StInd IntRep (amodeToStix (CAddr rr))
373 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
375 amodeToStix (CAddr (SpRel off))
376 = StIndex PtrRep stgSp (StInt (toInteger IBOX(off)))
378 amodeToStix (CAddr (HpRel off))
379 = StIndex IntRep stgHp (StInt (toInteger (- IBOX(off))))
381 amodeToStix (CAddr (NodeRel off))
382 = StIndex IntRep stgNode (StInt (toInteger IBOX(off)))
384 amodeToStix (CAddr (CIndex base off pk))
385 = StIndex pk (amodeToStix base) (amodeToStix off)
387 amodeToStix (CReg magic) = StReg (StixMagicId magic)
388 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
390 amodeToStix (CLbl lbl _) = StCLbl lbl
392 -- For CharLike and IntLike, we attempt some trivial constant-folding here.
394 amodeToStix (CCharLike (CLit (MachChar c)))
395 = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closure+")) (int off))
397 off = charLikeSize * ord c
399 amodeToStix (CCharLike x)
400 = StIndex CharRep charLike off
402 off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
404 amodeToStix (CIntLike (CLit (MachInt i)))
405 = StLitLbl ((<>) (ptext SLIT("INTLIKE_closure+")) (int off))
407 off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
409 amodeToStix (CIntLike x)
412 amodeToStix (CLit core)
414 MachChar c -> StInt (toInteger (ord c))
415 MachStr s -> StString s
416 MachAddr a -> StInt a
418 MachWord w -> case word2IntLit core of MachInt iw -> StInt iw
419 MachLitLit s _ -> litLitToStix (_UNPK_ s)
420 MachFloat d -> StDouble d
421 MachDouble d -> StDouble d
422 _ -> panic "amodeToStix:core literal"
424 amodeToStix (CLitLit s _)
425 = litLitToStix (_UNPK_ s)
427 amodeToStix (CMacroExpr _ macro [arg])
429 ENTRY_CODE -> amodeToStix arg
430 ARG_TAG -> amodeToStix arg -- just an integer no. of words
432 #ifdef WORDS_BIGENDIAN
434 [StInd WordRep (StIndex PtrRep (amodeToStix arg)
435 (StInt (toInteger (-1)))),
439 [StInd WordRep (StIndex PtrRep (amodeToStix arg)
440 (StInt (toInteger (-1)))),
444 -> StInd PtrRep (StIndex PtrRep (amodeToStix arg)
445 (StInt (toInteger uF_UPDATEE)))
447 -- GET_TAG(info_ptr) is supposed to be get_itbl(info_ptr)->srt_len,
448 -- which we've had to hand-code here.
450 litLitToStix :: String -> StixTree
453 "stdout" -> stixFor_stdout
454 "stderr" -> stixFor_stderr
455 "stdin" -> stixFor_stdin
456 other -> error ("\nlitLitToStix: can't handle `" ++ nm ++ "'\n"
457 ++ "suggested workaround: use flag -fvia-C\n")
460 Sizes of the CharLike and IntLike closures that are arranged as arrays
461 in the data segment. (These are in bytes.)
464 -- The INTLIKE base pointer
466 intLikePtr :: StixTree
468 intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closure"))
474 charLike = sStLitLbl SLIT("CHARLIKE_closure")
476 -- Trees for the ErrorIOPrimOp
478 topClosure, errorIO :: StixTree
480 topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
481 errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))
483 mutArrPtrsFrozen_info = sStLitLbl SLIT("MUT_ARR_PTRS_FROZEN_info")
485 charLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
486 intLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))