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