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