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.
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 Now the more mundane operations.
243 lhs' = map amodeToStix lhs
244 rhs' = map amodeToStix' rhs
245 pk = getAmodeRep (head lhs)
247 returnUs (\ xs -> simplePrim pk lhs' op rhs' : xs)
255 -> UniqSM StixTreeList
257 simpleCoercion pk lhs rhs
258 = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
261 Here we try to rewrite primitives into a form the code generator can
262 understand. Any primitives not handled here must be handled at the
263 level of the specific code generator.
267 :: PrimRep -- Rep of first destination
268 -> [StixTree] -- Destinations
274 Now look for something more conventional.
277 simplePrim pk [lhs] op rest = StAssign pk lhs (StPrim op rest)
278 simplePrim pk as op bs = simplePrim_error op
281 = 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")
284 %---------------------------------------------------------------------
286 Here we generate the Stix code for CAddrModes.
288 When a character is fetched from a mixed type location, we have to do
289 an extra cast. This is reflected in amodeCode', which is for rhs
290 amodes that might possibly need the extra cast.
293 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
295 amodeToStix'{-'-} am@(CVal rr CharRep)
296 | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
297 | otherwise = amodeToStix am
299 amodeToStix' am = amodeToStix am
302 amodeToStix am@(CVal rr CharRep)
304 = StInd IntRep (amodeToStix (CAddr rr))
306 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
308 amodeToStix (CAddr (SpRel off))
309 = StIndex PtrRep stgSp (StInt (toInteger IBOX(off)))
311 amodeToStix (CAddr (HpRel off))
312 = StIndex IntRep stgHp (StInt (toInteger (- IBOX(off))))
314 amodeToStix (CAddr (NodeRel off))
315 = StIndex IntRep stgNode (StInt (toInteger IBOX(off)))
317 amodeToStix (CAddr (CIndex base off pk))
318 = StIndex pk (amodeToStix base) (amodeToStix off)
320 amodeToStix (CReg magic) = StReg (StixMagicId magic)
321 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
323 amodeToStix (CLbl lbl _) = StCLbl lbl
325 -- For CharLike and IntLike, we attempt some trivial constant-folding here.
327 amodeToStix (CCharLike (CLit (MachChar c)))
328 = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closure+")) (int off))
330 off = charLikeSize * ord c
332 amodeToStix (CCharLike x)
333 = StIndex PtrRep charLike off
335 off = StPrim IntMulOp [amodeToStix x, StInt (toInteger (fixedHdrSize+1))]
337 amodeToStix (CIntLike (CLit (MachInt i _)))
338 = StLitLbl ((<>) (ptext SLIT("INTLIKE_closure+")) (int off))
340 off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
342 amodeToStix (CIntLike x)
345 amodeToStix (CLit core)
347 MachChar c -> StInt (toInteger (ord c))
348 MachStr s -> StString s
349 MachAddr a -> StInt a
350 MachInt i _ -> StInt (toInteger i)
351 MachLitLit s _ -> StLitLit s
352 MachFloat d -> StDouble d
353 MachDouble d -> StDouble d
354 _ -> panic "amodeToStix:core literal"
356 -- A CLitLit is just a (CLit . MachLitLit)
357 amodeToStix (CLitLit s _) = StLitLit s
359 amodeToStix (CMacroExpr _ macro [arg])
361 ENTRY_CODE -> amodeToStix arg
362 ARG_TAG -> amodeToStix arg -- just an integer no. of words
363 GET_TAG -> StPrim SrlOp
364 [StInd WordRep (StPrim IntSubOp [amodeToStix arg,
369 -- GET_TAG(info_ptr) is supposed to be get_itbl(info_ptr)->srt_len,
370 -- which we've had to hand-code here.
373 Sizes of the CharLike and IntLike closures that are arranged as arrays
374 in the data segment. (These are in bytes.)
377 -- The INTLIKE base pointer
379 intLikePtr :: StixTree
381 intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closure"))
387 charLike = sStLitLbl SLIT("CHARLIKE_closure")
389 -- Trees for the ErrorIOPrimOp
391 topClosure, errorIO :: StixTree
393 topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
394 errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))
396 mutArrPtrsFrozen_info = sStLitLbl SLIT("MUT_ARR_PTRS_FROZEN_info")
398 charLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
399 intLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))