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' ) where
   7
   8 #include "HsVersions.h"
   9
  10 import MachMisc
  11 import Stix
  12 import StixInteger
  13
  14 import AbsCSyn          hiding ( spRel )
  15 import AbsCUtils        ( getAmodeRep, mixedTypeLocn )
  16 import SMRep            ( fixedHdrSize )
  17 import Literal          ( Literal(..), word2IntLit )
  18 import PrimOp           ( PrimOp(..), CCall(..), CCallTarget(..) )
  19 import PrimRep          ( PrimRep(..), getPrimRepSizeInBytes )
  20 import UniqSupply       ( returnUs, thenUs, getUniqueUs, UniqSM )
  21 import Constants        ( mIN_INTLIKE, mIN_CHARLIKE, uF_UPDATEE, bLOCK_SIZE,
  22                           rESERVED_STACK_WORDS )
  23 import CLabel           ( mkIntlikeClosureLabel, mkCharlikeClosureLabel,
  24                           mkMAP_FROZEN_infoLabel, mkEMPTY_MVAR_infoLabel,
  25                           mkForeignLabel )
  26 import ForeignCall      ( CCallConv(..) )
  27 import Outputable
  28 import FastTypes
  29
  30 #include "NCG.h"
  31 \end{code}
  32
  33 The main honchos here are primCode anf foreignCallCode, which handle the guts of COpStmts.
  34
  35 \begin{code}
  36 foreignCallCode
  37     :: [CAddrMode]      -- results
  38     -> ForeignCall      -- op
  39     -> [CAddrMode]      -- args
  40     -> UniqSM StixTreeList
  41
  42 primCode
  43     :: [CAddrMode]      -- results
  44     -> PrimOp           -- op
  45     -> [CAddrMode]      -- args
  46     -> UniqSM StixTreeList
  47 \end{code}
  48
  49 %************************************************************************
  50 %*                                                                      *
  51 \subsubsection{Code for foreign calls}
  52 %*                                                                      *
  53 %************************************************************************
  54
  55 First, the dreaded @ccall@.  We can't handle @casm@s.
  56
  57 Usually, this compiles to an assignment, but when the left-hand side
  58 is empty, we just perform the call and ignore the result.
  59
  60 btw Why not let programmer use casm to provide assembly code instead
  61 of C code?  ADR
  62
  63 ToDo: saving/restoring of volatile regs around ccalls.
  64
  65 JRS, 001113: always do the call of suspendThread and resumeThread as a ccall
  66 rather than inheriting the calling convention of the thing which we're really
  67 calling.
  68
  69 \begin{code}
  70 foreignCallCode lhs (CCall (CCallSpec (StaticTarget fn) cconv safety is_asm)) rhs
  71   | is_asm                = error "ERROR: Native code generator can't handle casm"
  72   | not (playSafe safety) = returnUs (\xs -> ccall : xs)
  73
  74   | otherwise
  75   = save_thread_state   `thenUs` \ save ->
  76     load_thread_state   `thenUs` \ load ->
  77     getUniqueUs         `thenUs` \ uniq ->
  78     let
  79        id  = StReg (StixTemp uniq IntRep)
  80
  81        suspend = StAssign IntRep id
  82                 (StCall SLIT("suspendThread") {-no:cconv-} CCallConv
  83                             IntRep [stgBaseReg])
  84        resume  = StCall SLIT("resumeThread") {-no:cconv-} CCallConv
  85                         VoidRep [id]
  86     in
  87     returnUs (\xs -> save (suspend : ccall : resume : load xs))
  88
  89   where
  90     args = map amodeCodeForCCall rhs
  91     amodeCodeForCCall x =
  92         let base = amodeToStix' x
  93         in
  94             case getAmodeRep x of
  95               ArrayRep      -> StIndex PtrRep base arrPtrsHS
  96               ByteArrayRep  -> StIndex IntRep base arrWordsHS
  97               ForeignObjRep -> StInd PtrRep (StIndex PtrRep base fixedHS)
  98               _ -> base
  99
 100     ccall = case lhs of
 101       []    -> StCall fn cconv VoidRep args
 102       [lhs] ->
 103           let lhs' = amodeToStix lhs
 104               pk   = case getAmodeRep lhs of
 105                         FloatRep  -> FloatRep
 106                         DoubleRep -> DoubleRep
 107                         other     -> IntRep
 108           in
 109               StAssign pk lhs' (StCall fn cconv pk args)
 110
 111 foreignCallCode lhs call rhs
 112   = pprPanic "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] Int2AddrOp [arg]
 144   = simpleCoercion AddrRep res arg
 145
 146 primCode [res] Addr2IntOp [arg]
 147   = simpleCoercion IntRep res arg
 148
 149 primCode [res] Int2WordOp [arg]
 150   = simpleCoercion IntRep{-WordRep?-} res arg
 151
 152 primCode [res] Word2IntOp [arg]
 153   = simpleCoercion IntRep res arg
 154
 155 primCode [res] AddrToHValueOp [arg]
 156   = simpleCoercion PtrRep res arg
 157
 158 primCode [res] IntToInt8Op [arg]
 159   = narrowingCoercion IntRep Int8Rep res arg
 160 primCode [res] IntToInt16Op [arg]
 161   = narrowingCoercion IntRep Int16Rep res arg
 162 primCode [res] IntToInt32Op [arg]
 163   = narrowingCoercion IntRep Int32Rep res arg
 164
 165 primCode [res] WordToWord8Op [arg]
 166   = narrowingCoercion WordRep Word8Rep res arg
 167 primCode [res] WordToWord16Op [arg]
 168   = narrowingCoercion WordRep Word16Rep res arg
 169 primCode [res] WordToWord32Op [arg]
 170   = narrowingCoercion WordRep Word32Rep res arg
 171 \end{code}
 172
 173 \begin{code}
 174 primCode [res] SameMutableArrayOp args
 175   = let
 176         compare = StPrim AddrEqOp (map amodeToStix args)
 177         assign = StAssign IntRep (amodeToStix res) compare
 178     in
 179     returnUs (\xs -> assign : xs)
 180
 181 primCode res@[_] SameMutableByteArrayOp args
 182   = primCode res SameMutableArrayOp args
 183
 184 primCode res@[_] SameMutVarOp args
 185   = primCode res SameMutableArrayOp args
 186 \end{code}
 187
 188 \begin{code}
 189 primCode res@[_] SameMVarOp args
 190   = primCode res SameMutableArrayOp args
 191
 192 -- #define isEmptyMVarzh(r,a) \
 193 --     r =(I_)((GET_INFO((StgMVar*)(a))) == &stg_EMPTY_MVAR_info )
 194 primCode [res] IsEmptyMVarOp [arg]
 195    = let res'     = amodeToStix res
 196          arg'     = amodeToStix arg
 197          arg_info = StInd PtrRep arg'
 198          em_info  = StCLbl mkEMPTY_MVAR_infoLabel
 199          same     = StPrim IntEqOp [arg_info, em_info]
 200          assign   = StAssign IntRep res' same
 201      in
 202      returnUs (\xs -> assign : xs)
 203
 204 -- #define myThreadIdzh(t) (t = CurrentTSO)
 205 primCode [res] MyThreadIdOp []
 206    = let res' = amodeToStix res
 207      in  returnUs (\xs -> StAssign ThreadIdRep res' stgCurrentTSO : xs)
 208
 209 \end{code}
 210
 211 Freezing an array of pointers is a double assignment.  We fix the
 212 header of the ``new'' closure because the lhs is probably a better
 213 addressing mode for the indirection (most likely, it's a VanillaReg).
 214
 215 \begin{code}
 216
 217 primCode [lhs] UnsafeFreezeArrayOp [rhs]
 218   = let
 219         lhs' = amodeToStix lhs
 220         rhs' = amodeToStix rhs
 221         header = StInd PtrRep lhs'
 222         assign = StAssign PtrRep lhs' rhs'
 223         freeze = StAssign PtrRep header mutArrPtrsFrozen_info
 224     in
 225     returnUs (\xs -> assign : freeze : xs)
 226
 227 primCode [lhs] UnsafeFreezeByteArrayOp [rhs]
 228   = simpleCoercion PtrRep lhs rhs
 229 \end{code}
 230
 231 Returning the size of (mutable) byte arrays is just
 232 an indexing operation.
 233
 234 \begin{code}
 235 primCode [lhs] SizeofByteArrayOp [rhs]
 236   = let
 237         lhs' = amodeToStix lhs
 238         rhs' = amodeToStix rhs
 239         sz   = StIndex IntRep rhs' fixedHS
 240         assign = StAssign IntRep lhs' (StInd IntRep sz)
 241     in
 242     returnUs (\xs -> assign : xs)
 243
 244 primCode [lhs] SizeofMutableByteArrayOp [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 \end{code}
 254
 255 Most other array primitives translate to simple indexing.
 256
 257 \begin{code}
 258 primCode lhs@[_] IndexArrayOp args
 259   = primCode lhs ReadArrayOp args
 260
 261 primCode [lhs] ReadArrayOp [obj, ix]
 262   = let
 263         lhs' = amodeToStix lhs
 264         obj' = amodeToStix obj
 265         ix' = amodeToStix ix
 266         base = StIndex IntRep obj' arrPtrsHS
 267         assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
 268     in
 269     returnUs (\xs -> assign : xs)
 270
 271 primCode [] WriteArrayOp [obj, ix, v]
 272   = let
 273         obj' = amodeToStix obj
 274         ix' = amodeToStix ix
 275         v' = amodeToStix v
 276         base = StIndex IntRep obj' arrPtrsHS
 277         assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
 278     in
 279     returnUs (\xs -> assign : xs)
 280
 281 primCode [] WriteForeignObjOp [obj, v]
 282   = let
 283         obj' = amodeToStix obj
 284         v' = amodeToStix v
 285         obj'' = StIndex AddrRep obj' (StInt 4711) -- fixedHS
 286         assign = StAssign AddrRep (StInd AddrRep obj'') v'
 287     in
 288     returnUs (\xs -> assign : xs)
 289
 290 -- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
 291 primCode ls IndexByteArrayOp_Char      rs = primCode_ReadByteArrayOp Word8Rep     ls rs
 292 primCode ls IndexByteArrayOp_WideChar  rs = primCode_ReadByteArrayOp CharRep      ls rs
 293 primCode ls IndexByteArrayOp_Int       rs = primCode_ReadByteArrayOp IntRep       ls rs
 294 primCode ls IndexByteArrayOp_Word      rs = primCode_ReadByteArrayOp WordRep      ls rs
 295 primCode ls IndexByteArrayOp_Addr      rs = primCode_ReadByteArrayOp AddrRep      ls rs
 296 primCode ls IndexByteArrayOp_Float     rs = primCode_ReadByteArrayOp FloatRep     ls rs
 297 primCode ls IndexByteArrayOp_Double    rs = primCode_ReadByteArrayOp DoubleRep    ls rs
 298 primCode ls IndexByteArrayOp_StablePtr rs = primCode_ReadByteArrayOp StablePtrRep ls rs
 299 primCode ls IndexByteArrayOp_Int8      rs = primCode_ReadByteArrayOp Int8Rep      ls rs
 300 primCode ls IndexByteArrayOp_Int16     rs = primCode_ReadByteArrayOp Int16Rep     ls rs
 301 primCode ls IndexByteArrayOp_Int32     rs = primCode_ReadByteArrayOp Int32Rep     ls rs
 302 primCode ls IndexByteArrayOp_Int64     rs = primCode_ReadByteArrayOp Int64Rep     ls rs
 303 primCode ls IndexByteArrayOp_Word8     rs = primCode_ReadByteArrayOp Word8Rep     ls rs
 304 primCode ls IndexByteArrayOp_Word16    rs = primCode_ReadByteArrayOp Word16Rep    ls rs
 305 primCode ls IndexByteArrayOp_Word32    rs = primCode_ReadByteArrayOp Word32Rep    ls rs
 306 primCode ls IndexByteArrayOp_Word64    rs = primCode_ReadByteArrayOp Word64Rep    ls rs
 307
 308 primCode ls ReadByteArrayOp_Char      rs = primCode_ReadByteArrayOp Word8Rep     ls rs
 309 primCode ls ReadByteArrayOp_WideChar  rs = primCode_ReadByteArrayOp CharRep      ls rs
 310 primCode ls ReadByteArrayOp_Int       rs = primCode_ReadByteArrayOp IntRep       ls rs
 311 primCode ls ReadByteArrayOp_Word      rs = primCode_ReadByteArrayOp WordRep      ls rs
 312 primCode ls ReadByteArrayOp_Addr      rs = primCode_ReadByteArrayOp AddrRep      ls rs
 313 primCode ls ReadByteArrayOp_Float     rs = primCode_ReadByteArrayOp FloatRep     ls rs
 314 primCode ls ReadByteArrayOp_Double    rs = primCode_ReadByteArrayOp DoubleRep    ls rs
 315 primCode ls ReadByteArrayOp_StablePtr rs = primCode_ReadByteArrayOp StablePtrRep ls rs
 316 primCode ls ReadByteArrayOp_Int8      rs = primCode_ReadByteArrayOp Int8Rep      ls rs
 317 primCode ls ReadByteArrayOp_Int16     rs = primCode_ReadByteArrayOp Int16Rep     ls rs
 318 primCode ls ReadByteArrayOp_Int32     rs = primCode_ReadByteArrayOp Int32Rep     ls rs
 319 primCode ls ReadByteArrayOp_Int64     rs = primCode_ReadByteArrayOp Int64Rep     ls rs
 320 primCode ls ReadByteArrayOp_Word8     rs = primCode_ReadByteArrayOp Word8Rep     ls rs
 321 primCode ls ReadByteArrayOp_Word16    rs = primCode_ReadByteArrayOp Word16Rep    ls rs
 322 primCode ls ReadByteArrayOp_Word32    rs = primCode_ReadByteArrayOp Word32Rep    ls rs
 323 primCode ls ReadByteArrayOp_Word64    rs = primCode_ReadByteArrayOp Word64Rep    ls rs
 324
 325 primCode ls WriteByteArrayOp_Char      rs = primCode_WriteByteArrayOp Word8Rep     ls rs
 326 primCode ls WriteByteArrayOp_WideChar  rs = primCode_WriteByteArrayOp CharRep      ls rs
 327 primCode ls WriteByteArrayOp_Int       rs = primCode_WriteByteArrayOp IntRep       ls rs
 328 primCode ls WriteByteArrayOp_Word      rs = primCode_WriteByteArrayOp WordRep      ls rs
 329 primCode ls WriteByteArrayOp_Addr      rs = primCode_WriteByteArrayOp AddrRep      ls rs
 330 primCode ls WriteByteArrayOp_Float     rs = primCode_WriteByteArrayOp FloatRep     ls rs
 331 primCode ls WriteByteArrayOp_Double    rs = primCode_WriteByteArrayOp DoubleRep    ls rs
 332 primCode ls WriteByteArrayOp_StablePtr rs = primCode_WriteByteArrayOp StablePtrRep ls rs
 333 primCode ls WriteByteArrayOp_Int8      rs = primCode_WriteByteArrayOp Int8Rep      ls rs
 334 primCode ls WriteByteArrayOp_Int16     rs = primCode_WriteByteArrayOp Int16Rep     ls rs
 335 primCode ls WriteByteArrayOp_Int32     rs = primCode_WriteByteArrayOp Int32Rep     ls rs
 336 primCode ls WriteByteArrayOp_Int64     rs = primCode_WriteByteArrayOp Int64Rep     ls rs
 337 primCode ls WriteByteArrayOp_Word8     rs = primCode_WriteByteArrayOp Word8Rep     ls rs
 338 primCode ls WriteByteArrayOp_Word16    rs = primCode_WriteByteArrayOp Word16Rep    ls rs
 339 primCode ls WriteByteArrayOp_Word32    rs = primCode_WriteByteArrayOp Word32Rep    ls rs
 340 primCode ls WriteByteArrayOp_Word64    rs = primCode_WriteByteArrayOp Word64Rep    ls rs
 341
 342 primCode ls IndexOffAddrOp_Char      rs = primCode_IndexOffAddrOp Word8Rep     ls rs
 343 primCode ls IndexOffAddrOp_WideChar  rs = primCode_IndexOffAddrOp CharRep      ls rs
 344 primCode ls IndexOffAddrOp_Int       rs = primCode_IndexOffAddrOp IntRep       ls rs
 345 primCode ls IndexOffAddrOp_Word      rs = primCode_IndexOffAddrOp WordRep      ls rs
 346 primCode ls IndexOffAddrOp_Addr      rs = primCode_IndexOffAddrOp AddrRep      ls rs
 347 primCode ls IndexOffAddrOp_Float     rs = primCode_IndexOffAddrOp FloatRep     ls rs
 348 primCode ls IndexOffAddrOp_Double    rs = primCode_IndexOffAddrOp DoubleRep    ls rs
 349 primCode ls IndexOffAddrOp_StablePtr rs = primCode_IndexOffAddrOp StablePtrRep ls rs
 350 primCode ls IndexOffAddrOp_Int8      rs = primCode_IndexOffAddrOp Int8Rep      ls rs
 351 primCode ls IndexOffAddrOp_Int16     rs = primCode_IndexOffAddrOp Int16Rep     ls rs
 352 primCode ls IndexOffAddrOp_Int32     rs = primCode_IndexOffAddrOp Int32Rep     ls rs
 353 primCode ls IndexOffAddrOp_Int64     rs = primCode_IndexOffAddrOp Int64Rep     ls rs
 354 primCode ls IndexOffAddrOp_Word8     rs = primCode_IndexOffAddrOp Word8Rep     ls rs
 355 primCode ls IndexOffAddrOp_Word16    rs = primCode_IndexOffAddrOp Word16Rep    ls rs
 356 primCode ls IndexOffAddrOp_Word32    rs = primCode_IndexOffAddrOp Word32Rep    ls rs
 357 primCode ls IndexOffAddrOp_Word64    rs = primCode_IndexOffAddrOp Word64Rep    ls rs
 358
 359 primCode ls IndexOffForeignObjOp_Char      rs = primCode_IndexOffForeignObjOp Word8Rep     ls rs
 360 primCode ls IndexOffForeignObjOp_WideChar  rs = primCode_IndexOffForeignObjOp CharRep      ls rs
 361 primCode ls IndexOffForeignObjOp_Int       rs = primCode_IndexOffForeignObjOp IntRep       ls rs
 362 primCode ls IndexOffForeignObjOp_Word      rs = primCode_IndexOffForeignObjOp WordRep      ls rs
 363 primCode ls IndexOffForeignObjOp_Addr      rs = primCode_IndexOffForeignObjOp AddrRep      ls rs
 364 primCode ls IndexOffForeignObjOp_Float     rs = primCode_IndexOffForeignObjOp FloatRep     ls rs
 365 primCode ls IndexOffForeignObjOp_Double    rs = primCode_IndexOffForeignObjOp DoubleRep    ls rs
 366 primCode ls IndexOffForeignObjOp_StablePtr rs = primCode_IndexOffForeignObjOp StablePtrRep ls rs
 367 primCode ls IndexOffForeignObjOp_Int8      rs = primCode_IndexOffForeignObjOp Int8Rep      ls rs
 368 primCode ls IndexOffForeignObjOp_Int16     rs = primCode_IndexOffForeignObjOp Int16Rep     ls rs
 369 primCode ls IndexOffForeignObjOp_Int32     rs = primCode_IndexOffForeignObjOp Int32Rep     ls rs
 370 primCode ls IndexOffForeignObjOp_Int64     rs = primCode_IndexOffForeignObjOp Int64Rep     ls rs
 371 primCode ls IndexOffForeignObjOp_Word8     rs = primCode_IndexOffForeignObjOp Word8Rep     ls rs
 372 primCode ls IndexOffForeignObjOp_Word16    rs = primCode_IndexOffForeignObjOp Word16Rep    ls rs
 373 primCode ls IndexOffForeignObjOp_Word32    rs = primCode_IndexOffForeignObjOp Word32Rep    ls rs
 374 primCode ls IndexOffForeignObjOp_Word64    rs = primCode_IndexOffForeignObjOp Word64Rep    ls rs
 375
 376 primCode ls ReadOffAddrOp_Char      rs = primCode_IndexOffAddrOp Word8Rep     ls rs
 377 primCode ls ReadOffAddrOp_WideChar  rs = primCode_IndexOffAddrOp CharRep      ls rs
 378 primCode ls ReadOffAddrOp_Int       rs = primCode_IndexOffAddrOp IntRep       ls rs
 379 primCode ls ReadOffAddrOp_Word      rs = primCode_IndexOffAddrOp WordRep      ls rs
 380 primCode ls ReadOffAddrOp_Addr      rs = primCode_IndexOffAddrOp AddrRep      ls rs
 381 primCode ls ReadOffAddrOp_Float     rs = primCode_IndexOffAddrOp FloatRep     ls rs
 382 primCode ls ReadOffAddrOp_Double    rs = primCode_IndexOffAddrOp DoubleRep    ls rs
 383 primCode ls ReadOffAddrOp_StablePtr rs = primCode_IndexOffAddrOp StablePtrRep ls rs
 384 primCode ls ReadOffAddrOp_Int8      rs = primCode_IndexOffAddrOp Int8Rep      ls rs
 385 primCode ls ReadOffAddrOp_Int16     rs = primCode_IndexOffAddrOp Int16Rep     ls rs
 386 primCode ls ReadOffAddrOp_Int32     rs = primCode_IndexOffAddrOp Int32Rep     ls rs
 387 primCode ls ReadOffAddrOp_Int64     rs = primCode_IndexOffAddrOp Int64Rep     ls rs
 388 primCode ls ReadOffAddrOp_Word8     rs = primCode_IndexOffAddrOp Word8Rep     ls rs
 389 primCode ls ReadOffAddrOp_Word16    rs = primCode_IndexOffAddrOp Word16Rep    ls rs
 390 primCode ls ReadOffAddrOp_Word32    rs = primCode_IndexOffAddrOp Word32Rep    ls rs
 391 primCode ls ReadOffAddrOp_Word64    rs = primCode_IndexOffAddrOp Word64Rep    ls rs
 392
 393 primCode ls WriteOffAddrOp_Char      rs = primCode_WriteOffAddrOp Word8Rep     ls rs
 394 primCode ls WriteOffAddrOp_WideChar  rs = primCode_WriteOffAddrOp CharRep      ls rs
 395 primCode ls WriteOffAddrOp_Int       rs = primCode_WriteOffAddrOp IntRep       ls rs
 396 primCode ls WriteOffAddrOp_Word      rs = primCode_WriteOffAddrOp WordRep      ls rs
 397 primCode ls WriteOffAddrOp_Addr      rs = primCode_WriteOffAddrOp AddrRep      ls rs
 398 primCode ls WriteOffAddrOp_Float     rs = primCode_WriteOffAddrOp FloatRep     ls rs
 399 primCode ls WriteOffAddrOp_Double    rs = primCode_WriteOffAddrOp DoubleRep    ls rs
 400 primCode ls WriteOffAddrOp_StablePtr rs = primCode_WriteOffAddrOp StablePtrRep ls rs
 401 primCode ls WriteOffAddrOp_Int8      rs = primCode_WriteOffAddrOp Int8Rep      ls rs
 402 primCode ls WriteOffAddrOp_Int16     rs = primCode_WriteOffAddrOp Int16Rep     ls rs
 403 primCode ls WriteOffAddrOp_Int32     rs = primCode_WriteOffAddrOp Int32Rep     ls rs
 404 primCode ls WriteOffAddrOp_Int64     rs = primCode_WriteOffAddrOp Int64Rep     ls rs
 405 primCode ls WriteOffAddrOp_Word8     rs = primCode_WriteOffAddrOp Word8Rep     ls rs
 406 primCode ls WriteOffAddrOp_Word16    rs = primCode_WriteOffAddrOp Word16Rep    ls rs
 407 primCode ls WriteOffAddrOp_Word32    rs = primCode_WriteOffAddrOp Word32Rep    ls rs
 408 primCode ls WriteOffAddrOp_Word64    rs = primCode_WriteOffAddrOp Word64Rep    ls rs
 409
 410 \end{code}
 411
 412
 413 DataToTagOp won't work for 64-bit archs, as it is.
 414
 415 \begin{code}
 416 primCode [lhs] DataToTagOp [arg]
 417   = let lhs'        = amodeToStix lhs
 418         arg'        = amodeToStix arg
 419         infoptr     = StInd PtrRep arg'
 420         word_32     = StInd WordRep (StIndex PtrRep infoptr (StInt (-1)))
 421         masked_le32 = StPrim SrlOp [word_32, StInt 16]
 422         masked_be32 = StPrim AndOp [word_32, StInt 65535]
 423 #ifdef WORDS_BIGENDIAN
 424         masked      = masked_be32
 425 #else
 426         masked      = masked_le32
 427 #endif
 428         assign      = StAssign IntRep lhs' masked
 429     in
 430     returnUs (\xs -> assign : xs)
 431 \end{code}
 432
 433 MutVars are pretty simple.
 434 #define writeMutVarzh(a,v)       (P_)(((StgMutVar *)(a))->var)=(v)
 435
 436 \begin{code}
 437 primCode [] WriteMutVarOp [aa,vv]
 438    = let aa_s      = amodeToStix aa
 439          vv_s      = amodeToStix vv
 440          var_field = StIndex PtrRep aa_s fixedHS
 441          assign    = StAssign PtrRep (StInd PtrRep var_field) vv_s
 442      in
 443      returnUs (\xs -> assign : xs)
 444
 445 primCode [rr] ReadMutVarOp [aa]
 446    = let aa_s      = amodeToStix aa
 447          rr_s      = amodeToStix rr
 448          var_field = StIndex PtrRep aa_s fixedHS
 449          assign    = StAssign PtrRep rr_s (StInd PtrRep var_field)
 450      in
 451      returnUs (\xs -> assign : xs)
 452 \end{code}
 453
 454 ForeignObj# primops.
 455
 456 \begin{code}
 457 primCode [rr] ForeignObjToAddrOp [fo]
 458   = let code =  StAssign AddrRep (amodeToStix rr)
 459                    (StInd AddrRep
 460                         (StIndex PtrRep (amodeToStix fo) fixedHS))
 461     in
 462     returnUs (\xs -> code : xs)
 463
 464 primCode [] TouchOp [_] = returnUs id
 465 \end{code}
 466
 467 Now the more mundane operations.
 468
 469 \begin{code}
 470 primCode lhs op rhs
 471   = let
 472         lhs' = map amodeToStix  lhs
 473         rhs' = map amodeToStix' rhs
 474         pk   = getAmodeRep (head lhs)
 475     in
 476     returnUs (\ xs -> simplePrim pk lhs' op rhs' : xs)
 477 \end{code}
 478
 479 Helper fns for some array ops.
 480
 481 \begin{code}
 482 primCode_ReadByteArrayOp pk [lhs] [obj, ix]
 483   = let
 484         lhs' = amodeToStix lhs
 485         obj' = amodeToStix obj
 486         ix' = amodeToStix ix
 487         base = StIndex IntRep obj' arrWordsHS
 488         assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
 489     in
 490     returnUs (\xs -> assign : xs)
 491
 492
 493 primCode_IndexOffAddrOp pk [lhs] [obj, ix]
 494   = let
 495         lhs' = amodeToStix lhs
 496         obj' = amodeToStix obj
 497         ix' = amodeToStix ix
 498         assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
 499     in
 500     returnUs (\xs -> assign : xs)
 501
 502
 503 primCode_IndexOffForeignObjOp pk [lhs] [obj, ix]
 504   = let
 505         lhs' = amodeToStix lhs
 506         obj' = amodeToStix obj
 507         ix' = amodeToStix ix
 508         obj'' = StIndex AddrRep obj' fixedHS
 509         assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix'))
 510     in
 511     returnUs (\xs -> assign : xs)
 512
 513
 514 primCode_WriteOffAddrOp pk [] [obj, ix, v]
 515   = let
 516         obj' = amodeToStix obj
 517         ix' = amodeToStix ix
 518         v' = amodeToStix v
 519         assign = StAssign pk (StInd pk (StIndex pk obj' ix')) v'
 520     in
 521     returnUs (\xs -> assign : xs)
 522
 523
 524 primCode_WriteByteArrayOp pk [] [obj, ix, v]
 525   = let
 526         obj' = amodeToStix obj
 527         ix' = amodeToStix ix
 528         v' = amodeToStix v
 529         base = StIndex IntRep obj' arrWordsHS
 530         assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
 531     in
 532     returnUs (\xs -> assign : xs)
 533
 534 \end{code}
 535
 536 \begin{code}
 537 simpleCoercion
 538       :: PrimRep
 539       -> CAddrMode
 540       -> CAddrMode
 541       -> UniqSM StixTreeList
 542
 543 simpleCoercion pk lhs rhs
 544   = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
 545
 546
 547 -- Rewrite a narrowing coercion into a pair of shifts.
 548 narrowingCoercion
 549       :: PrimRep   -> PrimRep
 550       -> CAddrMode -> CAddrMode
 551       -> UniqSM StixTreeList
 552
 553 narrowingCoercion pks pkd dst src
 554   | szd > szs
 555   = panic "StixPrim.narrowingCoercion"
 556   | szd == szs
 557   = returnUs (\xs -> StAssign pkd dst' src' : xs)
 558   | otherwise
 559   = returnUs (\xs -> assign : xs)
 560     where
 561           szs       = getPrimRepSizeInBytes pks
 562           szd       = getPrimRepSizeInBytes pkd
 563           src'      = amodeToStix src
 564           dst'      = amodeToStix dst
 565           shift_amt = fromIntegral (8 * (szs - szd))
 566
 567           assign
 568              = StAssign pkd dst'
 569                   (StPrim (if signed then ISraOp else SrlOp)
 570                      [StPrim SllOp [src', StInt shift_amt],
 571                       StInt shift_amt])
 572           signed
 573              = case pkd of
 574                   Int8Rep -> True; Int16Rep -> True
 575                   Int32Rep -> True; Int64Rep -> True; IntRep -> True
 576                   Word8Rep -> False; Word16Rep -> False
 577                   Word32Rep -> False; Word64Rep -> False; WordRep -> False
 578                   other -> pprPanic "StixPrim.narrowingCoercion" (ppr pkd)
 579 \end{code}
 580
 581 Here we try to rewrite primitives into a form the code generator can
 582 understand.  Any primitives not handled here must be handled at the
 583 level of the specific code generator.
 584
 585 \begin{code}
 586 simplePrim
 587     :: PrimRep          -- Rep of first destination
 588     -> [StixTree]       -- Destinations
 589     -> PrimOp
 590     -> [StixTree]
 591     -> StixTree
 592 \end{code}
 593
 594 Now look for something more conventional.
 595
 596 \begin{code}
 597 simplePrim pk [lhs] op rest  = StAssign pk lhs (StPrim op rest)
 598 simplePrim pk as    op bs    = simplePrim_error op
 599
 600 simplePrim_error op
 601     = 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")
 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}