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 #include "nativeGen/NCG.h"
  10
  11 import {-# SOURCE #-} StixPrim ( amodeToStix )
  12
  13 import MachMisc
  14 import MachRegs
  15 import AbsCSyn          ( CStmtMacro(..), MagicId(..), CAddrMode, tagreg,
  16                           CCheckMacro(..) )
  17 import Constants        ( uF_RET, uF_SU, uF_UPDATEE, uF_SIZE, sEQ_FRAME_SIZE )
  18 import CallConv         ( cCallConv )
  19 import PrimOp           ( PrimOp(..) )
  20 import PrimRep          ( PrimRep(..) )
  21 import Stix
  22 import UniqSupply       ( returnUs, thenUs, UniqSM )
  23 import Outputable
  24 import CLabel           ( mkBlackHoleInfoTableLabel, mkIndStaticInfoLabel,
  25                           mkIndInfoLabel, mkUpdInfoLabel, mkSeqInfoLabel,
  26                           mkRtsGCEntryLabel, mkStgUpdatePAPLabel )
  27 \end{code}
  28
  29 The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on
  30 the A stack, and perform a tail call to @UpdatePAP@ if the arguments are
  31 not there.  The @_LOAD_NODE@ version also loads R1 with an appropriate
  32 closure address.
  33
  34 \begin{code}
  35 macroCode
  36     :: CStmtMacro           -- statement macro
  37     -> [CAddrMode]          -- args
  38     -> UniqSM StixTreeList
  39 \end{code}
  40
  41 -----------------------------------------------------------------------------
  42 Argument satisfaction checks.
  43
  44 \begin{code}
  45 macroCode ARGS_CHK_LOAD_NODE args
  46   = getUniqLabelNCG                                     `thenUs` \ ulbl ->
  47     let
  48           [words, lbl] = map amodeToStix args
  49           temp = StIndex PtrRep stgSp words
  50           test = StPrim AddrGeOp [stgSu, 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 [words]
  58   = getUniqLabelNCG                                     `thenUs` \ ulbl ->
  59     let temp = StIndex PtrRep stgSp (amodeToStix words)
  60         test = StPrim AddrGeOp [stgSu, temp]
  61         cjmp = StCondJump ulbl test
  62         join = StLabel ulbl
  63     in
  64     returnUs (\xs -> cjmp : updatePAP : join : xs)
  65 \end{code}
  66
  67 -----------------------------------------------------------------------------
  68 Updating a CAF
  69
  70 @UPD_CAF@ involves changing the info pointer of the closure, and
  71 adding an indirection.
  72
  73 \begin{code}
  74 macroCode UPD_CAF args
  75   = let
  76         [cafptr,bhptr] = map amodeToStix args
  77         w0 = StInd PtrRep cafptr
  78         w1 = StInd PtrRep (StIndex PtrRep cafptr fixedHS)
  79         blocking_queue = StInd PtrRep (StIndex PtrRep bhptr fixedHS)
  80         a1 = StAssign PtrRep w0 ind_static_info
  81         a2 = StAssign PtrRep w1 bhptr
  82         a3 = StCall SLIT("newCAF") cCallConv VoidRep [cafptr]
  83     in
  84     returnUs (\xs -> a1 : a2 : a3 : xs)
  85 \end{code}
  86
  87 -----------------------------------------------------------------------------
  88 Blackholing
  89
  90 We do lazy blackholing: no need to overwrite thunks with blackholes
  91 the minute they're entered, as long as we do it before a context
  92 switch or garbage collection, that's ok.
  93
  94 Don't blackhole single entry closures, for the following reasons:
  95
  96         - if the compiler has decided that they won't be entered again,
  97           that probably means that nothing has a pointer to it
  98           (not necessarily true, but...)
  99
 100         - no need to blackhole for concurrency reasons, because nothing
 101           can block on the result of this computation.
 102
 103 \begin{code}
 104 macroCode UPD_BH_UPDATABLE args = returnUs id
 105
 106 macroCode UPD_BH_SINGLE_ENTRY args = returnUs id
 107 {-
 108   = let
 109         update = StAssign PtrRep (StInd PtrRep (amodeToStix arg)) bh_info
 110     in
 111     returnUs (\xs -> update : xs)
 112 -}
 113 \end{code}
 114
 115 -----------------------------------------------------------------------------
 116 Update frames
 117
 118 Push a four word update frame on the stack and slide the Su registers
 119 to the current Sp location.
 120
 121 \begin{code}
 122 macroCode PUSH_UPD_FRAME args
 123   = let
 124         [bhptr, _{-0-}] = map amodeToStix args
 125         frame n = StInd PtrRep
 126             (StIndex PtrRep stgSp (StInt (toInteger (n-uF_SIZE))))
 127
 128         -- HWL: these values are *wrong* in a GranSim setup; ToDo: fix
 129         a1 = StAssign PtrRep (frame uF_RET)     upd_frame_info
 130         a3 = StAssign PtrRep (frame uF_SU)      stgSu
 131         a4 = StAssign PtrRep (frame uF_UPDATEE) bhptr
 132
 133         updSu = StAssign PtrRep stgSu
 134                 (StIndex PtrRep stgSp (StInt (toInteger (-uF_SIZE))))
 135     in
 136     returnUs (\xs -> a1 : a3 : a4 : updSu : xs)
 137
 138
 139 macroCode PUSH_SEQ_FRAME args
 140    = let [arg_frame] = map amodeToStix args
 141          frame n = StInd PtrRep
 142                      (StIndex PtrRep arg_frame (StInt (toInteger n)))
 143          a1 = StAssign PtrRep (frame 0) seq_frame_info
 144          a2 = StAssign PtrRep (frame 1) stgSu
 145          updSu = StAssign PtrRep stgSu arg_frame
 146      in
 147      returnUs (\xs -> a1 : a2 : updSu : xs)
 148
 149
 150 macroCode UPDATE_SU_FROM_UPD_FRAME args
 151    = let [arg_frame] = map amodeToStix args
 152          frame n = StInd PtrRep
 153                       (StIndex PtrRep arg_frame (StInt (toInteger n)))
 154          updSu
 155             = StAssign PtrRep stgSu (frame uF_SU)
 156      in
 157      returnUs (\xs -> updSu : xs)
 158 \end{code}
 159
 160 -----------------------------------------------------------------------------
 161 Setting the tag register
 162
 163 This one only applies if we have a machine register devoted to TagReg.
 164
 165 \begin{code}
 166 macroCode SET_TAG [tag]
 167   = let set_tag = StAssign IntRep stgTagReg (amodeToStix tag)
 168     in
 169     case stgReg tagreg of
 170       Always _ -> returnUs id
 171       Save   _ -> returnUs (\ xs -> set_tag : xs)
 172 \end{code}
 173
 174 -----------------------------------------------------------------------------
 175
 176 \begin{code}
 177 macroCode REGISTER_IMPORT [arg]
 178    = returnUs (
 179         \xs -> StAssign WordRep (StInd WordRep stgSp) (amodeToStix arg)
 180              : StAssign PtrRep  stgSp (StPrim IntAddOp [stgSp, StInt 4])
 181              : xs
 182      )
 183
 184 macroCode REGISTER_FOREIGN_EXPORT [arg]
 185    = returnUs (
 186         \xs -> StCall SLIT("getStablePtr") cCallConv VoidRep [amodeToStix arg]
 187              : xs
 188      )
 189
 190 macroCode other args
 191    = case other of
 192         SET_TAG -> error "foobarxyzzy8"
 193         _       -> error "StixMacro.macroCode: unknown macro/args"
 194 \end{code}
 195
 196
 197 Do the business for a @HEAP_CHK@, having converted the args to Trees
 198 of StixOp.
 199
 200 -----------------------------------------------------------------------------
 201 Let's make sure that these CAFs are lifted out, shall we?
 202
 203 \begin{code}
 204 -- Some common labels
 205
 206 bh_info, ind_static_info, ind_info :: StixTree
 207
 208 bh_info         = StCLbl mkBlackHoleInfoTableLabel
 209 ind_static_info = StCLbl mkIndStaticInfoLabel
 210 ind_info        = StCLbl mkIndInfoLabel
 211 upd_frame_info  = StCLbl mkUpdInfoLabel
 212 seq_frame_info  = StCLbl mkSeqInfoLabel
 213 stg_update_PAP  = StCLbl mkStgUpdatePAPLabel
 214 -- Some common call trees
 215
 216 updatePAP, stackOverflow :: StixTree
 217
 218 updatePAP     = StJump stg_update_PAP
 219 stackOverflow = StCall SLIT("StackOverflow") cCallConv VoidRep []
 220 \end{code}
 221
 222 -----------------------------------------------------------------------------
 223 Heap/Stack checks
 224
 225 \begin{code}
 226 checkCode :: CCheckMacro -> [CAddrMode] -> StixTreeList -> UniqSM StixTreeList
 227 checkCode macro args assts
 228   = getUniqLabelNCG             `thenUs` \ ulbl_fail ->
 229     getUniqLabelNCG             `thenUs` \ ulbl_pass ->
 230
 231     let args_stix = map amodeToStix args
 232         newHp wds = StIndex PtrRep stgHp wds
 233         assign_hp wds = StAssign PtrRep stgHp (newHp wds)
 234         test_hp = StPrim AddrLeOp [stgHp, stgHpLim]
 235         cjmp_hp = StCondJump ulbl_pass test_hp
 236
 237         newSp wds = StIndex PtrRep stgSp (StPrim IntNegOp [wds])
 238         test_sp_pass wds = StPrim AddrGeOp [newSp wds, stgSpLim]
 239         test_sp_fail wds = StPrim AddrLtOp [newSp wds, stgSpLim]
 240         cjmp_sp_pass wds = StCondJump ulbl_pass (test_sp_pass wds)
 241         cjmp_sp_fail wds = StCondJump ulbl_fail (test_sp_fail wds)
 242
 243         assign_ret r ret = StAssign CodePtrRep r ret
 244
 245         fail = StLabel ulbl_fail
 246         join = StLabel ulbl_pass
 247
 248         -- see includes/StgMacros.h for explaination of these magic consts
 249         aLL_NON_PTRS
 250            = IF_ARCH_alpha(16383,65535)
 251
 252         assign_liveness ptr_regs
 253            = StAssign WordRep stgR9
 254                       (StPrim XorOp [StInt aLL_NON_PTRS, ptr_regs])
 255         assign_reentry reentry
 256            = StAssign WordRep stgR10 reentry
 257     in
 258
 259     returnUs (
 260     case macro of
 261         HP_CHK_NP      ->
 262                 let [words,ptrs] = args_stix
 263                 in  (\xs -> assign_hp words : cjmp_hp :
 264                             assts (gc_enter ptrs : join : xs))
 265
 266         HP_CHK_SEQ_NP  ->
 267                 let [words,ptrs] = args_stix
 268                 in  (\xs -> assign_hp words : cjmp_hp :
 269                             assts (gc_seq ptrs : join : xs))
 270
 271         STK_CHK_NP     ->
 272                 let [words,ptrs] = args_stix
 273                 in  (\xs -> cjmp_sp_pass words :
 274                             assts (gc_enter ptrs : join : xs))
 275
 276         HP_STK_CHK_NP  ->
 277                 let [sp_words,hp_words,ptrs] = args_stix
 278                 in  (\xs -> cjmp_sp_fail sp_words :
 279                             assign_hp hp_words : cjmp_hp :
 280                             fail :
 281                             assts (gc_enter ptrs : join : xs))
 282
 283         HP_CHK         ->
 284                 let [words,ret,r,ptrs] = args_stix
 285                 in  (\xs -> assign_hp words : cjmp_hp :
 286                             assts (assign_ret r ret : gc_chk ptrs : join : xs))
 287
 288         STK_CHK        ->
 289                 let [words,ret,r,ptrs] = args_stix
 290                 in  (\xs -> cjmp_sp_pass words :
 291                             assts (assign_ret r ret : gc_chk ptrs : join : xs))
 292
 293         HP_STK_CHK     ->
 294                 let [sp_words,hp_words,ret,r,ptrs] = args_stix
 295                 in  (\xs -> cjmp_sp_fail sp_words :
 296                             assign_hp hp_words : cjmp_hp :
 297                             fail :
 298                             assts (assign_ret r ret : gc_chk ptrs : join : xs))
 299
 300         HP_CHK_NOREGS  ->
 301                 let [words] = args_stix
 302                 in  (\xs -> assign_hp words : cjmp_hp :
 303                             assts (gc_noregs : join : xs))
 304
 305         HP_CHK_UNPT_R1 ->
 306                 let [words] = args_stix
 307                 in  (\xs -> assign_hp words : cjmp_hp :
 308                             assts (gc_unpt_r1 : join : xs))
 309
 310         HP_CHK_UNBX_R1 ->
 311                 let [words] = args_stix
 312                 in  (\xs -> assign_hp words : cjmp_hp :
 313                             assts (gc_unbx_r1 : join : xs))
 314
 315         HP_CHK_F1      ->
 316                 let [words] = args_stix
 317                 in  (\xs -> assign_hp words : cjmp_hp :
 318                             assts (gc_f1 : join : xs))
 319
 320         HP_CHK_D1      ->
 321                 let [words] = args_stix
 322                 in  (\xs -> assign_hp words : cjmp_hp :
 323                             assts (gc_d1 : join : xs))
 324
 325         HP_CHK_UT_ALT  ->
 326                 let [words,ptrs,nonptrs,r,ret] = args_stix
 327                 in (\xs -> assign_hp words : cjmp_hp :
 328                            assts (assign_ret r ret : gc_ut ptrs nonptrs
 329                                   : join : xs))
 330
 331         HP_CHK_GEN     ->
 332                 let [words,liveness,reentry] = args_stix
 333                 in (\xs -> assign_hp words : cjmp_hp :
 334                            assts (assign_liveness liveness :
 335                                   assign_reentry reentry :
 336                                   gc_gen : join : xs))
 337     )
 338
 339 -- Various canned heap-check routines
 340
 341 mkStJump_to_GCentry :: String -> StixTree
 342 mkStJump_to_GCentry gcname
 343 --   | opt_Static
 344    = StJump (StCLbl (mkRtsGCEntryLabel gcname))
 345 --   | otherwise -- it's in a different DLL
 346 --   = StJump (StInd PtrRep (StLitLbl True sdoc))
 347
 348 gc_chk (StInt n)   = mkStJump_to_GCentry ("stg_chk_" ++ show n)
 349 gc_enter (StInt n) = mkStJump_to_GCentry ("stg_gc_enter_" ++ show n)
 350 gc_seq (StInt n)   = mkStJump_to_GCentry ("stg_gc_seq_" ++ show n)
 351 gc_noregs          = mkStJump_to_GCentry "stg_gc_noregs"
 352 gc_unpt_r1         = mkStJump_to_GCentry "stg_gc_unpt_r1"
 353 gc_unbx_r1         = mkStJump_to_GCentry "stg_gc_unbx_r1"
 354 gc_f1              = mkStJump_to_GCentry "stg_gc_f1"
 355 gc_d1              = mkStJump_to_GCentry "stg_gc_d1"
 356 gc_gen             = mkStJump_to_GCentry "stg_gen_chk"
 357 gc_ut (StInt p) (StInt np)
 358                    = mkStJump_to_GCentry ("stg_gc_ut_" ++ show p
 359                                           ++ "_" ++ show np)
 360 \end{code}