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