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
114 primCode [lhs] UnsafeThawByteArrayOp [rhs]
115 = simpleCoercion PtrRep lhs rhs
118 Returning the size of (mutable) byte arrays is just
119 an indexing operation.
122 primCode [lhs] SizeofByteArrayOp [rhs]
124 lhs' = amodeToStix lhs
125 rhs' = amodeToStix rhs
126 sz = StIndex IntRep rhs' fixedHS
127 assign = StAssign IntRep lhs' (StInd IntRep sz)
129 returnUs (\xs -> assign : xs)
131 primCode [lhs] SizeofMutableByteArrayOp [rhs]
133 lhs' = amodeToStix lhs
134 rhs' = amodeToStix rhs
135 sz = StIndex IntRep rhs' fixedHS
136 assign = StAssign IntRep lhs' (StInd IntRep sz)
138 returnUs (\xs -> assign : xs)
142 Most other array primitives translate to simple indexing.
145 primCode lhs@[_] IndexArrayOp args
146 = primCode lhs ReadArrayOp args
148 primCode [lhs] ReadArrayOp [obj, ix]
150 lhs' = amodeToStix lhs
151 obj' = amodeToStix obj
153 base = StIndex IntRep obj' arrPtrsHS
154 assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
156 returnUs (\xs -> assign : xs)
158 primCode [] WriteArrayOp [obj, ix, v]
160 obj' = amodeToStix obj
163 base = StIndex IntRep obj' arrPtrsHS
164 assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
166 returnUs (\xs -> assign : xs)
168 primCode lhs@[_] (IndexByteArrayOp pk) args
169 = primCode lhs (ReadByteArrayOp pk) args
171 -- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
173 primCode [lhs] (ReadByteArrayOp pk) [obj, ix]
175 lhs' = amodeToStix lhs
176 obj' = amodeToStix obj
178 base = StIndex IntRep obj' arrWordsHS
179 assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
181 returnUs (\xs -> assign : xs)
183 primCode [lhs] (IndexOffAddrOp pk) [obj, ix]
185 lhs' = amodeToStix lhs
186 obj' = amodeToStix obj
188 assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
190 returnUs (\xs -> assign : xs)
192 primCode [lhs] (IndexOffForeignObjOp pk) [obj, ix]
194 lhs' = amodeToStix lhs
195 obj' = amodeToStix obj
197 obj'' = StIndex PtrRep obj' fixedHS
198 assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix'))
200 returnUs (\xs -> assign : xs)
202 primCode [] (WriteByteArrayOp pk) [obj, ix, v]
204 obj' = amodeToStix obj
207 base = StIndex IntRep obj' arrWordsHS
208 assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
210 returnUs (\xs -> assign : xs)
214 --primCode lhs (CCallOp fn is_asm may_gc) rhs
215 primCode lhs (CCallOp (Left fn) is_asm may_gc cconv) rhs
216 | is_asm = error "ERROR: Native code generator can't handle casm"
217 | may_gc = error "ERROR: Native code generator can't handle _ccall_GC_\n"
220 [] -> returnUs (\xs -> (StCall fn cconv VoidRep args) : xs)
222 let lhs' = amodeToStix lhs
223 pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
224 call = StAssign pk lhs' (StCall fn cconv pk args)
226 returnUs (\xs -> call : xs)
228 args = map amodeCodeForCCall rhs
229 amodeCodeForCCall x =
230 let base = amodeToStix' x
232 case getAmodeRep x of
233 ArrayRep -> StIndex PtrRep base arrPtrsHS
234 ByteArrayRep -> StIndex IntRep base arrWordsHS
235 ForeignObjRep -> StIndex PtrRep base fixedHS
239 DataToTagOp won't work for 64-bit archs, as it is.
242 primCode [lhs] DataToTagOp [arg]
243 = let lhs' = amodeToStix lhs
244 arg' = amodeToStix arg
245 infoptr = StInd PtrRep arg'
246 word_32 = StInd WordRep (StIndex PtrRep infoptr (StInt (-1)))
247 masked_le32 = StPrim SrlOp [word_32, StInt 16]
248 masked_be32 = StPrim AndOp [word_32, StInt 65535]
249 #ifdef WORDS_BIGENDIAN
254 assign = StAssign IntRep lhs' masked
256 returnUs (\xs -> assign : xs)
259 MutVars are pretty simple.
260 #define writeMutVarzh(a,v) (P_)(((StgMutVar *)(a))->var)=(v)
263 primCode [] WriteMutVarOp [aa,vv]
264 = let aa_s = amodeToStix aa
265 vv_s = amodeToStix vv
266 var_field = StIndex PtrRep aa_s fixedHS
267 assign = StAssign PtrRep (StInd PtrRep var_field) vv_s
269 returnUs (\xs -> assign : xs)
271 primCode [rr] ReadMutVarOp [aa]
272 = let aa_s = amodeToStix aa
273 rr_s = amodeToStix rr
274 var_field = StIndex PtrRep aa_s fixedHS
275 assign = StAssign PtrRep rr_s (StInd PtrRep var_field)
277 returnUs (\xs -> assign : xs)
280 Now the more mundane operations.
285 lhs' = map amodeToStix lhs
286 rhs' = map amodeToStix' rhs
287 pk = getAmodeRep (head lhs)
289 returnUs (\ xs -> simplePrim pk lhs' op rhs' : xs)
297 -> UniqSM StixTreeList
299 simpleCoercion pk lhs rhs
300 = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
303 Here we try to rewrite primitives into a form the code generator can
304 understand. Any primitives not handled here must be handled at the
305 level of the specific code generator.
309 :: PrimRep -- Rep of first destination
310 -> [StixTree] -- Destinations
316 Now look for something more conventional.
319 simplePrim pk [lhs] op rest = StAssign pk lhs (StPrim op rest)
320 simplePrim pk as op bs = simplePrim_error op
323 = 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")
326 %---------------------------------------------------------------------
328 Here we generate the Stix code for CAddrModes.
330 When a character is fetched from a mixed type location, we have to do
331 an extra cast. This is reflected in amodeCode', which is for rhs
332 amodes that might possibly need the extra cast.
335 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
337 amodeToStix'{-'-} am@(CVal rr CharRep)
338 | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
339 | otherwise = amodeToStix am
341 amodeToStix' am = amodeToStix am
344 amodeToStix am@(CVal rr CharRep)
346 = StInd IntRep (amodeToStix (CAddr rr))
348 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
350 amodeToStix (CAddr (SpRel off))
351 = StIndex PtrRep stgSp (StInt (toInteger IBOX(off)))
353 amodeToStix (CAddr (HpRel off))
354 = StIndex IntRep stgHp (StInt (toInteger (- IBOX(off))))
356 amodeToStix (CAddr (NodeRel off))
357 = StIndex IntRep stgNode (StInt (toInteger IBOX(off)))
359 amodeToStix (CAddr (CIndex base off pk))
360 = StIndex pk (amodeToStix base) (amodeToStix off)
362 amodeToStix (CReg magic) = StReg (StixMagicId magic)
363 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
365 amodeToStix (CLbl lbl _) = StCLbl lbl
367 -- For CharLike and IntLike, we attempt some trivial constant-folding here.
369 amodeToStix (CCharLike (CLit (MachChar c)))
370 = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closure+")) (int off))
372 off = charLikeSize * ord c
374 amodeToStix (CCharLike x)
375 = StIndex CharRep charLike off
377 off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
379 amodeToStix (CIntLike (CLit (MachInt i _)))
380 = StLitLbl ((<>) (ptext SLIT("INTLIKE_closure+")) (int off))
382 off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
384 amodeToStix (CIntLike x)
387 amodeToStix (CLit core)
389 MachChar c -> StInt (toInteger (ord c))
390 MachStr s -> StString s
391 MachAddr a -> StInt a
392 MachInt i _ -> StInt (toInteger i)
393 MachLitLit s _ -> {-trace (_UNPK_ s ++ "\n")-} (litLitToStix (_UNPK_ s))
394 MachFloat d -> StDouble d
395 MachDouble d -> StDouble d
396 _ -> panic "amodeToStix:core literal"
398 amodeToStix (CLitLit s _)
399 = litLitToStix (_UNPK_ s)
401 amodeToStix (CMacroExpr _ macro [arg])
403 ENTRY_CODE -> amodeToStix arg
404 ARG_TAG -> amodeToStix arg -- just an integer no. of words
406 #ifdef WORDS_BIGENDIAN
408 [StInd WordRep (StIndex PtrRep (amodeToStix arg)
409 (StInt (toInteger (-1)))),
413 [StInd WordRep (StIndex PtrRep (amodeToStix arg)
414 (StInt (toInteger (-1)))),
418 -> StInd PtrRep (StIndex PtrRep (amodeToStix arg)
419 (StInt (toInteger uF_UPDATEE)))
421 -- GET_TAG(info_ptr) is supposed to be get_itbl(info_ptr)->srt_len,
422 -- which we've had to hand-code here.
424 litLitToStix :: String -> StixTree
427 "stdout" -> stixFor_stdout
428 "stderr" -> stixFor_stderr
429 "stdin" -> stixFor_stdin
430 other -> error ("\nlitLitToStix: can't handle `" ++ nm ++ "'\n"
431 ++ "suggested workaround: use flag -fvia-C\n")
434 Sizes of the CharLike and IntLike closures that are arranged as arrays
435 in the data segment. (These are in bytes.)
438 -- The INTLIKE base pointer
440 intLikePtr :: StixTree
442 intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closure"))
448 charLike = sStLitLbl SLIT("CHARLIKE_closure")
450 -- Trees for the ErrorIOPrimOp
452 topClosure, errorIO :: StixTree
454 topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
455 errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))
457 mutArrPtrsFrozen_info = sStLitLbl SLIT("MUT_ARR_PTRS_FROZEN_info")
459 charLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
460 intLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))