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
 118 -- a bit late to catch this here..
 119 foreignCallCode _ DNCall{} _
 120  = panic "foreignCallCode: .NET interop not supported via NCG; compile with -fvia-C"
 121 \end{code}
 122
 123 %************************************************************************
 124 %*                                                                      *
 125 \subsubsection{Code for @CAddrMode@s}
 126 %*                                                                      *
 127 %************************************************************************
 128
 129 When a character is fetched from a mixed type location, we have to do
 130 an extra cast.  This is reflected in amodeCode', which is for rhs
 131 amodes that might possibly need the extra cast.
 132
 133 \begin{code}
 134 amodeToStix, amodeToStix' :: CAddrMode -> StixExpr
 135
 136 amodeToStix'{-'-} am@(CVal rr CharRep)
 137   | mixedTypeLocn am = StMachOp MO_NatS_to_32U [amodeToStix am]
 138   | otherwise        = amodeToStix am
 139 amodeToStix' am
 140   = amodeToStix am
 141
 142 -----------
 143 amodeToStix am@(CVal rr CharRep)
 144   | mixedTypeLocn am
 145   = StInd IntRep (amodeToStix (CAddr rr))
 146
 147 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
 148
 149 amodeToStix (CAddr (SpRel off))
 150   = StIndex PtrRep (StReg stgSp) (StInt (toInteger (iBox off)))
 151
 152 amodeToStix (CAddr (HpRel off))
 153   = StIndex IntRep (StReg stgHp) (StInt (toInteger (- (iBox off))))
 154
 155 amodeToStix (CAddr (NodeRel off))
 156   = StIndex IntRep (StReg stgNode) (StInt (toInteger (iBox off)))
 157
 158 amodeToStix (CAddr (CIndex base off pk))
 159   = StIndex pk (amodeToStix base) (amodeToStix off)
 160
 161 amodeToStix (CReg magic)    = StReg (StixMagicId magic)
 162 amodeToStix (CTemp uniq pk) = StReg (StixTemp (StixVReg uniq pk))
 163
 164 amodeToStix (CLbl      lbl _) = StCLbl lbl
 165
 166  -- For CharLike and IntLike, we attempt some trivial constant-folding here.
 167
 168 amodeToStix (CCharLike (CLit (MachChar c)))
 169   = StIndex Word8Rep cHARLIKE_closure (StInt (toInteger off))
 170   where
 171     off = charLikeSize * (c - mIN_CHARLIKE)
 172
 173 amodeToStix (CCharLike x)
 174   = panic "amodeToStix.CCharLike"
 175
 176 amodeToStix (CIntLike (CLit (MachInt i)))
 177   = StIndex Word8Rep iNTLIKE_closure (StInt (toInteger off))
 178   where
 179     off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
 180
 181 amodeToStix (CIntLike x)
 182   = panic "amodeToStix.CIntLike"
 183
 184 amodeToStix (CLit core)
 185   = case core of
 186       MachChar c     -> StInt (toInteger c)
 187       MachStr s      -> StString s
 188       MachNullAddr   -> StInt 0
 189       MachInt i      -> StInt i
 190       MachWord w     -> case word2IntLit core of MachInt iw -> StInt iw
 191       MachLitLit s _ -> litLitErr
 192                                                        -- dreadful, but rare.
 193       MachLabel l (Just x) -> StCLbl (mkForeignLabel (mkFastString (unpackFS l ++ '@':show x)) False)
 194       MachLabel l _        -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-})
 195       MachFloat d    -> StFloat d
 196       MachDouble d   -> StDouble d
 197       _ -> panic "amodeToStix:core literal"
 198
 199 amodeToStix (CMacroExpr _ macro [arg])
 200   = let
 201         arg_amode = amodeToStix arg
 202     in
 203     case macro of
 204       ENTRY_CODE -> arg_amode
 205       ARG_TAG    -> arg_amode -- just an integer no. of words
 206       GET_TAG    ->
 207 #ifdef WORDS_BIGENDIAN
 208                     StMachOp MO_Nat_And
 209                         [StInd WordRep (StIndex PtrRep arg_amode
 210                                                 (StInt (toInteger (-1)))),
 211                          StInt 65535]
 212 #else
 213                     StMachOp MO_Nat_Shr
 214                         [StInd WordRep (StIndex PtrRep arg_amode
 215                                                 (StInt (toInteger (-1)))),
 216                          StInt 16]
 217 #endif
 218       UPD_FRAME_UPDATEE
 219          -> StInd PtrRep (StIndex PtrRep arg_amode
 220                                          (StInt (toInteger uF_UPDATEE)))
 221
 222       BYTE_ARR_CTS -> StIndex IntRep arg_amode arrWordsHS
 223       PTRS_ARR_CTS -> StIndex PtrRep arg_amode arrPtrsHS
 224       ForeignObj_CLOSURE_DATA -> StInd PtrRep (StIndex PtrRep arg_amode fixedHS)
 225
 226
 227 amodeToStix other
 228    = pprPanic "StixPrim.amodeToStix" (pprAmode other)
 229
 230 litLitErr
 231    = ncgPrimopMoan "native code generator can't handle lit-lits" empty
 232 \end{code}
 233
 234 Sizes of the CharLike and IntLike closures that are arranged as arrays
 235 in the data segment.  (These are in bytes.)
 236
 237 \begin{code}
 238 -- The INTLIKE base pointer
 239
 240 iNTLIKE_closure :: StixExpr
 241 iNTLIKE_closure = StCLbl mkIntlikeClosureLabel
 242
 243 -- The CHARLIKE base
 244
 245 cHARLIKE_closure :: StixExpr
 246 cHARLIKE_closure = StCLbl mkCharlikeClosureLabel
 247
 248 mutArrPtrsFrozen_info = StCLbl mkMAP_FROZEN_infoLabel
 249
 250 -- these are the sizes of charLike and intLike closures, in _bytes_.
 251 charLikeSize = (fixedHdrSize + 1) * (getPrimRepSizeInBytes PtrRep)
 252 intLikeSize  = (fixedHdrSize + 1) * (getPrimRepSizeInBytes PtrRep)
 253 \end{code}
 254
 255
 256 \begin{code}
 257 save_thread_state
 258    = getUniqueUs   `thenUs` \ tso_uq ->
 259      let tso = StixTemp (StixVReg tso_uq PtrRep) in
 260      returnUs (\xs ->
 261         StAssignReg PtrRep tso (StReg stgCurrentTSO)
 262         : StAssignMem PtrRep
 263              (StMachOp MO_Nat_Add
 264                        [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])
 265              (StReg stgSp)
 266         : StAssignMem PtrRep
 267              (StMachOp MO_Nat_Add
 268                        [StReg stgCurrentNursery,
 269                         StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))])
 270              (StMachOp MO_Nat_Add
 271                        [StReg stgHp, StInt (toInteger (1 * BYTES_PER_WORD))])
 272         : xs
 273      )
 274
 275 load_thread_state
 276    = getUniqueUs   `thenUs` \ tso_uq ->
 277      let tso = StixTemp (StixVReg tso_uq PtrRep) in
 278      returnUs (\xs ->
 279         StAssignReg PtrRep tso (StReg stgCurrentTSO)
 280         : StAssignReg PtrRep
 281              stgSp
 282              (StInd PtrRep
 283                   (StMachOp MO_Nat_Add
 284                             [StReg tso, StInt (toInteger (TSO_SP*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}