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
 144 primCode lhs@[_] IndexArrayOp args
 145   = primCode lhs ReadArrayOp args
 146
 147 primCode [lhs] ReadArrayOp [obj, ix]
 148   = let
 149         lhs' = amodeToStix lhs
 150         obj' = amodeToStix obj
 151         ix' = amodeToStix ix
 152         base = StIndex IntRep obj' arrHS
 153         assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
 154     in
 155     returnUs (\xs -> assign : xs)
 156
 157 primCode [] WriteArrayOp [obj, ix, v]
 158   = let
 159         obj' = amodeToStix obj
 160         ix' = amodeToStix ix
 161         v' = amodeToStix v
 162         base = StIndex IntRep obj' arrHS
 163         assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
 164     in
 165     returnUs (\xs -> assign : xs)
 166
 167 primCode lhs@[_] (IndexByteArrayOp pk) args
 168   = primCode lhs (ReadByteArrayOp pk) args
 169
 170 -- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
 171
 172 primCode [lhs] (ReadByteArrayOp pk) [obj, ix]
 173   = let
 174         lhs' = amodeToStix lhs
 175         obj' = amodeToStix obj
 176         ix' = amodeToStix ix
 177         base = StIndex IntRep obj' arrHS
 178         assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
 179     in
 180     returnUs (\xs -> assign : xs)
 181
 182 primCode [lhs] (IndexOffAddrOp pk) [obj, ix]
 183   = let
 184         lhs' = amodeToStix lhs
 185         obj' = amodeToStix obj
 186         ix' = amodeToStix ix
 187         assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
 188     in
 189     returnUs (\xs -> assign : xs)
 190
 191 primCode [lhs] (IndexOffForeignObjOp pk) [obj, ix]
 192   = let
 193         lhs' = amodeToStix lhs
 194         obj' = amodeToStix obj
 195         ix' = amodeToStix ix
 196         obj'' = StIndex PtrRep obj' fixedHS
 197         assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix'))
 198     in
 199     returnUs (\xs -> assign : xs)
 200
 201 primCode [] (WriteByteArrayOp pk) [obj, ix, v]
 202   = let
 203         obj' = amodeToStix obj
 204         ix' = amodeToStix ix
 205         v' = amodeToStix v
 206         base = StIndex IntRep obj' arrHS
 207         assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
 208     in
 209     returnUs (\xs -> assign : xs)
 210 \end{code}
 211
 212 \begin{code}
 213 --primCode lhs (CCallOp fn is_asm may_gc) rhs
 214 primCode lhs (CCallOp (Left fn) is_asm may_gc cconv) rhs
 215   | is_asm = error "ERROR: Native code generator can't handle casm"
 216   | may_gc = error "ERROR: Native code generator can't handle _ccall_GC_\n"
 217   | otherwise
 218   = case lhs of
 219       [] -> returnUs (\xs -> (StCall fn cconv VoidRep args) : xs)
 220       [lhs] ->
 221           let lhs' = amodeToStix lhs
 222               pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
 223               call = StAssign pk lhs' (StCall fn cconv pk args)
 224           in
 225               returnUs (\xs -> call : xs)
 226   where
 227     args = map amodeCodeForCCall rhs
 228     amodeCodeForCCall x =
 229         let base = amodeToStix' x
 230         in
 231             case getAmodeRep x of
 232               ArrayRep      -> StIndex PtrRep base arrHS
 233               ByteArrayRep  -> StIndex IntRep base arrHS
 234               ForeignObjRep -> StIndex PtrRep base fixedHS
 235               _ -> base
 236 \end{code}
 237
 238 Now the more mundane operations.
 239
 240 \begin{code}
 241 primCode lhs op rhs
 242   = let
 243         lhs' = map amodeToStix  lhs
 244         rhs' = map amodeToStix' rhs
 245         pk   = getAmodeRep (head lhs)
 246     in
 247     returnUs (\ xs -> simplePrim pk lhs' op rhs' : xs)
 248 \end{code}
 249
 250 \begin{code}
 251 simpleCoercion
 252       :: PrimRep
 253       -> CAddrMode
 254       -> CAddrMode
 255       -> UniqSM StixTreeList
 256
 257 simpleCoercion pk lhs rhs
 258   = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
 259 \end{code}
 260
 261 Here we try to rewrite primitives into a form the code generator can
 262 understand.  Any primitives not handled here must be handled at the
 263 level of the specific code generator.
 264
 265 \begin{code}
 266 simplePrim
 267     :: PrimRep          -- Rep of first destination
 268     -> [StixTree]       -- Destinations
 269     -> PrimOp
 270     -> [StixTree]
 271     -> StixTree
 272 \end{code}
 273
 274 Now look for something more conventional.
 275
 276 \begin{code}
 277 simplePrim pk [lhs] op rest  = StAssign pk lhs (StPrim op rest)
 278 simplePrim pk as    op bs    = simplePrim_error op
 279
 280 simplePrim_error op
 281     = 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")
 282 \end{code}
 283
 284 %---------------------------------------------------------------------
 285
 286 Here we generate the Stix code for CAddrModes.
 287
 288 When a character is fetched from a mixed type location, we have to do
 289 an extra cast.  This is reflected in amodeCode', which is for rhs
 290 amodes that might possibly need the extra cast.
 291
 292 \begin{code}
 293 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
 294
 295 amodeToStix'{-'-} am@(CVal rr CharRep)
 296     | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
 297     | otherwise = amodeToStix am
 298
 299 amodeToStix' am = amodeToStix am
 300
 301 -----------
 302 amodeToStix am@(CVal rr CharRep)
 303   | mixedTypeLocn am
 304   = StInd IntRep (amodeToStix (CAddr rr))
 305
 306 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
 307
 308 amodeToStix (CAddr (SpRel off))
 309   = StIndex PtrRep stgSp (StInt (toInteger IBOX(off)))
 310
 311 amodeToStix (CAddr (HpRel off))
 312   = StIndex IntRep stgHp (StInt (toInteger (- IBOX(off))))
 313
 314 amodeToStix (CAddr (NodeRel off))
 315   = StIndex IntRep stgNode (StInt (toInteger IBOX(off)))
 316
 317 amodeToStix (CReg magic)    = StReg (StixMagicId magic)
 318 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
 319
 320 amodeToStix (CLbl      lbl _) = StCLbl lbl
 321
 322 amodeToStix (CTableEntry base off pk)
 323   = StInd pk (StIndex pk (amodeToStix base) (amodeToStix off))
 324
 325  -- For CharLike and IntLike, we attempt some trivial constant-folding here.
 326
 327 amodeToStix (CCharLike (CLit (MachChar c)))
 328   = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closure+")) (int off))
 329   where
 330     off = charLikeSize * ord c
 331
 332 amodeToStix (CCharLike x)
 333   = StIndex PtrRep charLike off
 334   where
 335     off = StPrim IntMulOp [amodeToStix x, StInt (toInteger (fixedHdrSize+1))]
 336
 337 amodeToStix (CIntLike (CLit (MachInt i _)))
 338   = StLitLbl ((<>) (ptext SLIT("INTLIKE_closure+")) (int off))
 339   where
 340     off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
 341
 342 amodeToStix (CIntLike x)
 343   = panic "CIntLike"
 344
 345  -- A CString is just a (CLit . MachStr)
 346 amodeToStix (CString s) = StString s
 347
 348 amodeToStix (CLit core)
 349   = case core of
 350       MachChar c     -> StInt (toInteger (ord c))
 351       MachStr s      -> StString s
 352       MachAddr a     -> StInt a
 353       MachInt i _    -> StInt (toInteger i)
 354       MachLitLit s _ -> StLitLit s
 355       MachFloat d    -> StDouble d
 356       MachDouble d   -> StDouble d
 357       _ -> panic "amodeToStix:core literal"
 358
 359  -- A CLitLit is just a (CLit . MachLitLit)
 360 amodeToStix (CLitLit s _) = StLitLit s
 361
 362 amodeToStix (CMacroExpr _ macro [arg])
 363   = case macro of
 364       ENTRY_CODE -> amodeToStix arg
 365       ARG_TAG    -> amodeToStix arg -- just an integer no. of words
 366       GET_TAG    -> StPrim SrlOp
 367                         [StInd WordRep (StPrim IntSubOp [amodeToStix arg,
 368                                                          StInt 1]),
 369                          StInt 16]
 370
 371 -- XXX!!!
 372 -- GET_TAG(info_ptr) is supposed to be  get_itbl(info_ptr)->srt_len,
 373 -- which we've had to hand-code here.
 374 \end{code}
 375
 376 Sizes of the CharLike and IntLike closures that are arranged as arrays
 377 in the data segment.  (These are in bytes.)
 378
 379 \begin{code}
 380 -- The INTLIKE base pointer
 381
 382 intLikePtr :: StixTree
 383
 384 intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closure"))
 385
 386 -- The CHARLIKE base
 387
 388 charLike :: StixTree
 389
 390 charLike = sStLitLbl SLIT("CHARLIKE_closure")
 391
 392 -- Trees for the ErrorIOPrimOp
 393
 394 topClosure, errorIO :: StixTree
 395
 396 topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
 397 errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))
 398
 399 mutArrPtrsFrozen_info = sStLitLbl SLIT("MUT_ARR_PTRS_FROZEN_info")
 400
 401 charLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
 402 intLikeSize  = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
 403 \end{code}