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 MachRegs
  12 import Stix
  13 import StixInteger
  14
  15 import AbsCSyn          hiding ( spRel )
  16 import AbsCUtils        ( getAmodeRep, mixedTypeLocn )
  17 import SMRep            ( fixedHdrSize )
  18 import Literal          ( Literal(..), word2IntLit )
  19 import CallConv         ( cCallConv )
  20 import PrimOp           ( PrimOp(..), CCall(..), CCallTarget(..) )
  21 import PrimRep          ( PrimRep(..), isFloatingRep )
  22 import UniqSupply       ( returnUs, thenUs, getUniqueUs, UniqSM )
  23 import Constants        ( mIN_INTLIKE, uF_UPDATEE, bLOCK_SIZE )
  24 import Outputable
  25
  26 import Char             ( ord, isAlphaNum )
  27
  28 #include "NCG.h"
  29 \end{code}
  30
  31 The main honcho here is primCode, which handles the guts of COpStmts.
  32
  33 \begin{code}
  34 primCode
  35     :: [CAddrMode]      -- results
  36     -> PrimOp           -- op
  37     -> [CAddrMode]      -- args
  38     -> UniqSM StixTreeList
  39 \end{code}
  40
  41 First, the dreaded @ccall@.  We can't handle @casm@s.
  42
  43 Usually, this compiles to an assignment, but when the left-hand side
  44 is empty, we just perform the call and ignore the result.
  45
  46 btw Why not let programmer use casm to provide assembly code instead
  47 of C code?  ADR
  48
  49 The (MP) integer operations are a true nightmare.  Since we don't have
  50 a convenient abstract way of allocating temporary variables on the (C)
  51 stack, we use the space just below HpLim for the @MP_INT@ structures,
  52 and modify our heap check accordingly.
  53
  54 \begin{code}
  55 -- NB: ordering of clauses somewhere driven by
  56 -- the desire to getting sane patt-matching behavior
  57 primCode res@[sr,dr] IntegerNegOp arg@[sa,da]
  58   = gmpNegate (sr,dr) (sa,da)
  59
  60 primCode [res] IntegerCmpOp args@[sa1,da1, sa2,da2]
  61   = gmpCompare res (sa1,da1, sa2,da2)
  62
  63 primCode [res] IntegerCmpIntOp args@[sa1,da1,ai]
  64   = gmpCompareInt res (sa1,da1,ai)
  65
  66 primCode [res] Integer2IntOp arg@[sa,da]
  67   = gmpInteger2Int res (sa,da)
  68
  69 primCode [res] Integer2WordOp arg@[sa,da]
  70   = gmpInteger2Word res (sa,da)
  71
  72 primCode [res] Int2AddrOp [arg]
  73   = simpleCoercion AddrRep res arg
  74
  75 primCode [res] Addr2IntOp [arg]
  76   = simpleCoercion IntRep res arg
  77
  78 primCode [res] Int2WordOp [arg]
  79   = simpleCoercion IntRep{-WordRep?-} res arg
  80
  81 primCode [res] Word2IntOp [arg]
  82   = simpleCoercion IntRep res arg
  83 \end{code}
  84
  85 \begin{code}
  86 primCode [res] SameMutableArrayOp args
  87   = let
  88         compare = StPrim AddrEqOp (map amodeToStix args)
  89         assign = StAssign IntRep (amodeToStix res) compare
  90     in
  91     returnUs (\xs -> assign : xs)
  92
  93 primCode res@[_] SameMutableByteArrayOp args
  94   = primCode res SameMutableArrayOp args
  95
  96 primCode res@[_] SameMutVarOp args
  97   = primCode res SameMutableArrayOp args
  98
  99 primCode res@[_] SameMVarOp args
 100   = primCode res SameMutableArrayOp args
 101 \end{code}
 102
 103 Freezing an array of pointers is a double assignment.  We fix the
 104 header of the ``new'' closure because the lhs is probably a better
 105 addressing mode for the indirection (most likely, it's a VanillaReg).
 106
 107 \begin{code}
 108
 109 primCode [lhs] UnsafeFreezeArrayOp [rhs]
 110   = let
 111         lhs' = amodeToStix lhs
 112         rhs' = amodeToStix rhs
 113         header = StInd PtrRep lhs'
 114         assign = StAssign PtrRep lhs' rhs'
 115         freeze = StAssign PtrRep header mutArrPtrsFrozen_info
 116     in
 117     returnUs (\xs -> assign : freeze : xs)
 118
 119 primCode [lhs] UnsafeFreezeByteArrayOp [rhs]
 120   = simpleCoercion PtrRep lhs rhs
 121 \end{code}
 122
 123 Returning the size of (mutable) byte arrays is just
 124 an indexing operation.
 125
 126 \begin{code}
 127 primCode [lhs] SizeofByteArrayOp [rhs]
 128   = let
 129         lhs' = amodeToStix lhs
 130         rhs' = amodeToStix rhs
 131         sz   = StIndex IntRep rhs' fixedHS
 132         assign = StAssign IntRep lhs' (StInd IntRep sz)
 133     in
 134     returnUs (\xs -> assign : xs)
 135
 136 primCode [lhs] SizeofMutableByteArrayOp [rhs]
 137   = let
 138         lhs' = amodeToStix lhs
 139         rhs' = amodeToStix rhs
 140         sz   = StIndex IntRep rhs' fixedHS
 141         assign = StAssign IntRep lhs' (StInd IntRep sz)
 142     in
 143     returnUs (\xs -> assign : xs)
 144
 145 \end{code}
 146
 147 Most other array primitives translate to simple indexing.
 148
 149 \begin{code}
 150 primCode lhs@[_] IndexArrayOp args
 151   = primCode lhs ReadArrayOp args
 152
 153 primCode [lhs] ReadArrayOp [obj, ix]
 154   = let
 155         lhs' = amodeToStix lhs
 156         obj' = amodeToStix obj
 157         ix' = amodeToStix ix
 158         base = StIndex IntRep obj' arrPtrsHS
 159         assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
 160     in
 161     returnUs (\xs -> assign : xs)
 162
 163 primCode [] WriteArrayOp [obj, ix, v]
 164   = let
 165         obj' = amodeToStix obj
 166         ix' = amodeToStix ix
 167         v' = amodeToStix v
 168         base = StIndex IntRep obj' arrPtrsHS
 169         assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
 170     in
 171     returnUs (\xs -> assign : xs)
 172
 173 primCode lhs@[_] (IndexByteArrayOp pk) args
 174   = primCode lhs (ReadByteArrayOp pk) args
 175
 176 -- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
 177
 178 primCode [lhs] (ReadByteArrayOp pk) [obj, ix]
 179   = let
 180         lhs' = amodeToStix lhs
 181         obj' = amodeToStix obj
 182         ix' = amodeToStix ix
 183         base = StIndex IntRep obj' arrWordsHS
 184         assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
 185     in
 186     returnUs (\xs -> assign : xs)
 187
 188 primCode lhs@[_] (ReadOffAddrOp pk) args
 189   = primCode lhs (IndexOffAddrOp pk) args
 190
 191 primCode [lhs] (IndexOffAddrOp pk) [obj, ix]
 192   = let
 193         lhs' = amodeToStix lhs
 194         obj' = amodeToStix obj
 195         ix' = amodeToStix ix
 196         assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
 197     in
 198     returnUs (\xs -> assign : xs)
 199
 200 primCode [lhs] (IndexOffForeignObjOp pk) [obj, ix]
 201   = let
 202         lhs' = amodeToStix lhs
 203         obj' = amodeToStix obj
 204         ix' = amodeToStix ix
 205         obj'' = StIndex AddrRep obj' fixedHS
 206         assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix'))
 207     in
 208     returnUs (\xs -> assign : xs)
 209
 210 primCode [] (WriteOffAddrOp pk) [obj, ix, v]
 211   = let
 212         obj' = amodeToStix obj
 213         ix' = amodeToStix ix
 214         v' = amodeToStix v
 215         assign = StAssign pk (StInd pk (StIndex pk obj' ix')) v'
 216     in
 217     returnUs (\xs -> assign : xs)
 218
 219 primCode [] (WriteByteArrayOp pk) [obj, ix, v]
 220   = let
 221         obj' = amodeToStix obj
 222         ix' = amodeToStix ix
 223         v' = amodeToStix v
 224         base = StIndex IntRep obj' arrWordsHS
 225         assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
 226     in
 227     returnUs (\xs -> assign : xs)
 228
 229 primCode [] WriteForeignObjOp [obj, v]
 230   = let
 231         obj' = amodeToStix obj
 232         v' = amodeToStix v
 233         obj'' = StIndex AddrRep obj' (StInt 4711) -- fixedHS
 234         assign = StAssign AddrRep (StInd AddrRep obj'') v'
 235     in
 236     returnUs (\xs -> assign : xs)
 237 \end{code}
 238
 239 ToDo: saving/restoring of volatile regs around ccalls.
 240
 241 \begin{code}
 242 primCode lhs (CCallOp (CCall (StaticTarget fn) is_asm may_gc cconv)) rhs
 243   | is_asm = error "ERROR: Native code generator can't handle casm"
 244   | not may_gc = returnUs (\xs -> ccall : xs)
 245   | otherwise =
 246         save_thread_state       `thenUs` \ save ->
 247         load_thread_state       `thenUs` \ load ->
 248         getUniqueUs             `thenUs` \ uniq ->
 249         let
 250            id  = StReg (StixTemp uniq IntRep)
 251
 252            suspend = StAssign IntRep id
 253                         (StCall SLIT("suspendThread") cconv IntRep [stgBaseReg])
 254            resume  = StCall SLIT("resumeThread") cconv VoidRep [id]
 255         in
 256         returnUs (\xs -> save (suspend : ccall : resume : load xs))
 257
 258   where
 259     args = map amodeCodeForCCall rhs
 260     amodeCodeForCCall x =
 261         let base = amodeToStix' x
 262         in
 263             case getAmodeRep x of
 264               ArrayRep      -> StIndex PtrRep base arrPtrsHS
 265               ByteArrayRep  -> StIndex IntRep base arrWordsHS
 266               ForeignObjRep -> StIndex PtrRep base fixedHS
 267               _ -> base
 268
 269     ccall = case lhs of
 270       [] -> StCall fn cconv VoidRep args
 271       [lhs] ->
 272           let lhs' = amodeToStix lhs
 273               pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
 274           in
 275               StAssign pk lhs' (StCall fn cconv pk args)
 276 \end{code}
 277
 278 DataToTagOp won't work for 64-bit archs, as it is.
 279
 280 \begin{code}
 281 primCode [lhs] DataToTagOp [arg]
 282   = let lhs'        = amodeToStix lhs
 283         arg'        = amodeToStix arg
 284         infoptr     = StInd PtrRep arg'
 285         word_32     = StInd WordRep (StIndex PtrRep infoptr (StInt (-1)))
 286         masked_le32 = StPrim SrlOp [word_32, StInt 16]
 287         masked_be32 = StPrim AndOp [word_32, StInt 65535]
 288 #ifdef WORDS_BIGENDIAN
 289         masked      = masked_be32
 290 #else
 291         masked      = masked_le32
 292 #endif
 293         assign      = StAssign IntRep lhs' masked
 294     in
 295     returnUs (\xs -> assign : xs)
 296 \end{code}
 297
 298 MutVars are pretty simple.
 299 #define writeMutVarzh(a,v)       (P_)(((StgMutVar *)(a))->var)=(v)
 300
 301 \begin{code}
 302 primCode [] WriteMutVarOp [aa,vv]
 303    = let aa_s      = amodeToStix aa
 304          vv_s      = amodeToStix vv
 305          var_field = StIndex PtrRep aa_s fixedHS
 306          assign    = StAssign PtrRep (StInd PtrRep var_field) vv_s
 307      in
 308      returnUs (\xs -> assign : xs)
 309
 310 primCode [rr] ReadMutVarOp [aa]
 311    = let aa_s      = amodeToStix aa
 312          rr_s      = amodeToStix rr
 313          var_field = StIndex PtrRep aa_s fixedHS
 314          assign    = StAssign PtrRep rr_s (StInd PtrRep var_field)
 315      in
 316      returnUs (\xs -> assign : xs)
 317 \end{code}
 318
 319 Now the more mundane operations.
 320
 321 \begin{code}
 322 primCode lhs op rhs
 323   = let
 324         lhs' = map amodeToStix  lhs
 325         rhs' = map amodeToStix' rhs
 326         pk   = getAmodeRep (head lhs)
 327     in
 328     returnUs (\ xs -> simplePrim pk lhs' op rhs' : xs)
 329 \end{code}
 330
 331 \begin{code}
 332 simpleCoercion
 333       :: PrimRep
 334       -> CAddrMode
 335       -> CAddrMode
 336       -> UniqSM StixTreeList
 337
 338 simpleCoercion pk lhs rhs
 339   = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
 340 \end{code}
 341
 342 Here we try to rewrite primitives into a form the code generator can
 343 understand.  Any primitives not handled here must be handled at the
 344 level of the specific code generator.
 345
 346 \begin{code}
 347 simplePrim
 348     :: PrimRep          -- Rep of first destination
 349     -> [StixTree]       -- Destinations
 350     -> PrimOp
 351     -> [StixTree]
 352     -> StixTree
 353 \end{code}
 354
 355 Now look for something more conventional.
 356
 357 \begin{code}
 358 simplePrim pk [lhs] op rest  = StAssign pk lhs (StPrim op rest)
 359 simplePrim pk as    op bs    = simplePrim_error op
 360
 361 simplePrim_error op
 362     = 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")
 363 \end{code}
 364
 365 %---------------------------------------------------------------------
 366
 367 Here we generate the Stix code for CAddrModes.
 368
 369 When a character is fetched from a mixed type location, we have to do
 370 an extra cast.  This is reflected in amodeCode', which is for rhs
 371 amodes that might possibly need the extra cast.
 372
 373 \begin{code}
 374 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
 375
 376 amodeToStix'{-'-} am@(CVal rr CharRep)
 377     | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
 378     | otherwise = amodeToStix am
 379
 380 amodeToStix' am = amodeToStix am
 381
 382 -----------
 383 amodeToStix am@(CVal rr CharRep)
 384   | mixedTypeLocn am
 385   = StInd IntRep (amodeToStix (CAddr rr))
 386
 387 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
 388
 389 amodeToStix (CAddr (SpRel off))
 390   = StIndex PtrRep stgSp (StInt (toInteger IBOX(off)))
 391
 392 amodeToStix (CAddr (HpRel off))
 393   = StIndex IntRep stgHp (StInt (toInteger (- IBOX(off))))
 394
 395 amodeToStix (CAddr (NodeRel off))
 396   = StIndex IntRep stgNode (StInt (toInteger IBOX(off)))
 397
 398 amodeToStix (CAddr (CIndex base off pk))
 399   = StIndex pk (amodeToStix base) (amodeToStix off)
 400
 401 amodeToStix (CReg magic)    = StReg (StixMagicId magic)
 402 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
 403
 404 amodeToStix (CLbl      lbl _) = StCLbl lbl
 405
 406  -- For CharLike and IntLike, we attempt some trivial constant-folding here.
 407
 408 amodeToStix (CCharLike (CLit (MachChar c)))
 409   = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closure+")) (int off))
 410   where
 411     off = charLikeSize * ord c
 412
 413 amodeToStix (CCharLike x)
 414   = StIndex CharRep charLike off
 415   where
 416     off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
 417
 418 amodeToStix (CIntLike (CLit (MachInt i)))
 419   = StLitLbl ((<>) (ptext SLIT("INTLIKE_closure+")) (int off))
 420   where
 421     off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
 422
 423 amodeToStix (CIntLike x)
 424   = panic "CIntLike"
 425
 426 amodeToStix (CLit core)
 427   = case core of
 428       MachChar c     -> StInt (toInteger (ord c))
 429       MachStr s      -> StString s
 430       MachAddr a     -> StInt a
 431       MachInt i      -> StInt i
 432       MachWord w     -> case word2IntLit core of MachInt iw -> StInt iw
 433       MachLitLit s _ -> litLitToStix (_UNPK_ s)
 434       MachFloat d    -> StDouble d
 435       MachDouble d   -> StDouble d
 436       _ -> panic "amodeToStix:core literal"
 437
 438 amodeToStix (CLitLit s _)
 439    = litLitToStix (_UNPK_ s)
 440
 441 amodeToStix (CMacroExpr _ macro [arg])
 442   = case macro of
 443       ENTRY_CODE -> amodeToStix arg
 444       ARG_TAG    -> amodeToStix arg -- just an integer no. of words
 445       GET_TAG    ->
 446 #ifdef WORDS_BIGENDIAN
 447                     StPrim AndOp
 448                         [StInd WordRep (StIndex PtrRep (amodeToStix arg)
 449                                                 (StInt (toInteger (-1)))),
 450                          StInt 65535]
 451 #else
 452                     StPrim SrlOp
 453                         [StInd WordRep (StIndex PtrRep (amodeToStix arg)
 454                                                 (StInt (toInteger (-1)))),
 455                          StInt 16]
 456 #endif
 457       UPD_FRAME_UPDATEE
 458          -> StInd PtrRep (StIndex PtrRep (amodeToStix arg)
 459                                          (StInt (toInteger uF_UPDATEE)))
 460 -- XXX!!!
 461 -- GET_TAG(info_ptr) is supposed to be  get_itbl(info_ptr)->srt_len,
 462 -- which we've had to hand-code here.
 463
 464 litLitToStix :: String -> StixTree
 465 litLitToStix nm
 466   | all is_id nm = StLitLbl (text nm)
 467   | otherwise    = error ("\nlitLitToStix: can't handle `" ++ nm ++ "'\n"
 468                            ++ "suggested workaround: use flag -fvia-C\n")
 469
 470   where is_id c = isAlphaNum c || c == '_'
 471 \end{code}
 472
 473 Sizes of the CharLike and IntLike closures that are arranged as arrays
 474 in the data segment.  (These are in bytes.)
 475
 476 \begin{code}
 477 -- The INTLIKE base pointer
 478
 479 intLikePtr :: StixTree
 480
 481 intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closure"))
 482
 483 -- The CHARLIKE base
 484
 485 charLike :: StixTree
 486
 487 charLike = sStLitLbl SLIT("CHARLIKE_closure")
 488
 489 -- Trees for the ErrorIOPrimOp
 490
 491 topClosure, errorIO :: StixTree
 492
 493 topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
 494 errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))
 495
 496 mutArrPtrsFrozen_info = sStLitLbl SLIT("MUT_ARR_PTRS_FROZEN_info")
 497
 498 charLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
 499 intLikeSize  = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
 500 \end{code}
 501
 502
 503 \begin{code}
 504 save_thread_state
 505    = getUniqueUs   `thenUs` \tso_uq ->
 506      let tso = StReg (StixTemp tso_uq ThreadIdRep) in
 507      returnUs (\xs ->
 508         StAssign ThreadIdRep tso stgCurrentTSO :
 509         StAssign PtrRep
 510            (StInd PtrRep (StPrim IntAddOp
 511                 [tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]))
 512            stgSp :
 513         StAssign PtrRep
 514            (StInd PtrRep (StPrim IntAddOp
 515                 [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))]))
 516            stgSu :
 517         StAssign PtrRep
 518            (StInd PtrRep (StPrim IntAddOp
 519                 [tso, StInt (toInteger (TSO_SPLIM*BYTES_PER_WORD))]))
 520            stgSpLim :
 521         StAssign PtrRep
 522            (StInd PtrRep (StPrim IntAddOp
 523                 [stgCurrentNursery,
 524                  StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]))
 525            (StPrim IntAddOp [stgHp, StInt (toInteger (1 * BYTES_PER_WORD))]) :
 526         xs
 527      )
 528
 529 load_thread_state
 530    = getUniqueUs   `thenUs` \tso_uq ->
 531      let tso = StReg (StixTemp tso_uq ThreadIdRep) in
 532      returnUs (\xs ->
 533         StAssign ThreadIdRep tso stgCurrentTSO :
 534         StAssign PtrRep stgSp
 535            (StInd PtrRep (StPrim IntAddOp
 536                 [tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])) :
 537         StAssign PtrRep stgSu
 538            (StInd PtrRep (StPrim IntAddOp
 539                 [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))])) :
 540         StAssign PtrRep stgSpLim
 541            (StInd PtrRep (StPrim IntAddOp
 542                 [tso, StInt (toInteger (TSO_SPLIM*BYTES_PER_WORD))])) :
 543         StAssign PtrRep stgHp
 544            (StPrim IntSubOp [
 545               StInd PtrRep (StPrim IntAddOp
 546                 [stgCurrentNursery,
 547                  StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]),
 548               StInt (toInteger (1 * BYTES_PER_WORD))
 549             ]) :
 550         StAssign PtrRep stgHpLim
 551            (StPrim IntAddOp [
 552               StInd PtrRep (StPrim IntAddOp
 553                 [stgCurrentNursery,
 554                  StInt (toInteger (BDESCR_START * BYTES_PER_WORD))]),
 555               StInt (toInteger (bLOCK_SIZE - (1 * BYTES_PER_WORD)))
 556             ]) :
 557         xs
 558      )
 559 \end{code}