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 Now the more mundane operations.
264 lhs' = map amodeToStix lhs
265 rhs' = map amodeToStix' rhs
266 pk = getAmodeRep (head lhs)
268 returnUs (\ xs -> simplePrim pk lhs' op rhs' : xs)
276 -> UniqSM StixTreeList
278 simpleCoercion pk lhs rhs
279 = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
282 Here we try to rewrite primitives into a form the code generator can
283 understand. Any primitives not handled here must be handled at the
284 level of the specific code generator.
288 :: PrimRep -- Rep of first destination
289 -> [StixTree] -- Destinations
295 Now look for something more conventional.
298 simplePrim pk [lhs] op rest = StAssign pk lhs (StPrim op rest)
299 simplePrim pk as op bs = simplePrim_error op
302 = 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")
305 %---------------------------------------------------------------------
307 Here we generate the Stix code for CAddrModes.
309 When a character is fetched from a mixed type location, we have to do
310 an extra cast. This is reflected in amodeCode', which is for rhs
311 amodes that might possibly need the extra cast.
314 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
316 amodeToStix'{-'-} am@(CVal rr CharRep)
317 | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
318 | otherwise = amodeToStix am
320 amodeToStix' am = amodeToStix am
323 amodeToStix am@(CVal rr CharRep)
325 = StInd IntRep (amodeToStix (CAddr rr))
327 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
329 amodeToStix (CAddr (SpRel off))
330 = StIndex PtrRep stgSp (StInt (toInteger IBOX(off)))
332 amodeToStix (CAddr (HpRel off))
333 = StIndex IntRep stgHp (StInt (toInteger (- IBOX(off))))
335 amodeToStix (CAddr (NodeRel off))
336 = StIndex IntRep stgNode (StInt (toInteger IBOX(off)))
338 amodeToStix (CAddr (CIndex base off pk))
339 = StIndex pk (amodeToStix base) (amodeToStix off)
341 amodeToStix (CReg magic) = StReg (StixMagicId magic)
342 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
344 amodeToStix (CLbl lbl _) = StCLbl lbl
346 -- For CharLike and IntLike, we attempt some trivial constant-folding here.
348 amodeToStix (CCharLike (CLit (MachChar c)))
349 = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closure+")) (int off))
351 off = charLikeSize * ord c
353 amodeToStix (CCharLike x)
354 = StIndex CharRep charLike off
356 off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
358 amodeToStix (CIntLike (CLit (MachInt i _)))
359 = StLitLbl ((<>) (ptext SLIT("INTLIKE_closure+")) (int off))
361 off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
363 amodeToStix (CIntLike x)
366 amodeToStix (CLit core)
368 MachChar c -> StInt (toInteger (ord c))
369 MachStr s -> StString s
370 MachAddr a -> StInt a
371 MachInt i _ -> StInt (toInteger i)
372 MachLitLit s _ -> {-trace (_UNPK_ s ++ "\n")-} (litLitToStix (_UNPK_ s))
373 MachFloat d -> StDouble d
374 MachDouble d -> StDouble d
375 _ -> panic "amodeToStix:core literal"
377 amodeToStix (CLitLit s _)
378 = litLitToStix (_UNPK_ s)
380 amodeToStix (CMacroExpr _ macro [arg])
382 ENTRY_CODE -> amodeToStix arg
383 ARG_TAG -> amodeToStix arg -- just an integer no. of words
385 #ifdef WORDS_BIGENDIAN
387 [StInd WordRep (StIndex PtrRep (amodeToStix arg)
388 (StInt (toInteger (-1)))),
392 [StInd WordRep (StIndex PtrRep (amodeToStix arg)
393 (StInt (toInteger (-1)))),
397 -> StInd PtrRep (StIndex PtrRep (amodeToStix arg)
398 (StInt (toInteger uF_UPDATEE)))
400 -- GET_TAG(info_ptr) is supposed to be get_itbl(info_ptr)->srt_len,
401 -- which we've had to hand-code here.
403 litLitToStix :: String -> StixTree
406 "stdout" -> stixFor_stdout
407 "stderr" -> stixFor_stderr
408 "stdin" -> stixFor_stdin
409 other -> error ("\nlitLitToStix: can't handle `" ++ nm ++ "'\n"
410 ++ "suggested workaround: use flag -fvia-C\n")
413 Sizes of the CharLike and IntLike closures that are arranged as arrays
414 in the data segment. (These are in bytes.)
417 -- The INTLIKE base pointer
419 intLikePtr :: StixTree
421 intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closure"))
427 charLike = sStLitLbl SLIT("CHARLIKE_closure")
429 -- Trees for the ErrorIOPrimOp
431 topClosure, errorIO :: StixTree
433 topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
434 errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))
436 mutArrPtrsFrozen_info = sStLitLbl SLIT("MUT_ARR_PTRS_FROZEN_info")
438 charLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
439 intLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))