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   = ncgPrimopMoan "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] AddrToHValueOp [arg]
 151   = simpleCoercion PtrRep res arg
 152
 153 #if (WORD_SIZE_IN_BITS == 32 || WORD_SIZE_IN_BITS == 64)
 154 primCode [res] Int2AddrOp [arg]
 155   = simpleCoercion AddrRep res arg
 156
 157 primCode [res] Addr2IntOp [arg]
 158   = simpleCoercion IntRep res arg
 159 #endif
 160
 161 primCode [res] Narrow8IntOp [arg]
 162   = narrowingCoercion IntRep Int8Rep res arg
 163 primCode [res] Narrow16IntOp [arg]
 164   = narrowingCoercion IntRep Int16Rep res arg
 165 primCode [res] Narrow32IntOp [arg]
 166   = narrowingCoercion IntRep Int32Rep res arg
 167
 168 primCode [res] Narrow8WordOp [arg]
 169   = narrowingCoercion WordRep Word8Rep res arg
 170 primCode [res] Narrow16WordOp [arg]
 171   = narrowingCoercion WordRep Word16Rep res arg
 172 primCode [res] Narrow32WordOp [arg]
 173   = narrowingCoercion WordRep Word32Rep res arg
 174 \end{code}
 175
 176 \begin{code}
 177 primCode [res] SameMutableArrayOp args
 178   = let
 179         compare = StPrim AddrEqOp (map amodeToStix args)
 180         assign = StAssign IntRep (amodeToStix res) compare
 181     in
 182     returnUs (\xs -> assign : xs)
 183
 184 primCode res@[_] SameMutableByteArrayOp args
 185   = primCode res SameMutableArrayOp args
 186
 187 primCode res@[_] SameMutVarOp args
 188   = primCode res SameMutableArrayOp args
 189 \end{code}
 190
 191 \begin{code}
 192 primCode res@[_] SameMVarOp args
 193   = primCode res SameMutableArrayOp args
 194
 195 -- #define isEmptyMVarzh(r,a) \
 196 --     r =(I_)((GET_INFO((StgMVar*)(a))) == &stg_EMPTY_MVAR_info )
 197 primCode [res] IsEmptyMVarOp [arg]
 198    = let res'     = amodeToStix res
 199          arg'     = amodeToStix arg
 200          arg_info = StInd PtrRep arg'
 201          em_info  = StCLbl mkEMPTY_MVAR_infoLabel
 202          same     = StPrim IntEqOp [arg_info, em_info]
 203          assign   = StAssign IntRep res' same
 204      in
 205      returnUs (\xs -> assign : xs)
 206
 207 -- #define myThreadIdzh(t) (t = CurrentTSO)
 208 primCode [res] MyThreadIdOp []
 209    = let res' = amodeToStix res
 210      in  returnUs (\xs -> StAssign ThreadIdRep res' stgCurrentTSO : xs)
 211
 212 \end{code}
 213
 214 Freezing an array of pointers is a double assignment.  We fix the
 215 header of the ``new'' closure because the lhs is probably a better
 216 addressing mode for the indirection (most likely, it's a VanillaReg).
 217
 218 \begin{code}
 219
 220 primCode [lhs] UnsafeFreezeArrayOp [rhs]
 221   = let
 222         lhs' = amodeToStix lhs
 223         rhs' = amodeToStix rhs
 224         header = StInd PtrRep lhs'
 225         assign = StAssign PtrRep lhs' rhs'
 226         freeze = StAssign PtrRep header mutArrPtrsFrozen_info
 227     in
 228     returnUs (\xs -> assign : freeze : xs)
 229
 230 primCode [lhs] UnsafeFreezeByteArrayOp [rhs]
 231   = simpleCoercion PtrRep lhs rhs
 232 \end{code}
 233
 234 Returning the size of (mutable) byte arrays is just
 235 an indexing operation.
 236
 237 \begin{code}
 238 primCode [lhs] SizeofByteArrayOp [rhs]
 239   = let
 240         lhs' = amodeToStix lhs
 241         rhs' = amodeToStix rhs
 242         sz   = StIndex IntRep rhs' fixedHS
 243         assign = StAssign IntRep lhs' (StInd IntRep sz)
 244     in
 245     returnUs (\xs -> assign : xs)
 246
 247 primCode [lhs] SizeofMutableByteArrayOp [rhs]
 248   = let
 249         lhs' = amodeToStix lhs
 250         rhs' = amodeToStix rhs
 251         sz   = StIndex IntRep rhs' fixedHS
 252         assign = StAssign IntRep lhs' (StInd IntRep sz)
 253     in
 254     returnUs (\xs -> assign : xs)
 255
 256 \end{code}
 257
 258 Most other array primitives translate to simple indexing.
 259
 260 \begin{code}
 261 primCode lhs@[_] IndexArrayOp args
 262   = primCode lhs ReadArrayOp args
 263
 264 primCode [lhs] ReadArrayOp [obj, ix]
 265   = let
 266         lhs' = amodeToStix lhs
 267         obj' = amodeToStix obj
 268         ix' = amodeToStix ix
 269         base = StIndex IntRep obj' arrPtrsHS
 270         assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
 271     in
 272     returnUs (\xs -> assign : xs)
 273
 274 primCode [] WriteArrayOp [obj, ix, v]
 275   = let
 276         obj' = amodeToStix obj
 277         ix' = amodeToStix ix
 278         v' = amodeToStix v
 279         base = StIndex IntRep obj' arrPtrsHS
 280         assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
 281     in
 282     returnUs (\xs -> assign : xs)
 283
 284 primCode [] WriteForeignObjOp [obj, v]
 285   = let
 286         obj' = amodeToStix obj
 287         v' = amodeToStix v
 288         obj'' = StIndex AddrRep obj' (StInt 4711) -- fixedHS
 289         assign = StAssign AddrRep (StInd AddrRep obj'') v'
 290     in
 291     returnUs (\xs -> assign : xs)
 292
 293 -- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
 294 primCode ls IndexByteArrayOp_Char      rs = primCode_ReadByteArrayOp Word8Rep     ls rs
 295 primCode ls IndexByteArrayOp_WideChar  rs = primCode_ReadByteArrayOp CharRep      ls rs
 296 primCode ls IndexByteArrayOp_Int       rs = primCode_ReadByteArrayOp IntRep       ls rs
 297 primCode ls IndexByteArrayOp_Word      rs = primCode_ReadByteArrayOp WordRep      ls rs
 298 primCode ls IndexByteArrayOp_Addr      rs = primCode_ReadByteArrayOp AddrRep      ls rs
 299 primCode ls IndexByteArrayOp_Float     rs = primCode_ReadByteArrayOp FloatRep     ls rs
 300 primCode ls IndexByteArrayOp_Double    rs = primCode_ReadByteArrayOp DoubleRep    ls rs
 301 primCode ls IndexByteArrayOp_StablePtr rs = primCode_ReadByteArrayOp StablePtrRep ls rs
 302 primCode ls IndexByteArrayOp_Int8      rs = primCode_ReadByteArrayOp Int8Rep      ls rs
 303 primCode ls IndexByteArrayOp_Int16     rs = primCode_ReadByteArrayOp Int16Rep     ls rs
 304 primCode ls IndexByteArrayOp_Int32     rs = primCode_ReadByteArrayOp Int32Rep     ls rs
 305 primCode ls IndexByteArrayOp_Int64     rs = primCode_ReadByteArrayOp Int64Rep     ls rs
 306 primCode ls IndexByteArrayOp_Word8     rs = primCode_ReadByteArrayOp Word8Rep     ls rs
 307 primCode ls IndexByteArrayOp_Word16    rs = primCode_ReadByteArrayOp Word16Rep    ls rs
 308 primCode ls IndexByteArrayOp_Word32    rs = primCode_ReadByteArrayOp Word32Rep    ls rs
 309 primCode ls IndexByteArrayOp_Word64    rs = primCode_ReadByteArrayOp Word64Rep    ls rs
 310
 311 primCode ls ReadByteArrayOp_Char      rs = primCode_ReadByteArrayOp Word8Rep     ls rs
 312 primCode ls ReadByteArrayOp_WideChar  rs = primCode_ReadByteArrayOp CharRep      ls rs
 313 primCode ls ReadByteArrayOp_Int       rs = primCode_ReadByteArrayOp IntRep       ls rs
 314 primCode ls ReadByteArrayOp_Word      rs = primCode_ReadByteArrayOp WordRep      ls rs
 315 primCode ls ReadByteArrayOp_Addr      rs = primCode_ReadByteArrayOp AddrRep      ls rs
 316 primCode ls ReadByteArrayOp_Float     rs = primCode_ReadByteArrayOp FloatRep     ls rs
 317 primCode ls ReadByteArrayOp_Double    rs = primCode_ReadByteArrayOp DoubleRep    ls rs
 318 primCode ls ReadByteArrayOp_StablePtr rs = primCode_ReadByteArrayOp StablePtrRep ls rs
 319 primCode ls ReadByteArrayOp_Int8      rs = primCode_ReadByteArrayOp Int8Rep      ls rs
 320 primCode ls ReadByteArrayOp_Int16     rs = primCode_ReadByteArrayOp Int16Rep     ls rs
 321 primCode ls ReadByteArrayOp_Int32     rs = primCode_ReadByteArrayOp Int32Rep     ls rs
 322 primCode ls ReadByteArrayOp_Int64     rs = primCode_ReadByteArrayOp Int64Rep     ls rs
 323 primCode ls ReadByteArrayOp_Word8     rs = primCode_ReadByteArrayOp Word8Rep     ls rs
 324 primCode ls ReadByteArrayOp_Word16    rs = primCode_ReadByteArrayOp Word16Rep    ls rs
 325 primCode ls ReadByteArrayOp_Word32    rs = primCode_ReadByteArrayOp Word32Rep    ls rs
 326 primCode ls ReadByteArrayOp_Word64    rs = primCode_ReadByteArrayOp Word64Rep    ls rs
 327
 328 primCode ls WriteByteArrayOp_Char      rs = primCode_WriteByteArrayOp Word8Rep     ls rs
 329 primCode ls WriteByteArrayOp_WideChar  rs = primCode_WriteByteArrayOp CharRep      ls rs
 330 primCode ls WriteByteArrayOp_Int       rs = primCode_WriteByteArrayOp IntRep       ls rs
 331 primCode ls WriteByteArrayOp_Word      rs = primCode_WriteByteArrayOp WordRep      ls rs
 332 primCode ls WriteByteArrayOp_Addr      rs = primCode_WriteByteArrayOp AddrRep      ls rs
 333 primCode ls WriteByteArrayOp_Float     rs = primCode_WriteByteArrayOp FloatRep     ls rs
 334 primCode ls WriteByteArrayOp_Double    rs = primCode_WriteByteArrayOp DoubleRep    ls rs
 335 primCode ls WriteByteArrayOp_StablePtr rs = primCode_WriteByteArrayOp StablePtrRep ls rs
 336 primCode ls WriteByteArrayOp_Int8      rs = primCode_WriteByteArrayOp Int8Rep      ls rs
 337 primCode ls WriteByteArrayOp_Int16     rs = primCode_WriteByteArrayOp Int16Rep     ls rs
 338 primCode ls WriteByteArrayOp_Int32     rs = primCode_WriteByteArrayOp Int32Rep     ls rs
 339 primCode ls WriteByteArrayOp_Int64     rs = primCode_WriteByteArrayOp Int64Rep     ls rs
 340 primCode ls WriteByteArrayOp_Word8     rs = primCode_WriteByteArrayOp Word8Rep     ls rs
 341 primCode ls WriteByteArrayOp_Word16    rs = primCode_WriteByteArrayOp Word16Rep    ls rs
 342 primCode ls WriteByteArrayOp_Word32    rs = primCode_WriteByteArrayOp Word32Rep    ls rs
 343 primCode ls WriteByteArrayOp_Word64    rs = primCode_WriteByteArrayOp Word64Rep    ls rs
 344
 345 primCode ls IndexOffAddrOp_Char      rs = primCode_IndexOffAddrOp Word8Rep     ls rs
 346 primCode ls IndexOffAddrOp_WideChar  rs = primCode_IndexOffAddrOp CharRep      ls rs
 347 primCode ls IndexOffAddrOp_Int       rs = primCode_IndexOffAddrOp IntRep       ls rs
 348 primCode ls IndexOffAddrOp_Word      rs = primCode_IndexOffAddrOp WordRep      ls rs
 349 primCode ls IndexOffAddrOp_Addr      rs = primCode_IndexOffAddrOp AddrRep      ls rs
 350 primCode ls IndexOffAddrOp_Float     rs = primCode_IndexOffAddrOp FloatRep     ls rs
 351 primCode ls IndexOffAddrOp_Double    rs = primCode_IndexOffAddrOp DoubleRep    ls rs
 352 primCode ls IndexOffAddrOp_StablePtr rs = primCode_IndexOffAddrOp StablePtrRep ls rs
 353 primCode ls IndexOffAddrOp_Int8      rs = primCode_IndexOffAddrOp Int8Rep      ls rs
 354 primCode ls IndexOffAddrOp_Int16     rs = primCode_IndexOffAddrOp Int16Rep     ls rs
 355 primCode ls IndexOffAddrOp_Int32     rs = primCode_IndexOffAddrOp Int32Rep     ls rs
 356 primCode ls IndexOffAddrOp_Int64     rs = primCode_IndexOffAddrOp Int64Rep     ls rs
 357 primCode ls IndexOffAddrOp_Word8     rs = primCode_IndexOffAddrOp Word8Rep     ls rs
 358 primCode ls IndexOffAddrOp_Word16    rs = primCode_IndexOffAddrOp Word16Rep    ls rs
 359 primCode ls IndexOffAddrOp_Word32    rs = primCode_IndexOffAddrOp Word32Rep    ls rs
 360 primCode ls IndexOffAddrOp_Word64    rs = primCode_IndexOffAddrOp Word64Rep    ls rs
 361
 362 primCode ls IndexOffForeignObjOp_Char      rs = primCode_IndexOffForeignObjOp Word8Rep     ls rs
 363 primCode ls IndexOffForeignObjOp_WideChar  rs = primCode_IndexOffForeignObjOp CharRep      ls rs
 364 primCode ls IndexOffForeignObjOp_Int       rs = primCode_IndexOffForeignObjOp IntRep       ls rs
 365 primCode ls IndexOffForeignObjOp_Word      rs = primCode_IndexOffForeignObjOp WordRep      ls rs
 366 primCode ls IndexOffForeignObjOp_Addr      rs = primCode_IndexOffForeignObjOp AddrRep      ls rs
 367 primCode ls IndexOffForeignObjOp_Float     rs = primCode_IndexOffForeignObjOp FloatRep     ls rs
 368 primCode ls IndexOffForeignObjOp_Double    rs = primCode_IndexOffForeignObjOp DoubleRep    ls rs
 369 primCode ls IndexOffForeignObjOp_StablePtr rs = primCode_IndexOffForeignObjOp StablePtrRep ls rs
 370 primCode ls IndexOffForeignObjOp_Int8      rs = primCode_IndexOffForeignObjOp Int8Rep      ls rs
 371 primCode ls IndexOffForeignObjOp_Int16     rs = primCode_IndexOffForeignObjOp Int16Rep     ls rs
 372 primCode ls IndexOffForeignObjOp_Int32     rs = primCode_IndexOffForeignObjOp Int32Rep     ls rs
 373 primCode ls IndexOffForeignObjOp_Int64     rs = primCode_IndexOffForeignObjOp Int64Rep     ls rs
 374 primCode ls IndexOffForeignObjOp_Word8     rs = primCode_IndexOffForeignObjOp Word8Rep     ls rs
 375 primCode ls IndexOffForeignObjOp_Word16    rs = primCode_IndexOffForeignObjOp Word16Rep    ls rs
 376 primCode ls IndexOffForeignObjOp_Word32    rs = primCode_IndexOffForeignObjOp Word32Rep    ls rs
 377 primCode ls IndexOffForeignObjOp_Word64    rs = primCode_IndexOffForeignObjOp Word64Rep    ls rs
 378
 379 primCode ls ReadOffAddrOp_Char      rs = primCode_IndexOffAddrOp Word8Rep     ls rs
 380 primCode ls ReadOffAddrOp_WideChar  rs = primCode_IndexOffAddrOp CharRep      ls rs
 381 primCode ls ReadOffAddrOp_Int       rs = primCode_IndexOffAddrOp IntRep       ls rs
 382 primCode ls ReadOffAddrOp_Word      rs = primCode_IndexOffAddrOp WordRep      ls rs
 383 primCode ls ReadOffAddrOp_Addr      rs = primCode_IndexOffAddrOp AddrRep      ls rs
 384 primCode ls ReadOffAddrOp_Float     rs = primCode_IndexOffAddrOp FloatRep     ls rs
 385 primCode ls ReadOffAddrOp_Double    rs = primCode_IndexOffAddrOp DoubleRep    ls rs
 386 primCode ls ReadOffAddrOp_StablePtr rs = primCode_IndexOffAddrOp StablePtrRep ls rs
 387 primCode ls ReadOffAddrOp_Int8      rs = primCode_IndexOffAddrOp Int8Rep      ls rs
 388 primCode ls ReadOffAddrOp_Int16     rs = primCode_IndexOffAddrOp Int16Rep     ls rs
 389 primCode ls ReadOffAddrOp_Int32     rs = primCode_IndexOffAddrOp Int32Rep     ls rs
 390 primCode ls ReadOffAddrOp_Int64     rs = primCode_IndexOffAddrOp Int64Rep     ls rs
 391 primCode ls ReadOffAddrOp_Word8     rs = primCode_IndexOffAddrOp Word8Rep     ls rs
 392 primCode ls ReadOffAddrOp_Word16    rs = primCode_IndexOffAddrOp Word16Rep    ls rs
 393 primCode ls ReadOffAddrOp_Word32    rs = primCode_IndexOffAddrOp Word32Rep    ls rs
 394 primCode ls ReadOffAddrOp_Word64    rs = primCode_IndexOffAddrOp Word64Rep    ls rs
 395
 396 primCode ls WriteOffAddrOp_Char      rs = primCode_WriteOffAddrOp Word8Rep     ls rs
 397 primCode ls WriteOffAddrOp_WideChar  rs = primCode_WriteOffAddrOp CharRep      ls rs
 398 primCode ls WriteOffAddrOp_Int       rs = primCode_WriteOffAddrOp IntRep       ls rs
 399 primCode ls WriteOffAddrOp_Word      rs = primCode_WriteOffAddrOp WordRep      ls rs
 400 primCode ls WriteOffAddrOp_Addr      rs = primCode_WriteOffAddrOp AddrRep      ls rs
 401 primCode ls WriteOffAddrOp_Float     rs = primCode_WriteOffAddrOp FloatRep     ls rs
 402 primCode ls WriteOffAddrOp_Double    rs = primCode_WriteOffAddrOp DoubleRep    ls rs
 403 primCode ls WriteOffAddrOp_StablePtr rs = primCode_WriteOffAddrOp StablePtrRep ls rs
 404 primCode ls WriteOffAddrOp_Int8      rs = primCode_WriteOffAddrOp Int8Rep      ls rs
 405 primCode ls WriteOffAddrOp_Int16     rs = primCode_WriteOffAddrOp Int16Rep     ls rs
 406 primCode ls WriteOffAddrOp_Int32     rs = primCode_WriteOffAddrOp Int32Rep     ls rs
 407 primCode ls WriteOffAddrOp_Int64     rs = primCode_WriteOffAddrOp Int64Rep     ls rs
 408 primCode ls WriteOffAddrOp_Word8     rs = primCode_WriteOffAddrOp Word8Rep     ls rs
 409 primCode ls WriteOffAddrOp_Word16    rs = primCode_WriteOffAddrOp Word16Rep    ls rs
 410 primCode ls WriteOffAddrOp_Word32    rs = primCode_WriteOffAddrOp Word32Rep    ls rs
 411 primCode ls WriteOffAddrOp_Word64    rs = primCode_WriteOffAddrOp Word64Rep    ls rs
 412
 413 \end{code}
 414
 415
 416 DataToTagOp won't work for 64-bit archs, as it is.
 417
 418 \begin{code}
 419 primCode [lhs] DataToTagOp [arg]
 420   = let lhs'        = amodeToStix lhs
 421         arg'        = amodeToStix arg
 422         infoptr     = StInd PtrRep arg'
 423         word_32     = StInd WordRep (StIndex PtrRep infoptr (StInt (-1)))
 424         masked_le32 = StPrim SrlOp [word_32, StInt 16]
 425         masked_be32 = StPrim AndOp [word_32, StInt 65535]
 426 #ifdef WORDS_BIGENDIAN
 427         masked      = masked_be32
 428 #else
 429         masked      = masked_le32
 430 #endif
 431         assign      = StAssign IntRep lhs' masked
 432     in
 433     returnUs (\xs -> assign : xs)
 434 \end{code}
 435
 436 MutVars are pretty simple.
 437 #define writeMutVarzh(a,v)       (P_)(((StgMutVar *)(a))->var)=(v)
 438
 439 \begin{code}
 440 primCode [] WriteMutVarOp [aa,vv]
 441    = let aa_s      = amodeToStix aa
 442          vv_s      = amodeToStix vv
 443          var_field = StIndex PtrRep aa_s fixedHS
 444          assign    = StAssign PtrRep (StInd PtrRep var_field) vv_s
 445      in
 446      returnUs (\xs -> assign : xs)
 447
 448 primCode [rr] ReadMutVarOp [aa]
 449    = let aa_s      = amodeToStix aa
 450          rr_s      = amodeToStix rr
 451          var_field = StIndex PtrRep aa_s fixedHS
 452          assign    = StAssign PtrRep rr_s (StInd PtrRep var_field)
 453      in
 454      returnUs (\xs -> assign : xs)
 455 \end{code}
 456
 457 ForeignObj# primops.
 458
 459 \begin{code}
 460 primCode [rr] ForeignObjToAddrOp [fo]
 461   = let code =  StAssign AddrRep (amodeToStix rr)
 462                    (StInd AddrRep
 463                         (StIndex PtrRep (amodeToStix fo) fixedHS))
 464     in
 465     returnUs (\xs -> code : xs)
 466
 467 primCode [] TouchOp [_] = returnUs id
 468 \end{code}
 469
 470 Now the more mundane operations.
 471
 472 \begin{code}
 473 primCode lhs op rhs
 474   = let
 475         lhs' = map amodeToStix  lhs
 476         rhs' = map amodeToStix' rhs
 477         pk   = getAmodeRep (head lhs)
 478     in
 479     returnUs (\ xs -> simplePrim pk lhs' op rhs' : xs)
 480 \end{code}
 481
 482 Helper fns for some array ops.
 483
 484 \begin{code}
 485 primCode_ReadByteArrayOp pk [lhs] [obj, ix]
 486   = let
 487         lhs' = amodeToStix lhs
 488         obj' = amodeToStix obj
 489         ix' = amodeToStix ix
 490         base = StIndex IntRep obj' arrWordsHS
 491         assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
 492     in
 493     returnUs (\xs -> assign : xs)
 494
 495
 496 primCode_IndexOffAddrOp pk [lhs] [obj, ix]
 497   = let
 498         lhs' = amodeToStix lhs
 499         obj' = amodeToStix obj
 500         ix' = amodeToStix ix
 501         assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
 502     in
 503     returnUs (\xs -> assign : xs)
 504
 505
 506 primCode_IndexOffForeignObjOp pk [lhs] [obj, ix]
 507   = let
 508         lhs' = amodeToStix lhs
 509         obj' = amodeToStix obj
 510         ix' = amodeToStix ix
 511         obj'' = StIndex AddrRep obj' fixedHS
 512         assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix'))
 513     in
 514     returnUs (\xs -> assign : xs)
 515
 516
 517 primCode_WriteOffAddrOp pk [] [obj, ix, v]
 518   = let
 519         obj' = amodeToStix obj
 520         ix' = amodeToStix ix
 521         v' = amodeToStix v
 522         assign = StAssign pk (StInd pk (StIndex pk obj' ix')) v'
 523     in
 524     returnUs (\xs -> assign : xs)
 525
 526
 527 primCode_WriteByteArrayOp pk [] [obj, ix, v]
 528   = let
 529         obj' = amodeToStix obj
 530         ix' = amodeToStix ix
 531         v' = amodeToStix v
 532         base = StIndex IntRep obj' arrWordsHS
 533         assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
 534     in
 535     returnUs (\xs -> assign : xs)
 536
 537 \end{code}
 538
 539 \begin{code}
 540 simpleCoercion
 541       :: PrimRep
 542       -> CAddrMode
 543       -> CAddrMode
 544       -> UniqSM StixTreeList
 545
 546 simpleCoercion pk lhs rhs
 547   = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
 548
 549
 550 -- Rewrite a narrowing coercion into a pair of shifts.
 551 narrowingCoercion
 552       :: PrimRep   -> PrimRep
 553       -> CAddrMode -> CAddrMode
 554       -> UniqSM StixTreeList
 555
 556 narrowingCoercion pks pkd dst src
 557   | szd > szs
 558   = panic "StixPrim.narrowingCoercion"
 559   | szd == szs
 560   = returnUs (\xs -> StAssign pkd dst' src' : xs)
 561   | otherwise
 562   = returnUs (\xs -> assign : xs)
 563     where
 564           szs       = getPrimRepSizeInBytes pks
 565           szd       = getPrimRepSizeInBytes pkd
 566           src'      = amodeToStix src
 567           dst'      = amodeToStix dst
 568           shift_amt = fromIntegral (8 * (szs - szd))
 569
 570           assign
 571              = StAssign pkd dst'
 572                   (StPrim (if signed then ISraOp else SrlOp)
 573                      [StPrim SllOp [src', StInt shift_amt],
 574                       StInt shift_amt])
 575           signed
 576              = case pkd of
 577                   Int8Rep -> True; Int16Rep -> True
 578                   Int32Rep -> True; Int64Rep -> True; IntRep -> True
 579                   Word8Rep -> False; Word16Rep -> False
 580                   Word32Rep -> False; Word64Rep -> False; WordRep -> False
 581                   other -> pprPanic "StixPrim.narrowingCoercion" (ppr pkd)
 582 \end{code}
 583
 584 Here we try to rewrite primitives into a form the code generator can
 585 understand.  Any primitives not handled here must be handled at the
 586 level of the specific code generator.
 587
 588 \begin{code}
 589 simplePrim
 590     :: PrimRep          -- Rep of first destination
 591     -> [StixTree]       -- Destinations
 592     -> PrimOp
 593     -> [StixTree]
 594     -> StixTree
 595 \end{code}
 596
 597 Now look for something more conventional.
 598
 599 \begin{code}
 600 simplePrim pk [lhs] op rest  = StAssign pk lhs (StPrim op rest)
 601 simplePrim pk as    op bs    = ncgPrimopMoan "simplPrim(all targets)" (ppr op)
 602 \end{code}
 603
 604 %---------------------------------------------------------------------
 605
 606 Here we generate the Stix code for CAddrModes.
 607
 608 When a character is fetched from a mixed type location, we have to do
 609 an extra cast.  This is reflected in amodeCode', which is for rhs
 610 amodes that might possibly need the extra cast.
 611
 612 \begin{code}
 613 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
 614
 615 amodeToStix'{-'-} am@(CVal rr CharRep)
 616     | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
 617     | otherwise = amodeToStix am
 618
 619 amodeToStix' am = amodeToStix am
 620
 621 -----------
 622 amodeToStix am@(CVal rr CharRep)
 623   | mixedTypeLocn am
 624   = StInd IntRep (amodeToStix (CAddr rr))
 625
 626 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
 627
 628 amodeToStix (CAddr (SpRel off))
 629   = StIndex PtrRep stgSp (StInt (toInteger (iBox off)))
 630
 631 amodeToStix (CAddr (HpRel off))
 632   = StIndex IntRep stgHp (StInt (toInteger (- (iBox off))))
 633
 634 amodeToStix (CAddr (NodeRel off))
 635   = StIndex IntRep stgNode (StInt (toInteger (iBox off)))
 636
 637 amodeToStix (CAddr (CIndex base off pk))
 638   = StIndex pk (amodeToStix base) (amodeToStix off)
 639
 640 amodeToStix (CReg magic)    = StReg (StixMagicId magic)
 641 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
 642
 643 amodeToStix (CLbl      lbl _) = StCLbl lbl
 644
 645  -- For CharLike and IntLike, we attempt some trivial constant-folding here.
 646
 647 amodeToStix (CCharLike (CLit (MachChar c)))
 648   = StIndex Word8Rep cHARLIKE_closure (StInt (toInteger off))
 649   where
 650     off = charLikeSize * (c - mIN_CHARLIKE)
 651
 652 amodeToStix (CCharLike x)
 653   = panic "CCharLike"
 654
 655 amodeToStix (CIntLike (CLit (MachInt i)))
 656   = StIndex Word8Rep iNTLIKE_closure (StInt (toInteger off))
 657   where
 658     off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
 659
 660 amodeToStix (CIntLike x)
 661   = panic "CIntLike"
 662
 663 amodeToStix (CLit core)
 664   = case core of
 665       MachChar c     -> StInt (toInteger c)
 666       MachStr s      -> StString s
 667       MachAddr a     -> StInt a
 668       MachInt i      -> StInt i
 669       MachWord w     -> case word2IntLit core of MachInt iw -> StInt iw
 670       MachLitLit s _ -> litLitErr
 671       MachLabel l    -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-})
 672       MachFloat d    -> StFloat d
 673       MachDouble d   -> StDouble d
 674       _ -> panic "amodeToStix:core literal"
 675
 676 amodeToStix (CMacroExpr _ macro [arg])
 677   = case macro of
 678       ENTRY_CODE -> amodeToStix arg
 679       ARG_TAG    -> amodeToStix arg -- just an integer no. of words
 680       GET_TAG    ->
 681 #ifdef WORDS_BIGENDIAN
 682                     StPrim AndOp
 683                         [StInd WordRep (StIndex PtrRep (amodeToStix arg)
 684                                                 (StInt (toInteger (-1)))),
 685                          StInt 65535]
 686 #else
 687                     StPrim SrlOp
 688                         [StInd WordRep (StIndex PtrRep (amodeToStix arg)
 689                                                 (StInt (toInteger (-1)))),
 690                          StInt 16]
 691 #endif
 692       UPD_FRAME_UPDATEE
 693          -> StInd PtrRep (StIndex PtrRep (amodeToStix arg)
 694                                          (StInt (toInteger uF_UPDATEE)))
 695
 696 litLitErr =
 697   panic "native code generator can't compile lit-lits, use -fvia-C"
 698 \end{code}
 699
 700 Sizes of the CharLike and IntLike closures that are arranged as arrays
 701 in the data segment.  (These are in bytes.)
 702
 703 \begin{code}
 704 -- The INTLIKE base pointer
 705
 706 iNTLIKE_closure :: StixTree
 707 iNTLIKE_closure = StCLbl mkIntlikeClosureLabel
 708
 709 -- The CHARLIKE base
 710
 711 cHARLIKE_closure :: StixTree
 712 cHARLIKE_closure = StCLbl mkCharlikeClosureLabel
 713
 714 mutArrPtrsFrozen_info = StCLbl mkMAP_FROZEN_infoLabel
 715
 716 -- these are the sizes of charLike and intLike closures, in _bytes_.
 717 charLikeSize = (fixedHdrSize + 1) * (sizeOf PtrRep)
 718 intLikeSize  = (fixedHdrSize + 1) * (sizeOf PtrRep)
 719 \end{code}
 720
 721
 722 \begin{code}
 723 save_thread_state
 724    = getUniqueUs   `thenUs` \tso_uq ->
 725      let tso = StReg (StixTemp tso_uq ThreadIdRep) in
 726      returnUs (\xs ->
 727         StAssign ThreadIdRep tso stgCurrentTSO :
 728         StAssign PtrRep
 729            (StInd PtrRep (StPrim IntAddOp
 730                 [tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]))
 731            stgSp :
 732         StAssign PtrRep
 733            (StInd PtrRep (StPrim IntAddOp
 734                 [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))]))
 735            stgSu :
 736         StAssign PtrRep
 737            (StInd PtrRep (StPrim IntAddOp
 738                 [stgCurrentNursery,
 739                  StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]))
 740            (StPrim IntAddOp [stgHp, StInt (toInteger (1 * BYTES_PER_WORD))]) :
 741         xs
 742      )
 743
 744 load_thread_state
 745    = getUniqueUs   `thenUs` \tso_uq ->
 746      let tso = StReg (StixTemp tso_uq ThreadIdRep) in
 747      returnUs (\xs ->
 748         StAssign ThreadIdRep tso stgCurrentTSO :
 749         StAssign PtrRep stgSp
 750            (StInd PtrRep (StPrim IntAddOp
 751                 [tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])) :
 752         StAssign PtrRep stgSu
 753            (StInd PtrRep (StPrim IntAddOp
 754                 [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))])) :
 755         StAssign PtrRep stgSpLim
 756            (StPrim IntAddOp [tso,
 757                              StInt (toInteger ((TSO_STACK + rESERVED_STACK_WORDS)
 758                                                *BYTES_PER_WORD))]) :
 759         StAssign PtrRep stgHp
 760            (StPrim IntSubOp [
 761               StInd PtrRep (StPrim IntAddOp
 762                 [stgCurrentNursery,
 763                  StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]),
 764               StInt (toInteger (1 * BYTES_PER_WORD))
 765             ]) :
 766         StAssign PtrRep stgHpLim
 767            (StPrim IntAddOp [
 768               StInd PtrRep (StPrim IntAddOp
 769                 [stgCurrentNursery,
 770                  StInt (toInteger (BDESCR_START * BYTES_PER_WORD))]),
 771               StInt (toInteger (bLOCK_SIZE - (1 * BYTES_PER_WORD)))
 772             ]) :
 773         xs
 774      )
 775 \end{code}