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