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@[ar,sr,dr] IntegerNegOp arg@[aa,sa,da]
57 = gmpNegate (ar,sr,dr) (aa,sa,da)
61 primCode [res] IntegerCmpOp args@[aa1,sa1,da1, aa2,sa2,da2]
62 = gmpCompare res (aa1,sa1,da1, aa2,sa2,da2)
64 primCode [res] Integer2IntOp arg@[aa,sa,da]
65 = gmpInteger2Int res (aa,sa,da)
67 primCode [res] Integer2WordOp arg@[aa,sa,da]
68 = gmpInteger2Word res (aa,sa,da)
70 primCode [res] Int2AddrOp [arg]
71 = simpleCoercion AddrRep res arg
73 primCode [res] Addr2IntOp [arg]
74 = simpleCoercion IntRep res arg
76 primCode [res] Int2WordOp [arg]
77 = simpleCoercion IntRep{-WordRep?-} res arg
79 primCode [res] Word2IntOp [arg]
80 = simpleCoercion IntRep res arg
84 primCode [res] SameMutableArrayOp args
86 compare = StPrim AddrEqOp (map amodeToStix args)
87 assign = StAssign IntRep (amodeToStix res) compare
89 returnUs (\xs -> assign : xs)
91 primCode res@[_] SameMutableByteArrayOp args
92 = primCode res SameMutableArrayOp args
95 Freezing an array of pointers is a double assignment. We fix the
96 header of the ``new'' closure because the lhs is probably a better
97 addressing mode for the indirection (most likely, it's a VanillaReg).
101 primCode [lhs] UnsafeFreezeArrayOp [rhs]
103 lhs' = amodeToStix lhs
104 rhs' = amodeToStix rhs
105 header = StInd PtrRep lhs'
106 assign = StAssign PtrRep lhs' rhs'
107 freeze = StAssign PtrRep header mutArrPtrsFrozen_info
109 returnUs (\xs -> assign : freeze : xs)
111 primCode [lhs] UnsafeFreezeByteArrayOp [rhs]
112 = simpleCoercion PtrRep lhs rhs
113 primCode [lhs] UnsafeThawByteArrayOp [rhs]
114 = simpleCoercion PtrRep lhs rhs
117 Returning the size of (mutable) byte arrays is just
118 an indexing operation.
121 primCode [lhs] SizeofByteArrayOp [rhs]
123 lhs' = amodeToStix lhs
124 rhs' = amodeToStix rhs
125 sz = StIndex IntRep rhs' fixedHS
126 assign = StAssign IntRep lhs' (StInd IntRep sz)
128 returnUs (\xs -> assign : xs)
130 primCode [lhs] SizeofMutableByteArrayOp [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)
141 Most other array primitives translate to simple indexing.
144 primCode lhs@[_] IndexArrayOp args
145 = primCode lhs ReadArrayOp args
147 primCode [lhs] ReadArrayOp [obj, ix]
149 lhs' = amodeToStix lhs
150 obj' = amodeToStix obj
152 base = StIndex IntRep obj' arrHS
153 assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
155 returnUs (\xs -> assign : xs)
157 primCode [] WriteArrayOp [obj, ix, v]
159 obj' = amodeToStix obj
162 base = StIndex IntRep obj' arrHS
163 assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
165 returnUs (\xs -> assign : xs)
167 primCode lhs@[_] (IndexByteArrayOp pk) args
168 = primCode lhs (ReadByteArrayOp pk) args
170 -- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
172 primCode [lhs] (ReadByteArrayOp pk) [obj, ix]
174 lhs' = amodeToStix lhs
175 obj' = amodeToStix obj
177 base = StIndex IntRep obj' arrHS
178 assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
180 returnUs (\xs -> assign : xs)
182 primCode [lhs] (IndexOffAddrOp pk) [obj, ix]
184 lhs' = amodeToStix lhs
185 obj' = amodeToStix obj
187 assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
189 returnUs (\xs -> assign : xs)
191 primCode [lhs] (IndexOffForeignObjOp pk) [obj, ix]
193 lhs' = amodeToStix lhs
194 obj' = amodeToStix obj
196 obj'' = StIndex PtrRep obj' fixedHS
197 assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix'))
199 returnUs (\xs -> assign : xs)
201 primCode [] (WriteByteArrayOp pk) [obj, ix, v]
203 obj' = amodeToStix obj
206 base = StIndex IntRep obj' arrHS
207 assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
209 returnUs (\xs -> assign : xs)
213 --primCode lhs (CCallOp fn is_asm may_gc) rhs
214 primCode lhs (CCallOp (Left fn) is_asm may_gc cconv) rhs
215 | is_asm = error "ERROR: Native code generator can't handle casm"
216 | may_gc = error "ERROR: Native code generator can't handle _ccall_GC_\n"
219 [] -> returnUs (\xs -> (StCall fn cconv VoidRep args) : xs)
221 let lhs' = amodeToStix lhs
222 pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
223 call = StAssign pk lhs' (StCall fn cconv pk args)
225 returnUs (\xs -> call : xs)
227 args = map amodeCodeForCCall rhs
228 amodeCodeForCCall x =
229 let base = amodeToStix' x
231 case getAmodeRep x of
232 ArrayRep -> StIndex PtrRep base arrHS
233 ByteArrayRep -> StIndex IntRep base arrHS
234 ForeignObjRep -> StIndex PtrRep base fixedHS
238 DataToTagOp won't work for 64-bit archs, as it is.
241 primCode [lhs] DataToTagOp [arg]
242 = let lhs' = amodeToStix lhs
243 arg' = amodeToStix arg
244 infoptr = StInd PtrRep arg'
245 word_32 = StInd WordRep (StIndex PtrRep infoptr (StInt (-1)))
246 masked_le32 = StPrim SrlOp [word_32, StInt 16]
247 masked_be32 = StPrim AndOp [word_32, StInt 65535]
248 #ifdef WORDS_BIGENDIAN
253 assign = StAssign IntRep lhs' masked
255 returnUs (\xs -> assign : xs)
258 Now the more mundane operations.
263 lhs' = map amodeToStix lhs
264 rhs' = map amodeToStix' rhs
265 pk = getAmodeRep (head lhs)
267 returnUs (\ xs -> simplePrim pk lhs' op rhs' : xs)
275 -> UniqSM StixTreeList
277 simpleCoercion pk lhs rhs
278 = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
281 Here we try to rewrite primitives into a form the code generator can
282 understand. Any primitives not handled here must be handled at the
283 level of the specific code generator.
287 :: PrimRep -- Rep of first destination
288 -> [StixTree] -- Destinations
294 Now look for something more conventional.
297 simplePrim pk [lhs] op rest = StAssign pk lhs (StPrim op rest)
298 simplePrim pk as op bs = simplePrim_error op
301 = 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")
304 %---------------------------------------------------------------------
306 Here we generate the Stix code for CAddrModes.
308 When a character is fetched from a mixed type location, we have to do
309 an extra cast. This is reflected in amodeCode', which is for rhs
310 amodes that might possibly need the extra cast.
313 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
315 amodeToStix'{-'-} am@(CVal rr CharRep)
316 | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
317 | otherwise = amodeToStix am
319 amodeToStix' am = amodeToStix am
322 amodeToStix am@(CVal rr CharRep)
324 = StInd IntRep (amodeToStix (CAddr rr))
326 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
328 amodeToStix (CAddr (SpRel off))
329 = StIndex PtrRep stgSp (StInt (toInteger IBOX(off)))
331 amodeToStix (CAddr (HpRel off))
332 = StIndex IntRep stgHp (StInt (toInteger (- IBOX(off))))
334 amodeToStix (CAddr (NodeRel off))
335 = StIndex IntRep stgNode (StInt (toInteger IBOX(off)))
337 amodeToStix (CAddr (CIndex base off pk))
338 = StIndex pk (amodeToStix base) (amodeToStix off)
340 amodeToStix (CReg magic) = StReg (StixMagicId magic)
341 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
343 amodeToStix (CLbl lbl _) = StCLbl lbl
345 -- For CharLike and IntLike, we attempt some trivial constant-folding here.
347 amodeToStix (CCharLike (CLit (MachChar c)))
348 = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closure+")) (int off))
350 off = charLikeSize * ord c
352 amodeToStix (CCharLike x)
353 = StIndex PtrRep charLike off
355 off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
357 amodeToStix (CIntLike (CLit (MachInt i _)))
358 = StLitLbl ((<>) (ptext SLIT("INTLIKE_closure+")) (int off))
360 off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
362 amodeToStix (CIntLike x)
365 amodeToStix (CLit core)
367 MachChar c -> StInt (toInteger (ord c))
368 MachStr s -> StString s
369 MachAddr a -> StInt a
370 MachInt i _ -> StInt (toInteger i)
371 MachLitLit s _ -> {-trace (_UNPK_ s ++ "\n")-} (litLitToStix (_UNPK_ s))
372 MachFloat d -> StDouble d
373 MachDouble d -> StDouble d
374 _ -> panic "amodeToStix:core literal"
376 amodeToStix (CLitLit s _)
377 = litLitToStix (_UNPK_ s)
379 amodeToStix (CMacroExpr _ macro [arg])
381 ENTRY_CODE -> amodeToStix arg
382 ARG_TAG -> amodeToStix arg -- just an integer no. of words
383 GET_TAG -> StPrim SrlOp
384 [StInd WordRep (StPrim IntSubOp [amodeToStix arg,
388 -> StInd PtrRep (StIndex PtrRep (amodeToStix arg)
389 (StInt (toInteger uF_UPDATEE)))
391 -- GET_TAG(info_ptr) is supposed to be get_itbl(info_ptr)->srt_len,
392 -- which we've had to hand-code here.
394 litLitToStix :: String -> StixTree
397 "stdout" -> stixFor_stdout
398 "stderr" -> stixFor_stderr
399 "stdin" -> stixFor_stdin
400 other -> error ("\nlitLitToStix: can't handle `" ++ nm ++ "'\n"
401 ++ "suggested workaround: use flag -fvia-C\n")
404 Sizes of the CharLike and IntLike closures that are arranged as arrays
405 in the data segment. (These are in bytes.)
408 -- The INTLIKE base pointer
410 intLikePtr :: StixTree
412 intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closure"))
418 charLike = sStLitLbl SLIT("CHARLIKE_closure")
420 -- Trees for the ErrorIOPrimOp
422 topClosure, errorIO :: StixTree
424 topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
425 errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))
427 mutArrPtrsFrozen_info = sStLitLbl SLIT("MUT_ARR_PTRS_FROZEN_info")
429 charLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
430 intLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))