ghc/compiler/nativeGen/StixMacro.lhs

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