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