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 SMRep ( fixedHdrSize )
18 import Const ( Literal(..) )
19 import CallConv ( cCallConv )
20 import PrimOp ( PrimOp(..) )
21 import PrimRep ( PrimRep(..), isFloatingRep )
22 import UniqSupply ( returnUs, thenUs, UniqSM )
23 import Constants ( mIN_INTLIKE )
29 The main honcho here is primCode, which handles the guts of COpStmts.
33 :: [CAddrMode] -- results
35 -> [CAddrMode] -- args
36 -> UniqSM StixTreeList
39 First, the dreaded @ccall@. We can't handle @casm@s.
41 Usually, this compiles to an assignment, but when the left-hand side
42 is empty, we just perform the call and ignore the result.
44 btw Why not let programmer use casm to provide assembly code instead
47 The (MP) integer operations are a true nightmare. Since we don't have
48 a convenient abstract way of allocating temporary variables on the (C)
49 stack, we use the space just below HpLim for the @MP_INT@ structures,
50 and modify our heap check accordingly.
53 -- NB: ordering of clauses somewhere driven by
54 -- the desire to getting sane patt-matching behavior
55 primCode res@[ar,sr,dr] IntegerNegOp arg@[aa,sa,da]
56 = gmpNegate (ar,sr,dr) (aa,sa,da)
60 primCode [res] IntegerCmpOp args@[aa1,sa1,da1, aa2,sa2,da2]
61 = gmpCompare res (aa1,sa1,da1, aa2,sa2,da2)
63 primCode [res] Integer2IntOp arg@[aa,sa,da]
64 = gmpInteger2Int res (aa,sa,da)
66 primCode [res] Integer2WordOp arg@[aa,sa,da]
67 = gmpInteger2Word res (aa,sa,da)
69 primCode [res] Int2AddrOp [arg]
70 = simpleCoercion AddrRep res arg
72 primCode [res] Addr2IntOp [arg]
73 = simpleCoercion IntRep res arg
75 primCode [res] Int2WordOp [arg]
76 = simpleCoercion IntRep{-WordRep?-} res arg
78 primCode [res] Word2IntOp [arg]
79 = simpleCoercion IntRep res arg
83 primCode [res] SameMutableArrayOp args
85 compare = StPrim AddrEqOp (map amodeToStix args)
86 assign = StAssign IntRep (amodeToStix res) compare
88 returnUs (\xs -> assign : xs)
90 primCode res@[_] SameMutableByteArrayOp args
91 = primCode res SameMutableArrayOp args
94 Freezing an array of pointers is a double assignment. We fix the
95 header of the ``new'' closure because the lhs is probably a better
96 addressing mode for the indirection (most likely, it's a VanillaReg).
100 primCode [lhs] UnsafeFreezeArrayOp [rhs]
102 lhs' = amodeToStix lhs
103 rhs' = amodeToStix rhs
104 header = StInd PtrRep lhs'
105 assign = StAssign PtrRep lhs' rhs'
106 freeze = StAssign PtrRep header mutArrPtrsFrozen_info
108 returnUs (\xs -> assign : freeze : xs)
110 primCode [lhs] UnsafeFreezeByteArrayOp [rhs]
111 = simpleCoercion PtrRep lhs rhs
112 primCode [lhs] UnsafeThawByteArrayOp [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' arrHS
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' arrHS
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' arrHS
177 assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
179 returnUs (\xs -> assign : xs)
181 primCode [lhs] (IndexOffAddrOp pk) [obj, ix]
183 lhs' = amodeToStix lhs
184 obj' = amodeToStix obj
186 assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
188 returnUs (\xs -> assign : xs)
190 primCode [lhs] (IndexOffForeignObjOp pk) [obj, ix]
192 lhs' = amodeToStix lhs
193 obj' = amodeToStix obj
195 obj'' = StIndex PtrRep obj' fixedHS
196 assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix'))
198 returnUs (\xs -> assign : xs)
200 primCode [] (WriteByteArrayOp pk) [obj, ix, v]
202 obj' = amodeToStix obj
205 base = StIndex IntRep obj' arrHS
206 assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
208 returnUs (\xs -> assign : xs)
212 --primCode lhs (CCallOp fn is_asm may_gc) rhs
213 primCode lhs (CCallOp (Left fn) is_asm may_gc cconv) rhs
214 | is_asm = error "ERROR: Native code generator can't handle casm"
215 | may_gc = error "ERROR: Native code generator can't handle _ccall_GC_\n"
218 [] -> returnUs (\xs -> (StCall fn cconv VoidRep args) : xs)
220 let lhs' = amodeToStix lhs
221 pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
222 call = StAssign pk lhs' (StCall fn cconv pk args)
224 returnUs (\xs -> call : xs)
226 args = map amodeCodeForCCall rhs
227 amodeCodeForCCall x =
228 let base = amodeToStix' x
230 case getAmodeRep x of
231 ArrayRep -> StIndex PtrRep base arrHS
232 ByteArrayRep -> StIndex IntRep base arrHS
233 ForeignObjRep -> StIndex PtrRep base fixedHS
237 DataToTagOp won't work for 64-bit archs, as it is.
240 primCode [lhs] DataToTagOp [arg]
241 = let lhs' = amodeToStix lhs
242 arg' = amodeToStix arg
243 infoptr = StInd PtrRep arg'
244 word_32 = StInd WordRep (StIndex PtrRep infoptr (StInt (-1)))
245 masked_le32 = StPrim SrlOp [word_32, StInt 16]
246 masked_be32 = StPrim AndOp [word_32, StInt 65535]
247 #ifdef WORDS_BIGENDIAN
252 assign = StAssign IntRep lhs' masked
254 returnUs (\xs -> assign : xs)
257 Now the more mundane operations.
262 lhs' = map amodeToStix lhs
263 rhs' = map amodeToStix' rhs
264 pk = getAmodeRep (head lhs)
266 returnUs (\ xs -> simplePrim pk lhs' op rhs' : xs)
274 -> UniqSM StixTreeList
276 simpleCoercion pk lhs rhs
277 = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
280 Here we try to rewrite primitives into a form the code generator can
281 understand. Any primitives not handled here must be handled at the
282 level of the specific code generator.
286 :: PrimRep -- Rep of first destination
287 -> [StixTree] -- Destinations
293 Now look for something more conventional.
296 simplePrim pk [lhs] op rest = StAssign pk lhs (StPrim op rest)
297 simplePrim pk as op bs = simplePrim_error op
300 = 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")
303 %---------------------------------------------------------------------
305 Here we generate the Stix code for CAddrModes.
307 When a character is fetched from a mixed type location, we have to do
308 an extra cast. This is reflected in amodeCode', which is for rhs
309 amodes that might possibly need the extra cast.
312 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
314 amodeToStix'{-'-} am@(CVal rr CharRep)
315 | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
316 | otherwise = amodeToStix am
318 amodeToStix' am = amodeToStix am
321 amodeToStix am@(CVal rr CharRep)
323 = StInd IntRep (amodeToStix (CAddr rr))
325 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
327 amodeToStix (CAddr (SpRel off))
328 = StIndex PtrRep stgSp (StInt (toInteger IBOX(off)))
330 amodeToStix (CAddr (HpRel off))
331 = StIndex IntRep stgHp (StInt (toInteger (- IBOX(off))))
333 amodeToStix (CAddr (NodeRel off))
334 = StIndex IntRep stgNode (StInt (toInteger IBOX(off)))
336 amodeToStix (CAddr (CIndex base off pk))
337 = StIndex pk (amodeToStix base) (amodeToStix off)
339 amodeToStix (CReg magic) = StReg (StixMagicId magic)
340 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
342 amodeToStix (CLbl lbl _) = StCLbl lbl
344 -- For CharLike and IntLike, we attempt some trivial constant-folding here.
346 amodeToStix (CCharLike (CLit (MachChar c)))
347 = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closure+")) (int off))
349 off = charLikeSize * ord c
351 amodeToStix (CCharLike x)
352 = StIndex PtrRep charLike off
354 off = StPrim IntMulOp [amodeToStix x, StInt (toInteger (fixedHdrSize+1))]
356 amodeToStix (CIntLike (CLit (MachInt i _)))
357 = StLitLbl ((<>) (ptext SLIT("INTLIKE_closure+")) (int off))
359 off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
361 amodeToStix (CIntLike x)
364 amodeToStix (CLit core)
366 MachChar c -> StInt (toInteger (ord c))
367 MachStr s -> StString s
368 MachAddr a -> StInt a
369 MachInt i _ -> StInt (toInteger i)
370 MachLitLit s _ -> StLitLit s
371 MachFloat d -> StDouble d
372 MachDouble d -> StDouble d
373 _ -> panic "amodeToStix:core literal"
375 -- A CLitLit is just a (CLit . MachLitLit)
376 amodeToStix (CLitLit s _) = StLitLit s
378 amodeToStix (CMacroExpr _ macro [arg])
380 ENTRY_CODE -> amodeToStix arg
381 ARG_TAG -> amodeToStix arg -- just an integer no. of words
382 GET_TAG -> StPrim SrlOp
383 [StInd WordRep (StPrim IntSubOp [amodeToStix arg,
388 -- GET_TAG(info_ptr) is supposed to be get_itbl(info_ptr)->srt_len,
389 -- which we've had to hand-code here.
392 Sizes of the CharLike and IntLike closures that are arranged as arrays
393 in the data segment. (These are in bytes.)
396 -- The INTLIKE base pointer
398 intLikePtr :: StixTree
400 intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closure"))
406 charLike = sStLitLbl SLIT("CHARLIKE_closure")
408 -- Trees for the ErrorIOPrimOp
410 topClosure, errorIO :: StixTree
412 topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
413 errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))
415 mutArrPtrsFrozen_info = sStLitLbl SLIT("MUT_ARR_PTRS_FROZEN_info")
417 charLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
418 intLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))