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