ghc/compiler/nativeGen/StixPrim.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1998
   3 %
   4
   5 \begin{code}
   6 module StixPrim ( amodeToStix, amodeToStix', foreignCallCode )
   7 where
   8
   9 #include "HsVersions.h"
  10
  11 import MachMisc
  12 import Stix
  13
  14 import PprAbsC          ( pprAmode )
  15 import AbsCSyn          hiding ( spRel )
  16 import AbsCUtils        ( getAmodeRep, mixedTypeLocn )
  17 import SMRep            ( fixedHdrSize )
  18 import Literal          ( Literal(..), word2IntLit )
  19 import MachOp           ( MachOp(..) )
  20 import PrimRep          ( PrimRep(..), getPrimRepArrayElemSize )
  21 import UniqSupply       ( returnUs, thenUs, getUniqueUs, UniqSM )
  22 import Constants        ( wORD_SIZE,
  23                           mIN_INTLIKE, mIN_CHARLIKE, uF_UPDATEE, bLOCK_SIZE,
  24                           rESERVED_STACK_WORDS )
  25 import CLabel           ( mkIntlikeClosureLabel, mkCharlikeClosureLabel,
  26                           mkMAP_FROZEN_infoLabel, mkEMPTY_MVAR_infoLabel,
  27                           mkForeignLabel )
  28 import ForeignCall      ( ForeignCall(..), CCallSpec(..), CCallTarget(..),
  29                           CCallConv(..), playSafe )
  30 import Outputable
  31 import FastTypes
  32
  33 #include "NCG.h"
  34 \end{code}
  35
  36 The main honchos here are primCode and foreignCallCode, which handle the guts of COpStmts.
  37
  38 \begin{code}
  39 foreignCallCode
  40     :: [CAddrMode]      -- results
  41     -> ForeignCall      -- op
  42     -> [CAddrMode]      -- args
  43     -> UniqSM StixStmtList
  44 \end{code}
  45
  46 %************************************************************************
  47 %*                                                                      *
  48 \subsubsection{Code for foreign calls}
  49 %*                                                                      *
  50 %************************************************************************
  51
  52 First, the dreaded @ccall@.  We can't handle @casm@s.
  53
  54 Usually, this compiles to an assignment, but when the left-hand side
  55 is empty, we just perform the call and ignore the result.
  56
  57 btw Why not let programmer use casm to provide assembly code instead
  58 of C code?  ADR
  59
  60 ToDo: saving/restoring of volatile regs around ccalls.
  61
  62 JRS, 001113: always do the call of suspendThread and resumeThread as a ccall
  63 rather than inheriting the calling convention of the thing which we're really
  64 calling.
  65
  66 \begin{code}
  67 foreignCallCode lhs call@(CCall (CCallSpec ctarget cconv safety)) rhs
  68
  69   | not (playSafe safety)
  70   = returnUs (\xs -> ccall : xs)
  71
  72   | otherwise
  73   = save_thread_state   `thenUs` \ save ->
  74     load_thread_state   `thenUs` \ load ->
  75     getUniqueUs         `thenUs` \ uniq ->
  76     let
  77        id  = StixTemp (StixVReg uniq IntRep)
  78
  79        suspend = StAssignReg IntRep id
  80                  (StCall (Left SLIT("suspendThread")) {-no:cconv-} CCallConv
  81                          IntRep [StReg stgBaseReg])
  82        resume  = StVoidable
  83                  (StCall (Left SLIT("resumeThread")) {-no:cconv-} CCallConv
  84                          VoidRep [StReg id])
  85     in
  86     returnUs (\xs -> save (suspend : ccall : resume : load xs))
  87
  88   where
  89     (cargs, stix_target)
  90         = case ctarget of
  91              StaticTarget nm -> (rhs, Left nm)
  92              DynamicTarget |  not (null rhs) -- an assertion
  93                            -> (tail rhs, Right (amodeToStix (head rhs)))
  94              CasmTarget _
  95                 -> ncgPrimopMoan "Native code generator can't handle foreign call"
  96                                  (ppr call)
  97
  98     stix_args = map amodeCodeForCCall cargs
  99     amodeCodeForCCall x =
 100         let base = amodeToStix' x
 101         in
 102             case getAmodeRep x of
 103               ArrayRep      -> StIndex PtrRep base arrPtrsHS
 104               ByteArrayRep  -> StIndex IntRep base arrWordsHS
 105               ForeignObjRep -> StInd PtrRep (StIndex PtrRep base fixedHS)
 106               other         -> base
 107
 108     ccall = case lhs of
 109       []    -> StVoidable (StCall stix_target cconv VoidRep stix_args)
 110       [lhs] -> mkStAssign pk lhs' (StCall stix_target cconv pk stix_args)
 111             where
 112                lhs' = amodeToStix lhs
 113                pk   = case getAmodeRep lhs of
 114                         FloatRep  -> FloatRep
 115                         DoubleRep -> DoubleRep
 116                         Int64Rep  -> Int64Rep
 117                         Word64Rep -> Word64Rep
 118                         other     -> IntRep
 119 \end{code}
 120
 121 %************************************************************************
 122 %*                                                                      *
 123 \subsubsection{Code for @CAddrMode@s}
 124 %*                                                                      *
 125 %************************************************************************
 126
 127 When a character is fetched from a mixed type location, we have to do
 128 an extra cast.  This is reflected in amodeCode', which is for rhs
 129 amodes that might possibly need the extra cast.
 130
 131 \begin{code}
 132 amodeToStix, amodeToStix' :: CAddrMode -> StixExpr
 133
 134 amodeToStix'{-'-} am@(CVal rr CharRep)
 135   | mixedTypeLocn am = StMachOp MO_NatS_to_32U [amodeToStix am]
 136   | otherwise        = amodeToStix am
 137 amodeToStix' am
 138   = amodeToStix am
 139
 140 -----------
 141 amodeToStix am@(CVal rr CharRep)
 142   | mixedTypeLocn am
 143   = StInd IntRep (amodeToStix (CAddr rr))
 144
 145 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
 146
 147 amodeToStix CBytesPerWord
 148   = StInt (toInteger wORD_SIZE)
 149
 150 amodeToStix (CAddr (SpRel off))
 151   = StIndex PtrRep (StReg stgSp) (StInt (toInteger (iBox off)))
 152
 153 amodeToStix (CAddr (HpRel off))
 154   = StIndex IntRep (StReg stgHp) (StInt (toInteger (- (iBox off))))
 155
 156 amodeToStix (CAddr (NodeRel off))
 157   = StIndex IntRep (StReg stgNode) (StInt (toInteger (iBox off)))
 158
 159 amodeToStix (CAddr (CIndex base off pk))
 160   = StIndex pk (amodeToStix base) (amodeToStix off)
 161
 162 amodeToStix (CReg magic)    = StReg (StixMagicId magic)
 163 amodeToStix (CTemp uniq pk) = StReg (StixTemp (StixVReg uniq pk))
 164
 165 amodeToStix (CLbl      lbl _) = StCLbl lbl
 166
 167  -- For CharLike and IntLike, we attempt some trivial constant-folding here.
 168
 169 amodeToStix (CCharLike (CLit (MachChar c)))
 170   = StIndex Word8Rep cHARLIKE_closure (StInt (toInteger off))
 171   where
 172     off = charLikeSize * (c - mIN_CHARLIKE)
 173
 174 amodeToStix (CCharLike x)
 175   = panic "amodeToStix.CCharLike"
 176
 177 amodeToStix (CIntLike (CLit (MachInt i)))
 178   = StIndex Word8Rep iNTLIKE_closure (StInt (toInteger off))
 179   where
 180     off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
 181
 182 amodeToStix (CIntLike x)
 183   = panic "amodeToStix.CIntLike"
 184
 185 amodeToStix (CLit core)
 186   = case core of
 187       MachChar c     -> StInt (toInteger c)
 188       MachStr s      -> StString s
 189       MachAddr a     -> StInt a
 190       MachInt i      -> StInt i
 191       MachWord w     -> case word2IntLit core of MachInt iw -> StInt iw
 192       MachLitLit s _ -> litLitErr
 193       MachLabel l    -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-})
 194       MachFloat d    -> StFloat d
 195       MachDouble d   -> StDouble d
 196       _ -> panic "amodeToStix:core literal"
 197
 198 amodeToStix (CMacroExpr _ macro [arg])
 199   = case macro of
 200       ENTRY_CODE -> amodeToStix arg
 201       ARG_TAG    -> amodeToStix arg -- just an integer no. of words
 202       GET_TAG    ->
 203 #ifdef WORDS_BIGENDIAN
 204                     StMachOp MO_Nat_And
 205                         [StInd WordRep (StIndex PtrRep (amodeToStix arg)
 206                                                 (StInt (toInteger (-1)))),
 207                          StInt 65535]
 208 #else
 209                     StMachOp MO_Nat_Shr
 210                         [StInd WordRep (StIndex PtrRep (amodeToStix arg)
 211                                                 (StInt (toInteger (-1)))),
 212                          StInt 16]
 213 #endif
 214       UPD_FRAME_UPDATEE
 215          -> StInd PtrRep (StIndex PtrRep (amodeToStix arg)
 216                                          (StInt (toInteger uF_UPDATEE)))
 217
 218 amodeToStix other
 219    = pprPanic "StixPrim.amodeToStix" (pprAmode other)
 220
 221 litLitErr
 222    = ncgPrimopMoan "native code generator can't handle lit-lits" empty
 223 \end{code}
 224
 225 Sizes of the CharLike and IntLike closures that are arranged as arrays
 226 in the data segment.  (These are in bytes.)
 227
 228 \begin{code}
 229 -- The INTLIKE base pointer
 230
 231 iNTLIKE_closure :: StixExpr
 232 iNTLIKE_closure = StCLbl mkIntlikeClosureLabel
 233
 234 -- The CHARLIKE base
 235
 236 cHARLIKE_closure :: StixExpr
 237 cHARLIKE_closure = StCLbl mkCharlikeClosureLabel
 238
 239 mutArrPtrsFrozen_info = StCLbl mkMAP_FROZEN_infoLabel
 240
 241 -- these are the sizes of charLike and intLike closures, in _bytes_.
 242 charLikeSize = (fixedHdrSize + 1) * (getPrimRepArrayElemSize PtrRep)
 243 intLikeSize  = (fixedHdrSize + 1) * (getPrimRepArrayElemSize PtrRep)
 244 \end{code}
 245
 246
 247 \begin{code}
 248 save_thread_state
 249    = getUniqueUs   `thenUs` \ tso_uq ->
 250      let tso = StixTemp (StixVReg tso_uq ThreadIdRep) in
 251      returnUs (\xs ->
 252         StAssignReg ThreadIdRep tso (StReg stgCurrentTSO)
 253         : StAssignMem PtrRep
 254              (StMachOp MO_Nat_Add
 255                        [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])
 256              (StReg stgSp)
 257         : StAssignMem PtrRep
 258              (StMachOp MO_Nat_Add
 259                        [StReg tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))])
 260              (StReg stgSu)
 261         : StAssignMem PtrRep
 262              (StMachOp MO_Nat_Add
 263                        [StReg stgCurrentNursery,
 264                         StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))])
 265              (StMachOp MO_Nat_Add
 266                        [StReg stgHp, StInt (toInteger (1 * BYTES_PER_WORD))])
 267         : xs
 268      )
 269
 270 load_thread_state
 271    = getUniqueUs   `thenUs` \ tso_uq ->
 272      let tso = StixTemp (StixVReg tso_uq ThreadIdRep) in
 273      returnUs (\xs ->
 274         StAssignReg ThreadIdRep tso (StReg stgCurrentTSO)
 275         : StAssignReg PtrRep
 276              stgSp
 277              (StInd PtrRep
 278                   (StMachOp MO_Nat_Add
 279                             [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]))
 280         : StAssignReg PtrRep
 281              stgSu
 282              (StInd PtrRep
 283                   (StMachOp MO_Nat_Add
 284                             [StReg tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))]))
 285         : StAssignReg PtrRep
 286              stgSpLim
 287              (StMachOp MO_Nat_Add
 288                        [StReg tso,
 289                         StInt (toInteger ((TSO_STACK + rESERVED_STACK_WORDS)
 290                                           *BYTES_PER_WORD))])
 291         : StAssignReg PtrRep
 292              stgHp
 293              (StMachOp MO_Nat_Sub
 294                        [StInd PtrRep
 295                               (StMachOp MO_Nat_Add
 296                                         [StReg stgCurrentNursery,
 297                                          StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]),
 298                         StInt (toInteger (1 * BYTES_PER_WORD))
 299                        ])
 300         : StAssignReg PtrRep
 301              stgHpLim
 302              (StIndex Word8Rep
 303                 (StInd PtrRep
 304                        (StIndex PtrRep (StReg stgCurrentNursery)
 305                                        (StInt (toInteger BDESCR_START))
 306                        )
 307                 )
 308                 (StMachOp MO_Nat_Sub
 309                    [StMachOp MO_NatU_Mul
 310                       [StInd WordRep
 311                              (StIndex PtrRep (StReg stgCurrentNursery)
 312                                              (StInt (toInteger BDESCR_BLOCKS))),
 313                        StInt (toInteger bLOCK_SIZE{-in bytes-})
 314                       ],
 315                       StInt (1 * BYTES_PER_WORD)
 316                    ]
 317                 )
 318
 319              )
 320
 321         : xs
 322      )
 323 \end{code}