ghc/compiler/nativeGen/StixMacro.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1996
   3 %
   4
   5 \begin{code}
   6 #include "HsVersions.h"
   7
   8 module StixMacro ( macroCode, heapCheck ) where
   9
  10 IMP_Ubiq(){-uitious-}
  11 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
  12 IMPORT_DELOOPER(NcgLoop)                ( amodeToStix )
  13 #else
  14 import {-# SOURCE #-} StixPrim ( amodeToStix )
  15 #endif
  16
  17 import MachMisc
  18
  19 -- In 2.0x we import Addr via GlaExts, so we better hide the other one here.
  20 #if __GLASGOW_HASKELL__ >= 202
  21 import MachRegs hiding (Addr)
  22 #else
  23 import MachRegs
  24 #endif
  25
  26 import AbsCSyn          ( CStmtMacro(..), MagicId(..), mkIntCLit, CAddrMode )
  27 import Constants        ( uF_RET, uF_SUA, uF_SUB, uF_UPDATEE,
  28                           sTD_UF_SIZE
  29                         )
  30 import OrdList          ( OrdList )
  31 import PrimOp           ( PrimOp(..) )
  32 import PrimRep          ( PrimRep(..) )
  33 import Stix
  34 import UniqSupply       ( returnUs, thenUs, SYN_IE(UniqSM) )
  35 \end{code}
  36
  37 The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on
  38 the A stack, and perform a tail call to @UpdatePAP@ if the arguments are
  39 not there.  The @_LOAD_NODE@ version also loads R1 with an appropriate
  40 closure address.
  41
  42 \begin{code}
  43 mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh)
  44 mkIntCLit_3 = mkIntCLit 3
  45
  46 macroCode
  47     :: CStmtMacro           -- statement macro
  48     -> [CAddrMode]          -- args
  49     -> UniqSM StixTreeList
  50
  51 macroCode ARGS_CHK_A_LOAD_NODE args
  52   = getUniqLabelNCG                                     `thenUs` \ ulbl ->
  53     let
  54           [words, lbl] = map amodeToStix args
  55           temp = StIndex PtrRep stgSpA words
  56           test = StPrim AddrGeOp [stgSuA, temp]
  57           cjmp = StCondJump ulbl test
  58           assign = StAssign PtrRep stgNode lbl
  59           join = StLabel ulbl
  60     in
  61     returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
  62
  63 macroCode ARGS_CHK_A [words]
  64   = getUniqLabelNCG                                     `thenUs` \ ulbl ->
  65     let temp = StIndex PtrRep stgSpA (amodeToStix words)
  66         test = StPrim AddrGeOp [stgSuA, temp]
  67         cjmp = StCondJump ulbl test
  68         join = StLabel ulbl
  69     in
  70     returnUs (\xs -> cjmp : updatePAP : join : xs)
  71 \end{code}
  72
  73 Like the macros above, the @ARGS_CHK_B{_LOAD_NODE}@ macros check for
  74 sufficient arguments on the B stack, and perform a tail call to
  75 @UpdatePAP@ if the arguments are not there.  The @_LOAD_NODE@ version
  76 also loads R1 with an appropriate closure address.  Note that the
  77 directions are swapped relative to the A stack.
  78
  79 \begin{code}
  80 macroCode ARGS_CHK_B_LOAD_NODE args
  81   = getUniqLabelNCG                                     `thenUs` \ ulbl ->
  82     let
  83         [words, lbl] = map amodeToStix args
  84         temp = StIndex PtrRep stgSuB (StPrim IntNegOp [words])
  85         test = StPrim AddrGeOp [stgSpB, temp]
  86         cjmp = StCondJump ulbl test
  87         assign = StAssign PtrRep stgNode lbl
  88         join = StLabel ulbl
  89     in
  90     returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
  91
  92 macroCode ARGS_CHK_B [words]
  93   = getUniqLabelNCG                                     `thenUs` \ ulbl ->
  94     let
  95         temp = StIndex PtrRep stgSuB (StPrim IntNegOp [amodeToStix words])
  96         test = StPrim AddrGeOp [stgSpB, temp]
  97         cjmp = StCondJump ulbl test
  98         join = StLabel ulbl
  99     in
 100     returnUs (\xs -> cjmp : updatePAP : join : xs)
 101 \end{code}
 102
 103 The @HEAP_CHK@ macro checks to see that there are enough words
 104 available in the heap (before reaching @HpLim@).  When a heap check
 105 fails, it has to call @PerformGC@ via the @PerformGC_wrapper@.  The
 106 call wrapper saves all of our volatile registers so that we don't have
 107 to.
 108
 109 Since there are @HEAP_CHK@s buried at unfortunate places in the
 110 integer primOps, this is just a wrapper.
 111
 112 \begin{code}
 113 macroCode HEAP_CHK args
 114   = let [liveness,words,reenter] = map amodeToStix args
 115     in
 116     heapCheck liveness words reenter
 117 \end{code}
 118
 119 The @STK_CHK@ macro checks for enough space on the stack between @SpA@
 120 and @SpB@.  A stack check can be complicated in the parallel world,
 121 but for the sequential case, we just need to ensure that we have
 122 enough space to continue.  Not that @_StackOverflow@ doesn't return,
 123 so we don't have to @callWrapper@ it.
 124
 125 \begin{code}
 126 macroCode STK_CHK [liveness, aWords, bWords, spa, spb, prim, reenter]
 127   =
 128 {- Need to check to see if we are compiling with stack checks
 129    getUniqLabelNCG                                      `thenUs` \ ulbl ->
 130     let words = StPrim IntNegOp
 131             [StPrim IntAddOp [amodeToStix aWords, amodeToStix bWords]]
 132         temp = StIndex PtrRep stgSpA words
 133         test = StPrim AddrGtOp [temp, stgSpB]
 134         cjmp = StCondJump ulbl test
 135         join = StLabel ulbl
 136     in
 137         returnUs (\xs -> cjmp : stackOverflow : join : xs)
 138 -}
 139     returnUs id
 140 \end{code}
 141
 142 @UPD_CAF@ involves changing the info pointer of the closure, adding an
 143 indirection, and putting the new CAF on a linked list for the storage
 144 manager.
 145
 146 \begin{code}
 147 macroCode UPD_CAF args
 148   = let
 149         [cafptr,bhptr] = map amodeToStix args
 150         w0 = StInd PtrRep cafptr
 151         w1 = StInd PtrRep (StIndex PtrRep cafptr (StInt 1))
 152         w2 = StInd PtrRep (StIndex PtrRep cafptr (StInt 2))
 153         a1 = StAssign PtrRep w0 caf_info
 154         a2 = StAssign PtrRep w1 smCAFlist
 155         a3 = StAssign PtrRep w2 bhptr
 156         a4 = StAssign PtrRep smCAFlist cafptr
 157     in
 158     returnUs (\xs -> a1 : a2 : a3 : a4 : xs)
 159 \end{code}
 160
 161 @UPD_IND@ is complicated by the fact that we are supporting the
 162 Appel-style garbage collector by default.  This means some extra work
 163 if we update an old generation object.
 164
 165 \begin{code}
 166 macroCode UPD_IND args
 167   = getUniqLabelNCG                                     `thenUs` \ ulbl ->
 168     let
 169         [updptr, heapptr] = map amodeToStix args
 170         test = StPrim AddrGtOp [updptr, smOldLim]
 171         cjmp = StCondJump ulbl test
 172         updRoots = StAssign PtrRep smOldMutables updptr
 173         join = StLabel ulbl
 174         upd0 = StAssign PtrRep (StInd PtrRep updptr) ind_info
 175         upd1 = StAssign PtrRep (StInd PtrRep
 176                 (StIndex PtrRep updptr (StInt 1))) smOldMutables
 177         upd2 = StAssign PtrRep (StInd PtrRep
 178                 (StIndex PtrRep updptr (StInt 2))) heapptr
 179     in
 180     returnUs (\xs -> cjmp : upd1 : updRoots : join : upd0 : upd2 : xs)
 181 \end{code}
 182
 183 @UPD_INPLACE_NOPTRS@ is only needed for ticky-ticky profiling.
 184
 185 \begin{code}
 186 macroCode UPD_INPLACE_NOPTRS args = returnUs id
 187 \end{code}
 188
 189 @UPD_INPLACE_PTRS@ is complicated by the fact that we are supporting
 190 the Appel-style garbage collector by default.  This means some extra
 191 work if we update an old generation object.
 192
 193 \begin{code}
 194 macroCode UPD_INPLACE_PTRS [liveness]
 195   = getUniqLabelNCG                                     `thenUs` \ ulbl ->
 196     let cjmp = StCondJump ulbl testOldLim
 197         testOldLim = StPrim AddrGtOp [stgNode, smOldLim]
 198         join = StLabel ulbl
 199         updUpd0 = StAssign PtrRep (StInd PtrRep stgNode) ind_info
 200         updUpd1 = StAssign PtrRep (StInd PtrRep
 201                     (StIndex PtrRep stgNode (StInt 1))) smOldMutables
 202         updUpd2 = StAssign PtrRep (StInd PtrRep
 203                     (StIndex PtrRep stgNode (StInt 2))) hpBack2
 204         hpBack2 = StIndex PtrRep stgHp (StInt (-2))
 205         updOldMutables = StAssign PtrRep smOldMutables stgNode
 206         updUpdReg = StAssign PtrRep stgNode hpBack2
 207     in
 208     macroCode HEAP_CHK [liveness, mkIntCLit_3, mkIntCLit_0]
 209                                                     `thenUs` \ heap_chk ->
 210     returnUs (\xs -> (cjmp :
 211                         heap_chk (updUpd0 : updUpd1 : updUpd2 :
 212                                     updOldMutables : updUpdReg : join : xs)))
 213 \end{code}
 214
 215 @UPD_BH_UPDATABLE@ is only used when running concurrent threads (in
 216 the sequential case, the GC takes care of this).  However, we do need
 217 to handle @UPD_BH_SINGLE_ENTRY@ in all cases.
 218
 219 \begin{code}
 220 macroCode UPD_BH_UPDATABLE args = returnUs id
 221
 222 macroCode UPD_BH_SINGLE_ENTRY [arg]
 223   = let
 224         update = StAssign PtrRep (StInd PtrRep (amodeToStix arg)) bh_info
 225     in
 226     returnUs (\xs -> update : xs)
 227 \end{code}
 228
 229 Push a four word update frame on the stack and slide the Su[AB]
 230 registers to the current Sp[AB] locations.
 231
 232 \begin{code}
 233 macroCode PUSH_STD_UPD_FRAME args
 234   = let
 235         [bhptr, aWords, bWords] = map amodeToStix args
 236         frame n = StInd PtrRep
 237             (StIndex PtrRep stgSpB (StPrim IntAddOp
 238                 [bWords, StInt (toInteger (sTD_UF_SIZE - n))]))
 239
 240         a1 = StAssign PtrRep (frame uF_RET) stgRetReg
 241         a2 = StAssign PtrRep (frame uF_SUB) stgSuB
 242         a3 = StAssign PtrRep (frame uF_SUA) stgSuA
 243         a4 = StAssign PtrRep (frame uF_UPDATEE) bhptr
 244
 245         updSuB = StAssign PtrRep
 246             stgSuB (StIndex PtrRep stgSpB (StPrim IntAddOp
 247                 [bWords, StInt (toInteger sTD_UF_SIZE)]))
 248         updSuA = StAssign PtrRep
 249             stgSuA (StIndex PtrRep stgSpA (StPrim IntNegOp [aWords]))
 250     in
 251     returnUs (\xs -> a1 : a2 : a3 : a4 : updSuB : updSuA : xs)
 252 \end{code}
 253
 254 Pop a standard update frame.
 255
 256 \begin{code}
 257 macroCode POP_STD_UPD_FRAME args
 258   = let
 259         frame n = StInd PtrRep (StIndex PtrRep stgSpB (StInt (toInteger (-n))))
 260
 261         grabRet = StAssign PtrRep stgRetReg (frame uF_RET)
 262         grabSuB = StAssign PtrRep stgSuB    (frame uF_SUB)
 263         grabSuA = StAssign PtrRep stgSuA    (frame uF_SUA)
 264
 265         updSpB = StAssign PtrRep
 266             stgSpB (StIndex PtrRep stgSpB (StInt (toInteger (-sTD_UF_SIZE))))
 267     in
 268     returnUs (\xs -> grabRet : grabSuB : grabSuA : updSpB : xs)
 269 \end{code}
 270
 271 This one only applies if we have a machine register devoted to TagReg.
 272 \begin{code}
 273 macroCode SET_TAG [tag]
 274   = let set_tag = StAssign IntRep stgTagReg (amodeToStix tag)
 275     in
 276     case stgReg TagReg of
 277       Always _ -> returnUs id
 278       Save   _ -> returnUs (\ xs -> set_tag : xs)
 279 \end{code}
 280
 281 Do the business for a @HEAP_CHK@, having converted the args to Trees
 282 of StixOp.
 283
 284 \begin{code}
 285 heapCheck
 286     :: StixTree         -- liveness
 287     -> StixTree         -- words needed
 288     -> StixTree         -- always reenter node? (boolean)
 289     -> UniqSM StixTreeList
 290
 291 heapCheck liveness words reenter
 292   = getUniqLabelNCG                                     `thenUs` \ ulbl ->
 293     let newHp = StIndex PtrRep stgHp words
 294         assign = StAssign PtrRep stgHp newHp
 295         test = StPrim AddrLeOp [stgHp, stgHpLim]
 296         cjmp = StCondJump ulbl test
 297         arg = StPrim IntAddOp [StPrim IntMulOp [words, StInt 256], liveness]
 298         -- ToDo: Overflow?  (JSM)
 299         gc = StCall SLIT("PerformGC_wrapper") VoidRep [arg]
 300         join = StLabel ulbl
 301     in
 302     returnUs (\xs -> assign : cjmp : gc : join : xs)
 303 \end{code}
 304
 305 Let's make sure that these CAFs are lifted out, shall we?
 306
 307 \begin{code}
 308 -- Some common labels
 309
 310 bh_info, caf_info, ind_info :: StixTree
 311
 312 bh_info   = sStLitLbl SLIT("BH_SINGLE_info")
 313 caf_info  = sStLitLbl SLIT("Caf_info")
 314 ind_info  = sStLitLbl SLIT("Ind_info")
 315
 316 -- Some common call trees
 317
 318 updatePAP, stackOverflow :: StixTree
 319
 320 updatePAP     = StJump (sStLitLbl SLIT("UpdatePAP"))
 321 stackOverflow = StCall SLIT("StackOverflow") VoidRep []
 322 \end{code}