ghc/compiler/nativeGen/StixMacro.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1998
   3 %
   4
   5 \begin{code}
   6 module StixMacro ( macroCode, checkCode ) where
   7
   8 #include "HsVersions.h"
   9
  10 import {-# SOURCE #-} StixPrim ( amodeToStix )
  11
  12 import MachMisc
  13 import MachRegs
  14 import AbsCSyn          ( CStmtMacro(..), MagicId(..), CAddrMode, tagreg,
  15                           CCheckMacro(..) )
  16 import Constants        ( uF_RET, uF_SU, uF_UPDATEE, uF_SIZE )
  17 import CallConv         ( cCallConv )
  18 import OrdList          ( OrdList )
  19 import PrimOp           ( PrimOp(..) )
  20 import PrimRep          ( PrimRep(..) )
  21 import Stix
  22 import UniqSupply       ( returnUs, thenUs, UniqSM )
  23 import Outputable
  24 \end{code}
  25
  26 The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on
  27 the A stack, and perform a tail call to @UpdatePAP@ if the arguments are
  28 not there.  The @_LOAD_NODE@ version also loads R1 with an appropriate
  29 closure address.
  30
  31 \begin{code}
  32 macroCode
  33     :: CStmtMacro           -- statement macro
  34     -> [CAddrMode]          -- args
  35     -> UniqSM StixTreeList
  36 \end{code}
  37
  38 -----------------------------------------------------------------------------
  39 Argument satisfaction checks.
  40
  41 \begin{code}
  42 macroCode ARGS_CHK_LOAD_NODE args
  43   = getUniqLabelNCG                                     `thenUs` \ ulbl ->
  44     let
  45           [words, lbl] = map amodeToStix args
  46           temp = StIndex PtrRep stgSp words
  47           test = StPrim AddrGeOp [stgSu, temp]
  48           cjmp = StCondJump ulbl test
  49           assign = StAssign PtrRep stgNode lbl
  50           join = StLabel ulbl
  51     in
  52     returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
  53
  54 macroCode ARGS_CHK [words]
  55   = getUniqLabelNCG                                     `thenUs` \ ulbl ->
  56     let temp = StIndex PtrRep stgSp (amodeToStix words)
  57         test = StPrim AddrGeOp [stgSu, temp]
  58         cjmp = StCondJump ulbl test
  59         join = StLabel ulbl
  60     in
  61     returnUs (\xs -> cjmp : updatePAP : join : xs)
  62 \end{code}
  63
  64 -----------------------------------------------------------------------------
  65 Updating a CAF
  66
  67 @UPD_CAF@ involves changing the info pointer of the closure, and
  68 adding an indirection.
  69
  70 \begin{code}
  71 macroCode UPD_CAF args
  72   = let
  73         [cafptr,bhptr] = map amodeToStix args
  74         w0 = StInd PtrRep cafptr
  75         w1 = StInd PtrRep (StIndex PtrRep cafptr fixedHS)
  76         blocking_queue = StInd PtrRep (StIndex PtrRep bhptr fixedHS)
  77         a1 = StAssign PtrRep w0 ind_static_info
  78         a2 = StAssign PtrRep w1 bhptr
  79         a3 = StAssign PtrRep blocking_queue end_tso_queue
  80     in
  81     returnUs (\xs -> a1 : a2 : a3 : xs)
  82 \end{code}
  83
  84 -----------------------------------------------------------------------------
  85 Blackholing
  86
  87 We do lazy blackholing: no need to overwrite thunks with blackholes
  88 the minute they're entered, as long as we do it before a context
  89 switch or garbage collection, that's ok.
  90
  91 Don't blackhole single entry closures, for the following reasons:
  92
  93         - if the compiler has decided that they won't be entered again,
  94           that probably means that nothing has a pointer to it
  95           (not necessarily true, but...)
  96
  97         - no need to blackhole for concurrency reasons, because nothing
  98           can block on the result of this computation.
  99
 100 \begin{code}
 101 macroCode UPD_BH_UPDATABLE args = returnUs id
 102
 103 macroCode UPD_BH_SINGLE_ENTRY args = returnUs id
 104 {-
 105   = let
 106         update = StAssign PtrRep (StInd PtrRep (amodeToStix arg)) bh_info
 107     in
 108     returnUs (\xs -> update : xs)
 109 -}
 110 \end{code}
 111
 112 -----------------------------------------------------------------------------
 113 Update frames
 114
 115 Push a four word update frame on the stack and slide the Su registers
 116 to the current Sp location.
 117
 118 \begin{code}
 119 macroCode PUSH_UPD_FRAME args
 120   = let
 121         [bhptr, _{-0-}] = map amodeToStix args
 122         frame n = StInd PtrRep
 123             (StIndex PtrRep stgSp (StInt (toInteger (n-uF_SIZE))))
 124
 125         a1 = StAssign PtrRep (frame uF_RET)     upd_frame_info
 126         a3 = StAssign PtrRep (frame uF_SU)      stgSu
 127         a4 = StAssign PtrRep (frame uF_UPDATEE) bhptr
 128
 129         updSu = StAssign PtrRep stgSu
 130                 (StIndex PtrRep stgSp (StInt (toInteger (-uF_SIZE))))
 131     in
 132     returnUs (\xs -> a1 : a3 : a4 : updSu : xs)
 133 \end{code}
 134
 135 -----------------------------------------------------------------------------
 136 Setting the tag register
 137
 138 This one only applies if we have a machine register devoted to TagReg.
 139
 140 \begin{code}
 141 macroCode SET_TAG [tag]
 142   = let set_tag = StAssign IntRep stgTagReg (amodeToStix tag)
 143     in
 144     case stgReg tagreg of
 145       Always _ -> returnUs id
 146       Save   _ -> returnUs (\ xs -> set_tag : xs)
 147 \end{code}
 148
 149 Do the business for a @HEAP_CHK@, having converted the args to Trees
 150 of StixOp.
 151
 152 -----------------------------------------------------------------------------
 153 Let's make sure that these CAFs are lifted out, shall we?
 154
 155 \begin{code}
 156 -- Some common labels
 157
 158 bh_info, ind_static_info, ind_info :: StixTree
 159
 160 bh_info         = sStLitLbl SLIT("BLACKHOLE_info")
 161 ind_static_info = sStLitLbl SLIT("IND_STATIC_info")
 162 ind_info        = sStLitLbl SLIT("IND_info")
 163 upd_frame_info  = sStLitLbl SLIT("Upd_frame_entry")
 164 end_tso_queue   = sStLitLbl SLIT("END_TSO_QUEUE_closure")
 165
 166 -- Some common call trees
 167
 168 updatePAP, stackOverflow :: StixTree
 169
 170 updatePAP     = StJump (sStLitLbl SLIT("stg_update_PAP"))
 171 stackOverflow = StCall SLIT("StackOverflow") cCallConv VoidRep []
 172 \end{code}
 173
 174 -----------------------------------------------------------------------------
 175 Heap/Stack checks
 176
 177 \begin{code}
 178 checkCode :: CCheckMacro -> [CAddrMode] -> StixTreeList -> UniqSM StixTreeList
 179 checkCode macro args assts
 180   = getUniqLabelNCG             `thenUs` \ ulbl_fail ->
 181     getUniqLabelNCG             `thenUs` \ ulbl_pass ->
 182
 183     let args_stix = map amodeToStix args
 184         newHp wds = StIndex PtrRep stgHp wds
 185         assign_hp wds = StAssign PtrRep stgHp (newHp wds)
 186         test_hp = StPrim AddrLeOp [stgHp, stgHpLim]
 187         cjmp_hp = StCondJump ulbl_pass test_hp
 188
 189         newSp wds = StIndex PtrRep stgSp (StPrim IntNegOp [wds])
 190         test_sp_pass wds = StPrim AddrGeOp [newSp wds, stgSpLim]
 191         test_sp_fail wds = StPrim AddrLtOp [newSp wds, stgSpLim]
 192         cjmp_sp_pass wds = StCondJump ulbl_pass (test_sp_pass wds)
 193         cjmp_sp_fail wds = StCondJump ulbl_fail (test_sp_fail wds)
 194
 195         assign_ret r ret = StAssign CodePtrRep r ret
 196
 197         fail = StLabel ulbl_fail
 198         join = StLabel ulbl_pass
 199     in
 200
 201     returnUs (
 202     case macro of
 203         HP_CHK_NP      ->
 204                 let [words,ptrs] = args_stix
 205                 in  (\xs -> assign_hp words : cjmp_hp :
 206                             assts (gc_enter ptrs : join : xs))
 207
 208         STK_CHK_NP     ->
 209                 let [words,ptrs] = args_stix
 210                 in  (\xs -> cjmp_sp_pass words :
 211                             assts (gc_enter ptrs : join : xs))
 212
 213         HP_STK_CHK_NP  ->
 214                 let [sp_words,hp_words,ptrs] = args_stix
 215                 in  (\xs -> cjmp_sp_fail sp_words :
 216                             assign_hp hp_words : cjmp_hp :
 217                             fail :
 218                             assts (gc_enter ptrs : join : xs))
 219
 220         HP_CHK         ->
 221                 let [words,ret,r,ptrs] = args_stix
 222                 in  (\xs -> assign_hp words : cjmp_hp :
 223                             assts (assign_ret r ret : gc_chk ptrs : join : xs))
 224
 225         STK_CHK        ->
 226                 let [words,ret,r,ptrs] = args_stix
 227                 in  (\xs -> cjmp_sp_pass words :
 228                             assts (assign_ret r ret : gc_chk ptrs : join : xs))
 229
 230         HP_STK_CHK     ->
 231                 let [sp_words,hp_words,ret,r,ptrs] = args_stix
 232                 in  (\xs -> cjmp_sp_fail sp_words :
 233                             assign_hp hp_words : cjmp_hp :
 234                             fail :
 235                             assts (assign_ret r ret : gc_chk ptrs : join : xs))
 236
 237         HP_CHK_NOREGS  ->
 238                 let [words] = args_stix
 239                 in  (\xs -> assign_hp words : cjmp_hp :
 240                             assts (gc_noregs : join : xs))
 241
 242         HP_CHK_UNPT_R1 ->
 243                 let [words] = args_stix
 244                 in  (\xs -> assign_hp words : cjmp_hp :
 245                             assts (gc_unpt_r1 : join : xs))
 246
 247         HP_CHK_UNBX_R1 ->
 248                 let [words] = args_stix
 249                 in  (\xs -> assign_hp words : cjmp_hp :
 250                             assts (gc_unbx_r1 : join : xs))
 251
 252         HP_CHK_F1      ->
 253                 let [words] = args_stix
 254                 in  (\xs -> assign_hp words : cjmp_hp :
 255                             assts (gc_f1 : join : xs))
 256
 257         HP_CHK_D1      ->
 258                 let [words] = args_stix
 259                 in  (\xs -> assign_hp words : cjmp_hp :
 260                             assts (gc_d1 : join : xs))
 261
 262         HP_CHK_UT_ALT  ->
 263                 error "unimplemented check"
 264
 265         HP_CHK_GEN     ->
 266                 error "unimplemented check"
 267   )
 268
 269 -- Various canned heap-check routines
 270
 271 gc_chk (StInt n)   = StJump (StLitLbl (ptext SLIT("stg_chk_") <> int (fromInteger n)))
 272 gc_enter (StInt n) = StJump (StLitLbl (ptext SLIT("stg_gc_enter_") <> int (fromInteger n)))
 273 gc_noregs          = StJump (StLitLbl (ptext SLIT("stg_gc_noregs")))
 274 gc_unpt_r1         = StJump (StLitLbl (ptext SLIT("stg_gc_unpt_r1")))
 275 gc_unbx_r1         = StJump (StLitLbl (ptext SLIT("stg_gc_unbx_r1")))
 276 gc_f1              = StJump (StLitLbl (ptext SLIT("stg_gc_f1")))
 277 gc_d1              = StJump (StLitLbl (ptext SLIT("stg_gc_d1")))
 278
 279 \end{code}