ghc/compiler/nativeGen/StixPrim.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1998
   3 %
   4
   5 \begin{code}
   6 module StixPrim ( primCode, amodeToStix, amodeToStix', foreignCallCode )
   7   where
   8
   9 #include "HsVersions.h"
  10
  11 import MachMisc
  12 import Stix
  13 import StixInteger
  14
  15 import AbsCSyn          hiding ( spRel )
  16 import AbsCUtils        ( getAmodeRep, mixedTypeLocn )
  17 import SMRep            ( fixedHdrSize )
  18 import Literal          ( Literal(..), word2IntLit )
  19 import PrimOp           ( PrimOp(..) )
  20 import PrimRep          ( PrimRep(..), getPrimRepSizeInBytes )
  21 import UniqSupply       ( returnUs, thenUs, getUniqueUs, UniqSM )
  22 import Constants        ( mIN_INTLIKE, mIN_CHARLIKE, uF_UPDATEE, bLOCK_SIZE,
  23                           rESERVED_STACK_WORDS )
  24 import CLabel           ( mkIntlikeClosureLabel, mkCharlikeClosureLabel,
  25                           mkMAP_FROZEN_infoLabel, mkEMPTY_MVAR_infoLabel,
  26                           mkForeignLabel )
  27 import ForeignCall      ( ForeignCall(..), CCallSpec(..), CCallTarget(..),
  28                           CCallConv(..), playSafe )
  29 import Outputable
  30 import FastTypes
  31
  32 #include "NCG.h"
  33 \end{code}
  34
  35 The main honchos here are primCode anf foreignCallCode, which handle the guts of COpStmts.
  36
  37 \begin{code}
  38 foreignCallCode
  39     :: [CAddrMode]      -- results
  40     -> ForeignCall      -- op
  41     -> [CAddrMode]      -- args
  42     -> UniqSM StixTreeList
  43
  44 primCode
  45     :: [CAddrMode]      -- results
  46     -> PrimOp           -- op
  47     -> [CAddrMode]      -- args
  48     -> UniqSM StixTreeList
  49 \end{code}
  50
  51 %************************************************************************
  52 %*                                                                      *
  53 \subsubsection{Code for foreign calls}
  54 %*                                                                      *
  55 %************************************************************************
  56
  57 First, the dreaded @ccall@.  We can't handle @casm@s.
  58
  59 Usually, this compiles to an assignment, but when the left-hand side
  60 is empty, we just perform the call and ignore the result.
  61
  62 btw Why not let programmer use casm to provide assembly code instead
  63 of C code?  ADR
  64
  65 ToDo: saving/restoring of volatile regs around ccalls.
  66
  67 JRS, 001113: always do the call of suspendThread and resumeThread as a ccall
  68 rather than inheriting the calling convention of the thing which we're really
  69 calling.
  70
  71 \begin{code}
  72 foreignCallCode lhs (CCall (CCallSpec (StaticTarget fn) cconv safety)) rhs
  73   | not (playSafe safety) = returnUs (\xs -> ccall : xs)
  74
  75   | otherwise
  76   = save_thread_state   `thenUs` \ save ->
  77     load_thread_state   `thenUs` \ load ->
  78     getUniqueUs         `thenUs` \ uniq ->
  79     let
  80        id  = StReg (StixTemp uniq IntRep)
  81
  82        suspend = StAssign IntRep id
  83                 (StCall SLIT("suspendThread") {-no:cconv-} CCallConv
  84                             IntRep [stgBaseReg])
  85        resume  = StCall SLIT("resumeThread") {-no:cconv-} CCallConv
  86                         VoidRep [id]
  87     in
  88     returnUs (\xs -> save (suspend : ccall : resume : load xs))
  89
  90   where
  91     args = map amodeCodeForCCall rhs
  92     amodeCodeForCCall x =
  93         let base = amodeToStix' x
  94         in
  95             case getAmodeRep x of
  96               ArrayRep      -> StIndex PtrRep base arrPtrsHS
  97               ByteArrayRep  -> StIndex IntRep base arrWordsHS
  98               ForeignObjRep -> StInd PtrRep (StIndex PtrRep base fixedHS)
  99               _ -> base
 100
 101     ccall = case lhs of
 102       []    -> StCall fn cconv VoidRep args
 103       [lhs] -> StAssign pk lhs' (StCall fn cconv pk args)
 104             where
 105                lhs' = amodeToStix lhs
 106                pk   = case getAmodeRep lhs of
 107                         FloatRep  -> FloatRep
 108                         DoubleRep -> DoubleRep
 109                         other     -> IntRep
 110
 111 foreignCallCode lhs call rhs
 112   = ncgPrimopMoan "Native code generator can't handle foreign call" (ppr call)
 113 \end{code}
 114
 115
 116 %************************************************************************
 117 %*                                                                      *
 118 \subsubsection{Code for primops}
 119 %*                                                                      *
 120 %************************************************************************
 121
 122 The (MP) integer operations are a true nightmare.  Since we don't have
 123 a convenient abstract way of allocating temporary variables on the (C)
 124 stack, we use the space just below HpLim for the @MP_INT@ structures,
 125 and modify our heap check accordingly.
 126
 127 \begin{code}
 128 -- NB: ordering of clauses somewhere driven by
 129 -- the desire to getting sane patt-matching behavior
 130
 131 primCode [res] IntegerCmpOp args@[sa1,da1, sa2,da2]
 132   = gmpCompare res (sa1,da1, sa2,da2)
 133
 134 primCode [res] IntegerCmpIntOp args@[sa1,da1,ai]
 135   = gmpCompareInt res (sa1,da1,ai)
 136
 137 primCode [res] Integer2IntOp arg@[sa,da]
 138   = gmpInteger2Int res (sa,da)
 139
 140 primCode [res] Integer2WordOp arg@[sa,da]
 141   = gmpInteger2Word res (sa,da)
 142
 143 primCode [res] Int2WordOp [arg]
 144   = simpleCoercion IntRep{-WordRep?-} res arg
 145
 146 primCode [res] Word2IntOp [arg]
 147   = simpleCoercion IntRep res arg
 148
 149 primCode [res] AddrToHValueOp [arg]
 150   = simpleCoercion PtrRep res arg
 151
 152 #if (WORD_SIZE_IN_BITS == 32 || WORD_SIZE_IN_BITS == 64)
 153 primCode [res] Int2AddrOp [arg]
 154   = simpleCoercion AddrRep res arg
 155
 156 primCode [res] Addr2IntOp [arg]
 157   = simpleCoercion IntRep res arg
 158 #endif
 159
 160 primCode [res] Narrow8IntOp [arg]
 161   = narrowingCoercion IntRep Int8Rep res arg
 162 primCode [res] Narrow16IntOp [arg]
 163   = narrowingCoercion IntRep Int16Rep res arg
 164 primCode [res] Narrow32IntOp [arg]
 165   = narrowingCoercion IntRep Int32Rep res arg
 166
 167 primCode [res] Narrow8WordOp [arg]
 168   = narrowingCoercion WordRep Word8Rep res arg
 169 primCode [res] Narrow16WordOp [arg]
 170   = narrowingCoercion WordRep Word16Rep res arg
 171 primCode [res] Narrow32WordOp [arg]
 172   = narrowingCoercion WordRep Word32Rep res arg
 173 \end{code}
 174
 175 \begin{code}
 176 primCode [res] SameMutableArrayOp args
 177   = let
 178         compare = StPrim AddrEqOp (map amodeToStix args)
 179         assign = StAssign IntRep (amodeToStix res) compare
 180     in
 181     returnUs (\xs -> assign : xs)
 182
 183 primCode res@[_] SameMutableByteArrayOp args
 184   = primCode res SameMutableArrayOp args
 185
 186 primCode res@[_] SameMutVarOp args
 187   = primCode res SameMutableArrayOp args
 188 \end{code}
 189
 190 \begin{code}
 191 primCode res@[_] SameMVarOp args
 192   = primCode res SameMutableArrayOp args
 193
 194 -- #define isEmptyMVarzh(r,a) \
 195 --     r =(I_)((GET_INFO((StgMVar*)(a))) == &stg_EMPTY_MVAR_info )
 196 primCode [res] IsEmptyMVarOp [arg]
 197    = let res'     = amodeToStix res
 198          arg'     = amodeToStix arg
 199          arg_info = StInd PtrRep arg'
 200          em_info  = StCLbl mkEMPTY_MVAR_infoLabel
 201          same     = StPrim IntEqOp [arg_info, em_info]
 202          assign   = StAssign IntRep res' same
 203      in
 204      returnUs (\xs -> assign : xs)
 205
 206 -- #define myThreadIdzh(t) (t = CurrentTSO)
 207 primCode [res] MyThreadIdOp []
 208    = let res' = amodeToStix res
 209      in  returnUs (\xs -> StAssign ThreadIdRep res' stgCurrentTSO : xs)
 210
 211 \end{code}
 212
 213 Freezing an array of pointers is a double assignment.  We fix the
 214 header of the ``new'' closure because the lhs is probably a better
 215 addressing mode for the indirection (most likely, it's a VanillaReg).
 216
 217 \begin{code}
 218
 219 primCode [lhs] UnsafeFreezeArrayOp [rhs]
 220   = let
 221         lhs' = amodeToStix lhs
 222         rhs' = amodeToStix rhs
 223         header = StInd PtrRep lhs'
 224         assign = StAssign PtrRep lhs' rhs'
 225         freeze = StAssign PtrRep header mutArrPtrsFrozen_info
 226     in
 227     returnUs (\xs -> assign : freeze : xs)
 228
 229 primCode [lhs] UnsafeFreezeByteArrayOp [rhs]
 230   = simpleCoercion PtrRep lhs rhs
 231 \end{code}
 232
 233 Returning the size of (mutable) byte arrays is just
 234 an indexing operation.
 235
 236 \begin{code}
 237 primCode [lhs] SizeofByteArrayOp [rhs]
 238   = let
 239         lhs' = amodeToStix lhs
 240         rhs' = amodeToStix rhs
 241         sz   = StIndex IntRep rhs' fixedHS
 242         assign = StAssign IntRep lhs' (StInd IntRep sz)
 243     in
 244     returnUs (\xs -> assign : xs)
 245
 246 primCode [lhs] SizeofMutableByteArrayOp [rhs]
 247   = let
 248         lhs' = amodeToStix lhs
 249         rhs' = amodeToStix rhs
 250         sz   = StIndex IntRep rhs' fixedHS
 251         assign = StAssign IntRep lhs' (StInd IntRep sz)
 252     in
 253     returnUs (\xs -> assign : xs)
 254
 255 \end{code}
 256
 257 Most other array primitives translate to simple indexing.
 258
 259 \begin{code}
 260 primCode lhs@[_] IndexArrayOp args
 261   = primCode lhs ReadArrayOp args
 262
 263 primCode [lhs] ReadArrayOp [obj, ix]
 264   = let
 265         lhs' = amodeToStix lhs
 266         obj' = amodeToStix obj
 267         ix' = amodeToStix ix
 268         base = StIndex IntRep obj' arrPtrsHS
 269         assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
 270     in
 271     returnUs (\xs -> assign : xs)
 272
 273 primCode [] WriteArrayOp [obj, ix, v]
 274   = let
 275         obj' = amodeToStix obj
 276         ix' = amodeToStix ix
 277         v' = amodeToStix v
 278         base = StIndex IntRep obj' arrPtrsHS
 279         assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
 280     in
 281     returnUs (\xs -> assign : xs)
 282
 283 primCode [] WriteForeignObjOp [obj, v]
 284   = let
 285         obj' = amodeToStix obj
 286         v' = amodeToStix v
 287         obj'' = StIndex AddrRep obj' (StInt 4711) -- fixedHS
 288         assign = StAssign AddrRep (StInd AddrRep obj'') v'
 289     in
 290     returnUs (\xs -> assign : xs)
 291
 292 -- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
 293 primCode ls IndexByteArrayOp_Char      rs = primCode_ReadByteArrayOp Word8Rep     ls rs
 294 primCode ls IndexByteArrayOp_WideChar  rs = primCode_ReadByteArrayOp CharRep      ls rs
 295 primCode ls IndexByteArrayOp_Int       rs = primCode_ReadByteArrayOp IntRep       ls rs
 296 primCode ls IndexByteArrayOp_Word      rs = primCode_ReadByteArrayOp WordRep      ls rs
 297 primCode ls IndexByteArrayOp_Addr      rs = primCode_ReadByteArrayOp AddrRep      ls rs
 298 primCode ls IndexByteArrayOp_Float     rs = primCode_ReadByteArrayOp FloatRep     ls rs
 299 primCode ls IndexByteArrayOp_Double    rs = primCode_ReadByteArrayOp DoubleRep    ls rs
 300 primCode ls IndexByteArrayOp_StablePtr rs = primCode_ReadByteArrayOp StablePtrRep ls rs
 301 primCode ls IndexByteArrayOp_Int8      rs = primCode_ReadByteArrayOp Int8Rep      ls rs
 302 primCode ls IndexByteArrayOp_Int16     rs = primCode_ReadByteArrayOp Int16Rep     ls rs
 303 primCode ls IndexByteArrayOp_Int32     rs = primCode_ReadByteArrayOp Int32Rep     ls rs
 304 primCode ls IndexByteArrayOp_Int64     rs = primCode_ReadByteArrayOp Int64Rep     ls rs
 305 primCode ls IndexByteArrayOp_Word8     rs = primCode_ReadByteArrayOp Word8Rep     ls rs
 306 primCode ls IndexByteArrayOp_Word16    rs = primCode_ReadByteArrayOp Word16Rep    ls rs
 307 primCode ls IndexByteArrayOp_Word32    rs = primCode_ReadByteArrayOp Word32Rep    ls rs
 308 primCode ls IndexByteArrayOp_Word64    rs = primCode_ReadByteArrayOp Word64Rep    ls rs
 309
 310 primCode ls ReadByteArrayOp_Char      rs = primCode_ReadByteArrayOp Word8Rep     ls rs
 311 primCode ls ReadByteArrayOp_WideChar  rs = primCode_ReadByteArrayOp CharRep      ls rs
 312 primCode ls ReadByteArrayOp_Int       rs = primCode_ReadByteArrayOp IntRep       ls rs
 313 primCode ls ReadByteArrayOp_Word      rs = primCode_ReadByteArrayOp WordRep      ls rs
 314 primCode ls ReadByteArrayOp_Addr      rs = primCode_ReadByteArrayOp AddrRep      ls rs
 315 primCode ls ReadByteArrayOp_Float     rs = primCode_ReadByteArrayOp FloatRep     ls rs
 316 primCode ls ReadByteArrayOp_Double    rs = primCode_ReadByteArrayOp DoubleRep    ls rs
 317 primCode ls ReadByteArrayOp_StablePtr rs = primCode_ReadByteArrayOp StablePtrRep ls rs
 318 primCode ls ReadByteArrayOp_Int8      rs = primCode_ReadByteArrayOp Int8Rep      ls rs
 319 primCode ls ReadByteArrayOp_Int16     rs = primCode_ReadByteArrayOp Int16Rep     ls rs
 320 primCode ls ReadByteArrayOp_Int32     rs = primCode_ReadByteArrayOp Int32Rep     ls rs
 321 primCode ls ReadByteArrayOp_Int64     rs = primCode_ReadByteArrayOp Int64Rep     ls rs
 322 primCode ls ReadByteArrayOp_Word8     rs = primCode_ReadByteArrayOp Word8Rep     ls rs
 323 primCode ls ReadByteArrayOp_Word16    rs = primCode_ReadByteArrayOp Word16Rep    ls rs
 324 primCode ls ReadByteArrayOp_Word32    rs = primCode_ReadByteArrayOp Word32Rep    ls rs
 325 primCode ls ReadByteArrayOp_Word64    rs = primCode_ReadByteArrayOp Word64Rep    ls rs
 326
 327 primCode ls WriteByteArrayOp_Char      rs = primCode_WriteByteArrayOp Word8Rep     ls rs
 328 primCode ls WriteByteArrayOp_WideChar  rs = primCode_WriteByteArrayOp CharRep      ls rs
 329 primCode ls WriteByteArrayOp_Int       rs = primCode_WriteByteArrayOp IntRep       ls rs
 330 primCode ls WriteByteArrayOp_Word      rs = primCode_WriteByteArrayOp WordRep      ls rs
 331 primCode ls WriteByteArrayOp_Addr      rs = primCode_WriteByteArrayOp AddrRep      ls rs
 332 primCode ls WriteByteArrayOp_Float     rs = primCode_WriteByteArrayOp FloatRep     ls rs
 333 primCode ls WriteByteArrayOp_Double    rs = primCode_WriteByteArrayOp DoubleRep    ls rs
 334 primCode ls WriteByteArrayOp_StablePtr rs = primCode_WriteByteArrayOp StablePtrRep ls rs
 335 primCode ls WriteByteArrayOp_Int8      rs = primCode_WriteByteArrayOp Int8Rep      ls rs
 336 primCode ls WriteByteArrayOp_Int16     rs = primCode_WriteByteArrayOp Int16Rep     ls rs
 337 primCode ls WriteByteArrayOp_Int32     rs = primCode_WriteByteArrayOp Int32Rep     ls rs
 338 primCode ls WriteByteArrayOp_Int64     rs = primCode_WriteByteArrayOp Int64Rep     ls rs
 339 primCode ls WriteByteArrayOp_Word8     rs = primCode_WriteByteArrayOp Word8Rep     ls rs
 340 primCode ls WriteByteArrayOp_Word16    rs = primCode_WriteByteArrayOp Word16Rep    ls rs
 341 primCode ls WriteByteArrayOp_Word32    rs = primCode_WriteByteArrayOp Word32Rep    ls rs
 342 primCode ls WriteByteArrayOp_Word64    rs = primCode_WriteByteArrayOp Word64Rep    ls rs
 343
 344 primCode ls IndexOffAddrOp_Char      rs = primCode_IndexOffAddrOp Word8Rep     ls rs
 345 primCode ls IndexOffAddrOp_WideChar  rs = primCode_IndexOffAddrOp CharRep      ls rs
 346 primCode ls IndexOffAddrOp_Int       rs = primCode_IndexOffAddrOp IntRep       ls rs
 347 primCode ls IndexOffAddrOp_Word      rs = primCode_IndexOffAddrOp WordRep      ls rs
 348 primCode ls IndexOffAddrOp_Addr      rs = primCode_IndexOffAddrOp AddrRep      ls rs
 349 primCode ls IndexOffAddrOp_Float     rs = primCode_IndexOffAddrOp FloatRep     ls rs
 350 primCode ls IndexOffAddrOp_Double    rs = primCode_IndexOffAddrOp DoubleRep    ls rs
 351 primCode ls IndexOffAddrOp_StablePtr rs = primCode_IndexOffAddrOp StablePtrRep ls rs
 352 primCode ls IndexOffAddrOp_Int8      rs = primCode_IndexOffAddrOp Int8Rep      ls rs
 353 primCode ls IndexOffAddrOp_Int16     rs = primCode_IndexOffAddrOp Int16Rep     ls rs
 354 primCode ls IndexOffAddrOp_Int32     rs = primCode_IndexOffAddrOp Int32Rep     ls rs
 355 primCode ls IndexOffAddrOp_Int64     rs = primCode_IndexOffAddrOp Int64Rep     ls rs
 356 primCode ls IndexOffAddrOp_Word8     rs = primCode_IndexOffAddrOp Word8Rep     ls rs
 357 primCode ls IndexOffAddrOp_Word16    rs = primCode_IndexOffAddrOp Word16Rep    ls rs
 358 primCode ls IndexOffAddrOp_Word32    rs = primCode_IndexOffAddrOp Word32Rep    ls rs
 359 primCode ls IndexOffAddrOp_Word64    rs = primCode_IndexOffAddrOp Word64Rep    ls rs
 360
 361 primCode ls IndexOffForeignObjOp_Char      rs = primCode_IndexOffForeignObjOp Word8Rep     ls rs
 362 primCode ls IndexOffForeignObjOp_WideChar  rs = primCode_IndexOffForeignObjOp CharRep      ls rs
 363 primCode ls IndexOffForeignObjOp_Int       rs = primCode_IndexOffForeignObjOp IntRep       ls rs
 364 primCode ls IndexOffForeignObjOp_Word      rs = primCode_IndexOffForeignObjOp WordRep      ls rs
 365 primCode ls IndexOffForeignObjOp_Addr      rs = primCode_IndexOffForeignObjOp AddrRep      ls rs
 366 primCode ls IndexOffForeignObjOp_Float     rs = primCode_IndexOffForeignObjOp FloatRep     ls rs
 367 primCode ls IndexOffForeignObjOp_Double    rs = primCode_IndexOffForeignObjOp DoubleRep    ls rs
 368 primCode ls IndexOffForeignObjOp_StablePtr rs = primCode_IndexOffForeignObjOp StablePtrRep ls rs
 369 primCode ls IndexOffForeignObjOp_Int8      rs = primCode_IndexOffForeignObjOp Int8Rep      ls rs
 370 primCode ls IndexOffForeignObjOp_Int16     rs = primCode_IndexOffForeignObjOp Int16Rep     ls rs
 371 primCode ls IndexOffForeignObjOp_Int32     rs = primCode_IndexOffForeignObjOp Int32Rep     ls rs
 372 primCode ls IndexOffForeignObjOp_Int64     rs = primCode_IndexOffForeignObjOp Int64Rep     ls rs
 373 primCode ls IndexOffForeignObjOp_Word8     rs = primCode_IndexOffForeignObjOp Word8Rep     ls rs
 374 primCode ls IndexOffForeignObjOp_Word16    rs = primCode_IndexOffForeignObjOp Word16Rep    ls rs
 375 primCode ls IndexOffForeignObjOp_Word32    rs = primCode_IndexOffForeignObjOp Word32Rep    ls rs
 376 primCode ls IndexOffForeignObjOp_Word64    rs = primCode_IndexOffForeignObjOp Word64Rep    ls rs
 377
 378 primCode ls ReadOffAddrOp_Char      rs = primCode_IndexOffAddrOp Word8Rep     ls rs
 379 primCode ls ReadOffAddrOp_WideChar  rs = primCode_IndexOffAddrOp CharRep      ls rs
 380 primCode ls ReadOffAddrOp_Int       rs = primCode_IndexOffAddrOp IntRep       ls rs
 381 primCode ls ReadOffAddrOp_Word      rs = primCode_IndexOffAddrOp WordRep      ls rs
 382 primCode ls ReadOffAddrOp_Addr      rs = primCode_IndexOffAddrOp AddrRep      ls rs
 383 primCode ls ReadOffAddrOp_Float     rs = primCode_IndexOffAddrOp FloatRep     ls rs
 384 primCode ls ReadOffAddrOp_Double    rs = primCode_IndexOffAddrOp DoubleRep    ls rs
 385 primCode ls ReadOffAddrOp_StablePtr rs = primCode_IndexOffAddrOp StablePtrRep ls rs
 386 primCode ls ReadOffAddrOp_Int8      rs = primCode_IndexOffAddrOp Int8Rep      ls rs
 387 primCode ls ReadOffAddrOp_Int16     rs = primCode_IndexOffAddrOp Int16Rep     ls rs
 388 primCode ls ReadOffAddrOp_Int32     rs = primCode_IndexOffAddrOp Int32Rep     ls rs
 389 primCode ls ReadOffAddrOp_Int64     rs = primCode_IndexOffAddrOp Int64Rep     ls rs
 390 primCode ls ReadOffAddrOp_Word8     rs = primCode_IndexOffAddrOp Word8Rep     ls rs
 391 primCode ls ReadOffAddrOp_Word16    rs = primCode_IndexOffAddrOp Word16Rep    ls rs
 392 primCode ls ReadOffAddrOp_Word32    rs = primCode_IndexOffAddrOp Word32Rep    ls rs
 393 primCode ls ReadOffAddrOp_Word64    rs = primCode_IndexOffAddrOp Word64Rep    ls rs
 394
 395 primCode ls WriteOffAddrOp_Char      rs = primCode_WriteOffAddrOp Word8Rep     ls rs
 396 primCode ls WriteOffAddrOp_WideChar  rs = primCode_WriteOffAddrOp CharRep      ls rs
 397 primCode ls WriteOffAddrOp_Int       rs = primCode_WriteOffAddrOp IntRep       ls rs
 398 primCode ls WriteOffAddrOp_Word      rs = primCode_WriteOffAddrOp WordRep      ls rs
 399 primCode ls WriteOffAddrOp_Addr      rs = primCode_WriteOffAddrOp AddrRep      ls rs
 400 primCode ls WriteOffAddrOp_Float     rs = primCode_WriteOffAddrOp FloatRep     ls rs
 401 primCode ls WriteOffAddrOp_Double    rs = primCode_WriteOffAddrOp DoubleRep    ls rs
 402 primCode ls WriteOffAddrOp_StablePtr rs = primCode_WriteOffAddrOp StablePtrRep ls rs
 403 primCode ls WriteOffAddrOp_Int8      rs = primCode_WriteOffAddrOp Int8Rep      ls rs
 404 primCode ls WriteOffAddrOp_Int16     rs = primCode_WriteOffAddrOp Int16Rep     ls rs
 405 primCode ls WriteOffAddrOp_Int32     rs = primCode_WriteOffAddrOp Int32Rep     ls rs
 406 primCode ls WriteOffAddrOp_Int64     rs = primCode_WriteOffAddrOp Int64Rep     ls rs
 407 primCode ls WriteOffAddrOp_Word8     rs = primCode_WriteOffAddrOp Word8Rep     ls rs
 408 primCode ls WriteOffAddrOp_Word16    rs = primCode_WriteOffAddrOp Word16Rep    ls rs
 409 primCode ls WriteOffAddrOp_Word32    rs = primCode_WriteOffAddrOp Word32Rep    ls rs
 410 primCode ls WriteOffAddrOp_Word64    rs = primCode_WriteOffAddrOp Word64Rep    ls rs
 411
 412 \end{code}
 413
 414
 415 DataToTagOp won't work for 64-bit archs, as it is.
 416
 417 \begin{code}
 418 primCode [lhs] DataToTagOp [arg]
 419   = let lhs'        = amodeToStix lhs
 420         arg'        = amodeToStix arg
 421         infoptr     = StInd PtrRep arg'
 422         word_32     = StInd WordRep (StIndex PtrRep infoptr (StInt (-1)))
 423         masked_le32 = StPrim SrlOp [word_32, StInt 16]
 424         masked_be32 = StPrim AndOp [word_32, StInt 65535]
 425 #ifdef WORDS_BIGENDIAN
 426         masked      = masked_be32
 427 #else
 428         masked      = masked_le32
 429 #endif
 430         assign      = StAssign IntRep lhs' masked
 431     in
 432     returnUs (\xs -> assign : xs)
 433 \end{code}
 434
 435 MutVars are pretty simple.
 436 #define writeMutVarzh(a,v)       (P_)(((StgMutVar *)(a))->var)=(v)
 437
 438 \begin{code}
 439 primCode [] WriteMutVarOp [aa,vv]
 440    = let aa_s      = amodeToStix aa
 441          vv_s      = amodeToStix vv
 442          var_field = StIndex PtrRep aa_s fixedHS
 443          assign    = StAssign PtrRep (StInd PtrRep var_field) vv_s
 444      in
 445      returnUs (\xs -> assign : xs)
 446
 447 primCode [rr] ReadMutVarOp [aa]
 448    = let aa_s      = amodeToStix aa
 449          rr_s      = amodeToStix rr
 450          var_field = StIndex PtrRep aa_s fixedHS
 451          assign    = StAssign PtrRep rr_s (StInd PtrRep var_field)
 452      in
 453      returnUs (\xs -> assign : xs)
 454 \end{code}
 455
 456 ForeignObj# primops.
 457
 458 \begin{code}
 459 primCode [rr] ForeignObjToAddrOp [fo]
 460   = let code =  StAssign AddrRep (amodeToStix rr)
 461                    (StInd AddrRep
 462                         (StIndex PtrRep (amodeToStix fo) fixedHS))
 463     in
 464     returnUs (\xs -> code : xs)
 465
 466 primCode [] TouchOp [_] = returnUs id
 467 \end{code}
 468
 469 Now the more mundane operations.
 470
 471 \begin{code}
 472 primCode lhs op rhs
 473   = let
 474         lhs' = map amodeToStix  lhs
 475         rhs' = map amodeToStix' rhs
 476         pk   = getAmodeRep (head lhs)
 477     in
 478     returnUs (\ xs -> simplePrim pk lhs' op rhs' : xs)
 479 \end{code}
 480
 481 Helper fns for some array ops.
 482
 483 \begin{code}
 484 primCode_ReadByteArrayOp pk [lhs] [obj, ix]
 485   = let
 486         lhs' = amodeToStix lhs
 487         obj' = amodeToStix obj
 488         ix' = amodeToStix ix
 489         base = StIndex IntRep obj' arrWordsHS
 490         assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
 491     in
 492     returnUs (\xs -> assign : xs)
 493
 494
 495 primCode_IndexOffAddrOp pk [lhs] [obj, ix]
 496   = let
 497         lhs' = amodeToStix lhs
 498         obj' = amodeToStix obj
 499         ix' = amodeToStix ix
 500         assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
 501     in
 502     returnUs (\xs -> assign : xs)
 503
 504
 505 primCode_IndexOffForeignObjOp pk [lhs] [obj, ix]
 506   = let
 507         lhs' = amodeToStix lhs
 508         obj' = amodeToStix obj
 509         ix' = amodeToStix ix
 510         obj'' = StIndex AddrRep obj' fixedHS
 511         assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix'))
 512     in
 513     returnUs (\xs -> assign : xs)
 514
 515
 516 primCode_WriteOffAddrOp pk [] [obj, ix, v]
 517   = let
 518         obj' = amodeToStix obj
 519         ix' = amodeToStix ix
 520         v' = amodeToStix v
 521         assign = StAssign pk (StInd pk (StIndex pk obj' ix')) v'
 522     in
 523     returnUs (\xs -> assign : xs)
 524
 525
 526 primCode_WriteByteArrayOp pk [] [obj, ix, v]
 527   = let
 528         obj' = amodeToStix obj
 529         ix' = amodeToStix ix
 530         v' = amodeToStix v
 531         base = StIndex IntRep obj' arrWordsHS
 532         assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
 533     in
 534     returnUs (\xs -> assign : xs)
 535
 536 \end{code}
 537
 538 \begin{code}
 539 simpleCoercion
 540       :: PrimRep
 541       -> CAddrMode
 542       -> CAddrMode
 543       -> UniqSM StixTreeList
 544
 545 simpleCoercion pk lhs rhs
 546   = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
 547
 548
 549 -- Rewrite a narrowing coercion into a pair of shifts.
 550 narrowingCoercion
 551       :: PrimRep   -> PrimRep
 552       -> CAddrMode -> CAddrMode
 553       -> UniqSM StixTreeList
 554
 555 narrowingCoercion pks pkd dst src
 556   | szd > szs
 557   = panic "StixPrim.narrowingCoercion"
 558   | szd == szs
 559   = returnUs (\xs -> StAssign pkd dst' src' : xs)
 560   | otherwise
 561   = returnUs (\xs -> assign : xs)
 562     where
 563           szs       = getPrimRepSizeInBytes pks
 564           szd       = getPrimRepSizeInBytes pkd
 565           src'      = amodeToStix src
 566           dst'      = amodeToStix dst
 567           shift_amt = fromIntegral (8 * (szs - szd))
 568
 569           assign
 570              = StAssign pkd dst'
 571                   (StPrim (if signed then ISraOp else SrlOp)
 572                      [StPrim SllOp [src', StInt shift_amt],
 573                       StInt shift_amt])
 574           signed
 575              = case pkd of
 576                   Int8Rep -> True; Int16Rep -> True
 577                   Int32Rep -> True; Int64Rep -> True; IntRep -> True
 578                   Word8Rep -> False; Word16Rep -> False
 579                   Word32Rep -> False; Word64Rep -> False; WordRep -> False
 580                   other -> pprPanic "StixPrim.narrowingCoercion" (ppr pkd)
 581 \end{code}
 582
 583 Here we try to rewrite primitives into a form the code generator can
 584 understand.  Any primitives not handled here must be handled at the
 585 level of the specific code generator.
 586
 587 \begin{code}
 588 simplePrim
 589     :: PrimRep          -- Rep of first destination
 590     -> [StixTree]       -- Destinations
 591     -> PrimOp
 592     -> [StixTree]
 593     -> StixTree
 594 \end{code}
 595
 596 Now look for something more conventional.
 597
 598 \begin{code}
 599 simplePrim pk [lhs] op rest  = StAssign pk lhs (StPrim op rest)
 600 simplePrim pk as    op bs    = ncgPrimopMoan "simplPrim(all targets)" (ppr op)
 601 \end{code}
 602
 603 %---------------------------------------------------------------------
 604
 605 Here we generate the Stix code for CAddrModes.
 606
 607 When a character is fetched from a mixed type location, we have to do
 608 an extra cast.  This is reflected in amodeCode', which is for rhs
 609 amodes that might possibly need the extra cast.
 610
 611 \begin{code}
 612 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
 613
 614 amodeToStix'{-'-} am@(CVal rr CharRep)
 615     | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
 616     | otherwise = amodeToStix am
 617
 618 amodeToStix' am = amodeToStix am
 619
 620 -----------
 621 amodeToStix am@(CVal rr CharRep)
 622   | mixedTypeLocn am
 623   = StInd IntRep (amodeToStix (CAddr rr))
 624
 625 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
 626
 627 amodeToStix (CAddr (SpRel off))
 628   = StIndex PtrRep stgSp (StInt (toInteger (iBox off)))
 629
 630 amodeToStix (CAddr (HpRel off))
 631   = StIndex IntRep stgHp (StInt (toInteger (- (iBox off))))
 632
 633 amodeToStix (CAddr (NodeRel off))
 634   = StIndex IntRep stgNode (StInt (toInteger (iBox off)))
 635
 636 amodeToStix (CAddr (CIndex base off pk))
 637   = StIndex pk (amodeToStix base) (amodeToStix off)
 638
 639 amodeToStix (CReg magic)    = StReg (StixMagicId magic)
 640 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
 641
 642 amodeToStix (CLbl      lbl _) = StCLbl lbl
 643
 644  -- For CharLike and IntLike, we attempt some trivial constant-folding here.
 645
 646 amodeToStix (CCharLike (CLit (MachChar c)))
 647   = StIndex Word8Rep cHARLIKE_closure (StInt (toInteger off))
 648   where
 649     off = charLikeSize * (c - mIN_CHARLIKE)
 650
 651 amodeToStix (CCharLike x)
 652   = panic "CCharLike"
 653
 654 amodeToStix (CIntLike (CLit (MachInt i)))
 655   = StIndex Word8Rep iNTLIKE_closure (StInt (toInteger off))
 656   where
 657     off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
 658
 659 amodeToStix (CIntLike x)
 660   = panic "CIntLike"
 661
 662 amodeToStix (CLit core)
 663   = case core of
 664       MachChar c     -> StInt (toInteger c)
 665       MachStr s      -> StString s
 666       MachAddr a     -> StInt a
 667       MachInt i      -> StInt i
 668       MachWord w     -> case word2IntLit core of MachInt iw -> StInt iw
 669       MachLitLit s _ -> litLitErr
 670       MachLabel l    -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-})
 671       MachFloat d    -> StFloat d
 672       MachDouble d   -> StDouble d
 673       _ -> panic "amodeToStix:core literal"
 674
 675 amodeToStix (CMacroExpr _ macro [arg])
 676   = case macro of
 677       ENTRY_CODE -> amodeToStix arg
 678       ARG_TAG    -> amodeToStix arg -- just an integer no. of words
 679       GET_TAG    ->
 680 #ifdef WORDS_BIGENDIAN
 681                     StPrim AndOp
 682                         [StInd WordRep (StIndex PtrRep (amodeToStix arg)
 683                                                 (StInt (toInteger (-1)))),
 684                          StInt 65535]
 685 #else
 686                     StPrim SrlOp
 687                         [StInd WordRep (StIndex PtrRep (amodeToStix arg)
 688                                                 (StInt (toInteger (-1)))),
 689                          StInt 16]
 690 #endif
 691       UPD_FRAME_UPDATEE
 692          -> StInd PtrRep (StIndex PtrRep (amodeToStix arg)
 693                                          (StInt (toInteger uF_UPDATEE)))
 694
 695 litLitErr =
 696   panic "native code generator can't compile lit-lits, use -fvia-C"
 697 \end{code}
 698
 699 Sizes of the CharLike and IntLike closures that are arranged as arrays
 700 in the data segment.  (These are in bytes.)
 701
 702 \begin{code}
 703 -- The INTLIKE base pointer
 704
 705 iNTLIKE_closure :: StixTree
 706 iNTLIKE_closure = StCLbl mkIntlikeClosureLabel
 707
 708 -- The CHARLIKE base
 709
 710 cHARLIKE_closure :: StixTree
 711 cHARLIKE_closure = StCLbl mkCharlikeClosureLabel
 712
 713 mutArrPtrsFrozen_info = StCLbl mkMAP_FROZEN_infoLabel
 714
 715 -- these are the sizes of charLike and intLike closures, in _bytes_.
 716 charLikeSize = (fixedHdrSize + 1) * (sizeOf PtrRep)
 717 intLikeSize  = (fixedHdrSize + 1) * (sizeOf PtrRep)
 718 \end{code}
 719
 720
 721 \begin{code}
 722 save_thread_state
 723    = getUniqueUs   `thenUs` \tso_uq ->
 724      let tso = StReg (StixTemp tso_uq ThreadIdRep) in
 725      returnUs (\xs ->
 726         StAssign ThreadIdRep tso stgCurrentTSO :
 727         StAssign PtrRep
 728            (StInd PtrRep (StPrim IntAddOp
 729                 [tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]))
 730            stgSp :
 731         StAssign PtrRep
 732            (StInd PtrRep (StPrim IntAddOp
 733                 [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))]))
 734            stgSu :
 735         StAssign PtrRep
 736            (StInd PtrRep (StPrim IntAddOp
 737                 [stgCurrentNursery,
 738                  StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]))
 739            (StPrim IntAddOp [stgHp, StInt (toInteger (1 * BYTES_PER_WORD))]) :
 740         xs
 741      )
 742
 743 load_thread_state
 744    = getUniqueUs   `thenUs` \tso_uq ->
 745      let tso = StReg (StixTemp tso_uq ThreadIdRep) in
 746      returnUs (\xs ->
 747         StAssign ThreadIdRep tso stgCurrentTSO :
 748         StAssign PtrRep stgSp
 749            (StInd PtrRep (StPrim IntAddOp
 750                 [tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])) :
 751         StAssign PtrRep stgSu
 752            (StInd PtrRep (StPrim IntAddOp
 753                 [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))])) :
 754         StAssign PtrRep stgSpLim
 755            (StPrim IntAddOp [tso,
 756                              StInt (toInteger ((TSO_STACK + rESERVED_STACK_WORDS)
 757                                                *BYTES_PER_WORD))]) :
 758         StAssign PtrRep stgHp
 759            (StPrim IntSubOp [
 760               StInd PtrRep (StPrim IntAddOp
 761                 [stgCurrentNursery,
 762                  StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]),
 763               StInt (toInteger (1 * BYTES_PER_WORD))
 764             ]) :
 765         StAssign PtrRep stgHpLim
 766            (StPrim IntAddOp [
 767               StInd PtrRep (StPrim IntAddOp
 768                 [stgCurrentNursery,
 769                  StInt (toInteger (BDESCR_START * BYTES_PER_WORD))]),
 770               StInt (toInteger (bLOCK_SIZE - (1 * BYTES_PER_WORD)))
 771             ]) :
 772         xs
 773      )
 774 \end{code}