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