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, playThreadSafe )
  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        is_threadSafe
  80         | playThreadSafe safety = 1
  81         | otherwise             = 0
  82
  83        suspend = StAssignReg IntRep id
  84                  (StCall (Left SLIT("suspendThread")) {-no:cconv-} CCallConv
  85                          IntRep [StReg stgBaseReg, StInt is_threadSafe ])
  86        resume  = StVoidable
  87                  (StCall (Left SLIT("resumeThread")) {-no:cconv-} CCallConv
  88                          VoidRep [StReg id, StInt is_threadSafe ])
  89     in
  90     returnUs (\xs -> save (suspend : ccall : resume : load xs))
  91
  92   where
  93     (cargs, stix_target)
  94         = case ctarget of
  95              StaticTarget nm -> (rhs, Left nm)
  96              DynamicTarget |  not (null rhs) -- an assertion
  97                            -> (tail rhs, Right (amodeToStix (head rhs)))
  98              CasmTarget _
  99                 -> ncgPrimopMoan "Native code generator can't handle foreign call"
 100                                  (ppr call)
 101
 102     stix_args = map amodeCodeForCCall cargs
 103     amodeCodeForCCall x =
 104         let base = amodeToStix' x
 105         in
 106             case getAmodeRep x of
 107               ArrayRep      -> StIndex PtrRep base arrPtrsHS
 108               ByteArrayRep  -> StIndex IntRep base arrWordsHS
 109               ForeignObjRep -> StInd PtrRep (StIndex PtrRep base fixedHS)
 110               other         -> base
 111
 112     ccall = case lhs of
 113       []    -> StVoidable (StCall stix_target cconv VoidRep stix_args)
 114       [lhs] -> mkStAssign pk lhs' (StCall stix_target cconv pk stix_args)
 115             where
 116                lhs' = amodeToStix lhs
 117                pk   = case getAmodeRep lhs of
 118                         FloatRep  -> FloatRep
 119                         DoubleRep -> DoubleRep
 120                         Int64Rep  -> Int64Rep
 121                         Word64Rep -> Word64Rep
 122                         other     -> IntRep
 123 \end{code}
 124
 125 %************************************************************************
 126 %*                                                                      *
 127 \subsubsection{Code for @CAddrMode@s}
 128 %*                                                                      *
 129 %************************************************************************
 130
 131 When a character is fetched from a mixed type location, we have to do
 132 an extra cast.  This is reflected in amodeCode', which is for rhs
 133 amodes that might possibly need the extra cast.
 134
 135 \begin{code}
 136 amodeToStix, amodeToStix' :: CAddrMode -> StixExpr
 137
 138 amodeToStix'{-'-} am@(CVal rr CharRep)
 139   | mixedTypeLocn am = StMachOp MO_NatS_to_32U [amodeToStix am]
 140   | otherwise        = amodeToStix am
 141 amodeToStix' am
 142   = amodeToStix am
 143
 144 -----------
 145 amodeToStix am@(CVal rr CharRep)
 146   | mixedTypeLocn am
 147   = StInd IntRep (amodeToStix (CAddr rr))
 148
 149 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
 150
 151 amodeToStix CBytesPerWord
 152   = StInt (toInteger wORD_SIZE)
 153
 154 amodeToStix (CAddr (SpRel off))
 155   = StIndex PtrRep (StReg stgSp) (StInt (toInteger (iBox off)))
 156
 157 amodeToStix (CAddr (HpRel off))
 158   = StIndex IntRep (StReg stgHp) (StInt (toInteger (- (iBox off))))
 159
 160 amodeToStix (CAddr (NodeRel off))
 161   = StIndex IntRep (StReg stgNode) (StInt (toInteger (iBox off)))
 162
 163 amodeToStix (CAddr (CIndex base off pk))
 164   = StIndex pk (amodeToStix base) (amodeToStix off)
 165
 166 amodeToStix (CReg magic)    = StReg (StixMagicId magic)
 167 amodeToStix (CTemp uniq pk) = StReg (StixTemp (StixVReg uniq pk))
 168
 169 amodeToStix (CLbl      lbl _) = StCLbl lbl
 170
 171  -- For CharLike and IntLike, we attempt some trivial constant-folding here.
 172
 173 amodeToStix (CCharLike (CLit (MachChar c)))
 174   = StIndex Word8Rep cHARLIKE_closure (StInt (toInteger off))
 175   where
 176     off = charLikeSize * (c - mIN_CHARLIKE)
 177
 178 amodeToStix (CCharLike x)
 179   = panic "amodeToStix.CCharLike"
 180
 181 amodeToStix (CIntLike (CLit (MachInt i)))
 182   = StIndex Word8Rep iNTLIKE_closure (StInt (toInteger off))
 183   where
 184     off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
 185
 186 amodeToStix (CIntLike x)
 187   = panic "amodeToStix.CIntLike"
 188
 189 amodeToStix (CLit core)
 190   = case core of
 191       MachChar c     -> StInt (toInteger c)
 192       MachStr s      -> StString s
 193       MachAddr a     -> StInt a
 194       MachInt i      -> StInt i
 195       MachWord w     -> case word2IntLit core of MachInt iw -> StInt iw
 196       MachLitLit s _ -> litLitErr
 197       MachLabel l    -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-})
 198       MachFloat d    -> StFloat d
 199       MachDouble d   -> StDouble d
 200       _ -> panic "amodeToStix:core literal"
 201
 202 amodeToStix (CMacroExpr _ macro [arg])
 203   = case macro of
 204       ENTRY_CODE -> amodeToStix arg
 205       ARG_TAG    -> amodeToStix arg -- just an integer no. of words
 206       GET_TAG    ->
 207 #ifdef WORDS_BIGENDIAN
 208                     StMachOp MO_Nat_And
 209                         [StInd WordRep (StIndex PtrRep (amodeToStix arg)
 210                                                 (StInt (toInteger (-1)))),
 211                          StInt 65535]
 212 #else
 213                     StMachOp MO_Nat_Shr
 214                         [StInd WordRep (StIndex PtrRep (amodeToStix arg)
 215                                                 (StInt (toInteger (-1)))),
 216                          StInt 16]
 217 #endif
 218       UPD_FRAME_UPDATEE
 219          -> StInd PtrRep (StIndex PtrRep (amodeToStix arg)
 220                                          (StInt (toInteger uF_UPDATEE)))
 221
 222 amodeToStix other
 223    = pprPanic "StixPrim.amodeToStix" (pprAmode other)
 224
 225 litLitErr
 226    = ncgPrimopMoan "native code generator can't handle lit-lits" empty
 227 \end{code}
 228
 229 Sizes of the CharLike and IntLike closures that are arranged as arrays
 230 in the data segment.  (These are in bytes.)
 231
 232 \begin{code}
 233 -- The INTLIKE base pointer
 234
 235 iNTLIKE_closure :: StixExpr
 236 iNTLIKE_closure = StCLbl mkIntlikeClosureLabel
 237
 238 -- The CHARLIKE base
 239
 240 cHARLIKE_closure :: StixExpr
 241 cHARLIKE_closure = StCLbl mkCharlikeClosureLabel
 242
 243 mutArrPtrsFrozen_info = StCLbl mkMAP_FROZEN_infoLabel
 244
 245 -- these are the sizes of charLike and intLike closures, in _bytes_.
 246 charLikeSize = (fixedHdrSize + 1) * (getPrimRepArrayElemSize PtrRep)
 247 intLikeSize  = (fixedHdrSize + 1) * (getPrimRepArrayElemSize PtrRep)
 248 \end{code}
 249
 250
 251 \begin{code}
 252 save_thread_state
 253    = getUniqueUs   `thenUs` \ tso_uq ->
 254      let tso = StixTemp (StixVReg tso_uq ThreadIdRep) in
 255      returnUs (\xs ->
 256         StAssignReg ThreadIdRep tso (StReg stgCurrentTSO)
 257         : StAssignMem PtrRep
 258              (StMachOp MO_Nat_Add
 259                        [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])
 260              (StReg stgSp)
 261         : StAssignMem PtrRep
 262              (StMachOp MO_Nat_Add
 263                        [StReg tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))])
 264              (StReg stgSu)
 265         : StAssignMem PtrRep
 266              (StMachOp MO_Nat_Add
 267                        [StReg stgCurrentNursery,
 268                         StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))])
 269              (StMachOp MO_Nat_Add
 270                        [StReg stgHp, StInt (toInteger (1 * BYTES_PER_WORD))])
 271         : xs
 272      )
 273
 274 load_thread_state
 275    = getUniqueUs   `thenUs` \ tso_uq ->
 276      let tso = StixTemp (StixVReg tso_uq ThreadIdRep) in
 277      returnUs (\xs ->
 278         StAssignReg ThreadIdRep tso (StReg stgCurrentTSO)
 279         : StAssignReg PtrRep
 280              stgSp
 281              (StInd PtrRep
 282                   (StMachOp MO_Nat_Add
 283                             [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]))
 284         : StAssignReg PtrRep
 285              stgSu
 286              (StInd PtrRep
 287                   (StMachOp MO_Nat_Add
 288                             [StReg tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))]))
 289         : StAssignReg PtrRep
 290              stgSpLim
 291              (StMachOp MO_Nat_Add
 292                        [StReg tso,
 293                         StInt (toInteger ((TSO_STACK + rESERVED_STACK_WORDS)
 294                                           *BYTES_PER_WORD))])
 295         : StAssignReg PtrRep
 296              stgHp
 297              (StMachOp MO_Nat_Sub
 298                        [StInd PtrRep
 299                               (StMachOp MO_Nat_Add
 300                                         [StReg stgCurrentNursery,
 301                                          StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]),
 302                         StInt (toInteger (1 * BYTES_PER_WORD))
 303                        ])
 304         : StAssignReg PtrRep
 305              stgHpLim
 306              (StIndex Word8Rep
 307                 (StInd PtrRep
 308                        (StIndex PtrRep (StReg stgCurrentNursery)
 309                                        (StInt (toInteger BDESCR_START))
 310                        )
 311                 )
 312                 (StMachOp MO_Nat_Sub
 313                    [StMachOp MO_NatU_Mul
 314                       [StInd WordRep
 315                              (StIndex PtrRep (StReg stgCurrentNursery)
 316                                              (StInt (toInteger BDESCR_BLOCKS))),
 317                        StInt (toInteger bLOCK_SIZE{-in bytes-})
 318                       ],
 319                       StInt (1 * BYTES_PER_WORD)
 320                    ]
 321                 )
 322
 323              )
 324
 325         : xs
 326      )
 327 \end{code}