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