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