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