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 Const            ( Literal(..) )
  20 import CallConv         ( cCallConv )
  21 import PrimOp           ( PrimOp(..) )
  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 primCode [lhs] UnsafeThawByteArrayOp [rhs]
 115   = simpleCoercion PtrRep lhs rhs
 116 \end{code}
 117
 118 Returning the size of (mutable) byte arrays is just
 119 an indexing operation.
 120
 121 \begin{code}
 122 primCode [lhs] SizeofByteArrayOp [rhs]
 123   = let
 124         lhs' = amodeToStix lhs
 125         rhs' = amodeToStix rhs
 126         sz   = StIndex IntRep rhs' fixedHS
 127         assign = StAssign IntRep lhs' (StInd IntRep sz)
 128     in
 129     returnUs (\xs -> assign : xs)
 130
 131 primCode [lhs] SizeofMutableByteArrayOp [rhs]
 132   = let
 133         lhs' = amodeToStix lhs
 134         rhs' = amodeToStix rhs
 135         sz   = StIndex IntRep rhs' fixedHS
 136         assign = StAssign IntRep lhs' (StInd IntRep sz)
 137     in
 138     returnUs (\xs -> assign : xs)
 139
 140 \end{code}
 141
 142 Most other array primitives translate to simple indexing.
 143
 144 \begin{code}
 145 primCode lhs@[_] IndexArrayOp args
 146   = primCode lhs ReadArrayOp args
 147
 148 primCode [lhs] ReadArrayOp [obj, ix]
 149   = let
 150         lhs' = amodeToStix lhs
 151         obj' = amodeToStix obj
 152         ix' = amodeToStix ix
 153         base = StIndex IntRep obj' arrPtrsHS
 154         assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
 155     in
 156     returnUs (\xs -> assign : xs)
 157
 158 primCode [] WriteArrayOp [obj, ix, v]
 159   = let
 160         obj' = amodeToStix obj
 161         ix' = amodeToStix ix
 162         v' = amodeToStix v
 163         base = StIndex IntRep obj' arrPtrsHS
 164         assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
 165     in
 166     returnUs (\xs -> assign : xs)
 167
 168 primCode lhs@[_] (IndexByteArrayOp pk) args
 169   = primCode lhs (ReadByteArrayOp pk) args
 170
 171 -- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
 172
 173 primCode [lhs] (ReadByteArrayOp pk) [obj, ix]
 174   = let
 175         lhs' = amodeToStix lhs
 176         obj' = amodeToStix obj
 177         ix' = amodeToStix ix
 178         base = StIndex IntRep obj' arrWordsHS
 179         assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
 180     in
 181     returnUs (\xs -> assign : xs)
 182
 183 primCode [lhs] (IndexOffAddrOp pk) [obj, ix]
 184   = let
 185         lhs' = amodeToStix lhs
 186         obj' = amodeToStix obj
 187         ix' = amodeToStix ix
 188         assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
 189     in
 190     returnUs (\xs -> assign : xs)
 191
 192 primCode [lhs] (IndexOffForeignObjOp pk) [obj, ix]
 193   = let
 194         lhs' = amodeToStix lhs
 195         obj' = amodeToStix obj
 196         ix' = amodeToStix ix
 197         obj'' = StIndex PtrRep obj' fixedHS
 198         assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix'))
 199     in
 200     returnUs (\xs -> assign : xs)
 201
 202 primCode [] (WriteByteArrayOp pk) [obj, ix, v]
 203   = let
 204         obj' = amodeToStix obj
 205         ix' = amodeToStix ix
 206         v' = amodeToStix v
 207         base = StIndex IntRep obj' arrWordsHS
 208         assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
 209     in
 210     returnUs (\xs -> assign : xs)
 211 \end{code}
 212
 213 \begin{code}
 214 --primCode lhs (CCallOp fn is_asm may_gc) rhs
 215 primCode lhs (CCallOp (Left fn) is_asm may_gc cconv) rhs
 216   | is_asm = error "ERROR: Native code generator can't handle casm"
 217   | may_gc = error "ERROR: Native code generator can't handle _ccall_GC_\n"
 218   | otherwise
 219   = case lhs of
 220       [] -> returnUs (\xs -> (StCall fn cconv VoidRep args) : xs)
 221       [lhs] ->
 222           let lhs' = amodeToStix lhs
 223               pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
 224               call = StAssign pk lhs' (StCall fn cconv pk args)
 225           in
 226               returnUs (\xs -> call : xs)
 227   where
 228     args = map amodeCodeForCCall rhs
 229     amodeCodeForCCall x =
 230         let base = amodeToStix' x
 231         in
 232             case getAmodeRep x of
 233               ArrayRep      -> StIndex PtrRep base arrPtrsHS
 234               ByteArrayRep  -> StIndex IntRep base arrWordsHS
 235               ForeignObjRep -> StIndex PtrRep base fixedHS
 236               _ -> base
 237 \end{code}
 238
 239 DataToTagOp won't work for 64-bit archs, as it is.
 240
 241 \begin{code}
 242 primCode [lhs] DataToTagOp [arg]
 243   = let lhs'        = amodeToStix lhs
 244         arg'        = amodeToStix arg
 245         infoptr     = StInd PtrRep arg'
 246         word_32     = StInd WordRep (StIndex PtrRep infoptr (StInt (-1)))
 247         masked_le32 = StPrim SrlOp [word_32, StInt 16]
 248         masked_be32 = StPrim AndOp [word_32, StInt 65535]
 249 #ifdef WORDS_BIGENDIAN
 250         masked      = masked_be32
 251 #else
 252         masked      = masked_le32
 253 #endif
 254         assign      = StAssign IntRep lhs' masked
 255     in
 256     returnUs (\xs -> assign : xs)
 257 \end{code}
 258
 259 MutVars are pretty simple.
 260 #define writeMutVarzh(a,v)       (P_)(((StgMutVar *)(a))->var)=(v)
 261
 262 \begin{code}
 263 primCode [] WriteMutVarOp [aa,vv]
 264    = let aa_s      = amodeToStix aa
 265          vv_s      = amodeToStix vv
 266          var_field = StIndex PtrRep aa_s fixedHS
 267          assign    = StAssign PtrRep (StInd PtrRep var_field) vv_s
 268      in
 269      returnUs (\xs -> assign : xs)
 270
 271 primCode [rr] ReadMutVarOp [aa]
 272    = let aa_s      = amodeToStix aa
 273          rr_s      = amodeToStix rr
 274          var_field = StIndex PtrRep aa_s fixedHS
 275          assign    = StAssign PtrRep rr_s (StInd PtrRep var_field)
 276      in
 277      returnUs (\xs -> assign : xs)
 278 \end{code}
 279
 280 Now the more mundane operations.
 281
 282 \begin{code}
 283 primCode lhs op rhs
 284   = let
 285         lhs' = map amodeToStix  lhs
 286         rhs' = map amodeToStix' rhs
 287         pk   = getAmodeRep (head lhs)
 288     in
 289     returnUs (\ xs -> simplePrim pk lhs' op rhs' : xs)
 290 \end{code}
 291
 292 \begin{code}
 293 simpleCoercion
 294       :: PrimRep
 295       -> CAddrMode
 296       -> CAddrMode
 297       -> UniqSM StixTreeList
 298
 299 simpleCoercion pk lhs rhs
 300   = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
 301 \end{code}
 302
 303 Here we try to rewrite primitives into a form the code generator can
 304 understand.  Any primitives not handled here must be handled at the
 305 level of the specific code generator.
 306
 307 \begin{code}
 308 simplePrim
 309     :: PrimRep          -- Rep of first destination
 310     -> [StixTree]       -- Destinations
 311     -> PrimOp
 312     -> [StixTree]
 313     -> StixTree
 314 \end{code}
 315
 316 Now look for something more conventional.
 317
 318 \begin{code}
 319 simplePrim pk [lhs] op rest  = StAssign pk lhs (StPrim op rest)
 320 simplePrim pk as    op bs    = simplePrim_error op
 321
 322 simplePrim_error op
 323     = 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")
 324 \end{code}
 325
 326 %---------------------------------------------------------------------
 327
 328 Here we generate the Stix code for CAddrModes.
 329
 330 When a character is fetched from a mixed type location, we have to do
 331 an extra cast.  This is reflected in amodeCode', which is for rhs
 332 amodes that might possibly need the extra cast.
 333
 334 \begin{code}
 335 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
 336
 337 amodeToStix'{-'-} am@(CVal rr CharRep)
 338     | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
 339     | otherwise = amodeToStix am
 340
 341 amodeToStix' am = amodeToStix am
 342
 343 -----------
 344 amodeToStix am@(CVal rr CharRep)
 345   | mixedTypeLocn am
 346   = StInd IntRep (amodeToStix (CAddr rr))
 347
 348 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
 349
 350 amodeToStix (CAddr (SpRel off))
 351   = StIndex PtrRep stgSp (StInt (toInteger IBOX(off)))
 352
 353 amodeToStix (CAddr (HpRel off))
 354   = StIndex IntRep stgHp (StInt (toInteger (- IBOX(off))))
 355
 356 amodeToStix (CAddr (NodeRel off))
 357   = StIndex IntRep stgNode (StInt (toInteger IBOX(off)))
 358
 359 amodeToStix (CAddr (CIndex base off pk))
 360   = StIndex pk (amodeToStix base) (amodeToStix off)
 361
 362 amodeToStix (CReg magic)    = StReg (StixMagicId magic)
 363 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
 364
 365 amodeToStix (CLbl      lbl _) = StCLbl lbl
 366
 367  -- For CharLike and IntLike, we attempt some trivial constant-folding here.
 368
 369 amodeToStix (CCharLike (CLit (MachChar c)))
 370   = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closure+")) (int off))
 371   where
 372     off = charLikeSize * ord c
 373
 374 amodeToStix (CCharLike x)
 375   = StIndex CharRep charLike off
 376   where
 377     off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
 378
 379 amodeToStix (CIntLike (CLit (MachInt i _)))
 380   = StLitLbl ((<>) (ptext SLIT("INTLIKE_closure+")) (int off))
 381   where
 382     off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
 383
 384 amodeToStix (CIntLike x)
 385   = panic "CIntLike"
 386
 387 amodeToStix (CLit core)
 388   = case core of
 389       MachChar c     -> StInt (toInteger (ord c))
 390       MachStr s      -> StString s
 391       MachAddr a     -> StInt a
 392       MachInt i _    -> StInt (toInteger i)
 393       MachLitLit s _ -> {-trace (_UNPK_ s ++ "\n")-} (litLitToStix (_UNPK_ s))
 394       MachFloat d    -> StDouble d
 395       MachDouble d   -> StDouble d
 396       _ -> panic "amodeToStix:core literal"
 397
 398 amodeToStix (CLitLit s _)
 399    = litLitToStix (_UNPK_ s)
 400
 401 amodeToStix (CMacroExpr _ macro [arg])
 402   = case macro of
 403       ENTRY_CODE -> amodeToStix arg
 404       ARG_TAG    -> amodeToStix arg -- just an integer no. of words
 405       GET_TAG    ->
 406 #ifdef WORDS_BIGENDIAN
 407                     StPrim AndOp
 408                         [StInd WordRep (StIndex PtrRep (amodeToStix arg)
 409                                                 (StInt (toInteger (-1)))),
 410                          StInt 65535]
 411 #else
 412                     StPrim SrlOp
 413                         [StInd WordRep (StIndex PtrRep (amodeToStix arg)
 414                                                 (StInt (toInteger (-1)))),
 415                          StInt 16]
 416 #endif
 417       UPD_FRAME_UPDATEE
 418          -> StInd PtrRep (StIndex PtrRep (amodeToStix arg)
 419                                          (StInt (toInteger uF_UPDATEE)))
 420 -- XXX!!!
 421 -- GET_TAG(info_ptr) is supposed to be  get_itbl(info_ptr)->srt_len,
 422 -- which we've had to hand-code here.
 423
 424 litLitToStix :: String -> StixTree
 425 litLitToStix nm
 426    = case nm of
 427         "stdout" -> stixFor_stdout
 428         "stderr" -> stixFor_stderr
 429         "stdin"  -> stixFor_stdin
 430         other    -> error ("\nlitLitToStix: can't handle `" ++ nm ++ "'\n"
 431                            ++ "suggested workaround: use flag -fvia-C\n")
 432 \end{code}
 433
 434 Sizes of the CharLike and IntLike closures that are arranged as arrays
 435 in the data segment.  (These are in bytes.)
 436
 437 \begin{code}
 438 -- The INTLIKE base pointer
 439
 440 intLikePtr :: StixTree
 441
 442 intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closure"))
 443
 444 -- The CHARLIKE base
 445
 446 charLike :: StixTree
 447
 448 charLike = sStLitLbl SLIT("CHARLIKE_closure")
 449
 450 -- Trees for the ErrorIOPrimOp
 451
 452 topClosure, errorIO :: StixTree
 453
 454 topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
 455 errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))
 456
 457 mutArrPtrsFrozen_info = sStLitLbl SLIT("MUT_ARR_PTRS_FROZEN_info")
 458
 459 charLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
 460 intLikeSize  = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
 461 \end{code}