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 MachRegs
  14 import AbsCSyn          ( CStmtMacro(..), CAddrMode, tagreg, CCheckMacro(..) )
  15 import SMRep            ( fixedHdrSize )
  16 import Constants        ( uF_RET, uF_UPDATEE, uF_SIZE )
  17 import ForeignCall      ( CCallConv(..) )
  18 import MachOp           ( MachOp(..) )
  19 import PrimRep          ( PrimRep(..) )
  20 import Stix
  21 import Panic            ( panic )
  22 import UniqSupply       ( returnUs, thenUs, UniqSM )
  23 import CLabel           ( mkBlackHoleInfoTableLabel, mkIndStaticInfoLabel,
  24                           mkBlackHoleBQInfoTableLabel,
  25                           mkIndInfoLabel, mkUpdInfoLabel, mkRtsGCEntryLabel )
  26 \end{code}
  27 --------------------------------------------------------------------------------
  28 The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on
  29 the A stack, and perform a tail call to @UpdatePAP@ if the arguments are
  30 not there.  The @_LOAD_NODE@ version also loads R1 with an appropriate
  31 closure address.
  32
  33 \begin{code}
  34 macroCode
  35     :: CStmtMacro           -- statement macro
  36     -> [StixExpr]           -- args
  37     -> UniqSM StixStmtList
  38 \end{code}
  39
  40 -----------------------------------------------------------------------------
  41 Updating a CAF
  42
  43 @UPD_CAF@ involves changing the info pointer of the closure, and
  44 adding an indirection.
  45
  46 \begin{code}
  47 macroCode UPD_CAF [cafptr,bhptr]
  48   = let
  49         new_caf = StVoidable (StCall (Left FSLIT("newCAF")) CCallConv VoidRep [cafptr])
  50         a1 = StAssignMem PtrRep (StIndex PtrRep cafptr fixedHS) bhptr
  51         a2 = StAssignMem PtrRep cafptr ind_static_info
  52     in
  53     returnUs (\xs -> new_caf : a1 : a2 : xs)
  54 \end{code}
  55
  56 -----------------------------------------------------------------------------
  57 Blackholing
  58
  59 We do lazy blackholing: no need to overwrite thunks with blackholes
  60 the minute they're entered, as long as we do it before a context
  61 switch or garbage collection, that's ok.
  62
  63 Don't blackhole single entry closures, for the following reasons:
  64
  65         - if the compiler has decided that they won't be entered again,
  66           that probably means that nothing has a pointer to it
  67           (not necessarily true, but...)
  68
  69         - no need to blackhole for concurrency reasons, because nothing
  70           can block on the result of this computation.
  71
  72 \begin{code}
  73 macroCode UPD_BH_UPDATABLE args = returnUs id
  74
  75 macroCode UPD_BH_SINGLE_ENTRY args = returnUs id
  76 {-
  77   = let
  78         update = StAssign PtrRep (StInd PtrRep arg) bh_info
  79     in
  80     returnUs (\xs -> update : xs)
  81 -}
  82 \end{code}
  83
  84 -----------------------------------------------------------------------------
  85 Update frames
  86
  87 Push an update frame on the stack.
  88
  89 \begin{code}
  90 macroCode PUSH_UPD_FRAME [bhptr, _{-0-}]
  91   = let
  92         frame n = StIndex PtrRep (StReg stgSp) (StInt (toInteger (n-uF_SIZE)))
  93
  94         -- HWL: these values are *wrong* in a GranSim setup; ToDo: fix
  95         a1 = StAssignMem PtrRep (frame uF_RET)     upd_frame_info
  96         a4 = StAssignMem PtrRep (frame uF_UPDATEE) bhptr
  97     in
  98     returnUs (\xs -> a1 : a4 : xs)
  99 \end{code}
 100
 101 -----------------------------------------------------------------------------
 102 Setting the tag register
 103
 104 This one only applies if we have a machine register devoted to TagReg.
 105
 106 \begin{code}
 107 macroCode SET_TAG [tag]
 108   = case get_MagicId_reg_or_addr tagreg of
 109        Right baseRegAddr
 110           -> returnUs id
 111        Left  realreg
 112           -> let a1 = StAssignReg IntRep (StixMagicId tagreg) tag
 113              in returnUs ( \xs -> a1 : xs )
 114 \end{code}
 115
 116 -----------------------------------------------------------------------------
 117
 118 \begin{code}
 119 macroCode AWAKEN_BQ_CLOSURE [arg]
 120   =  getUniqLabelNCG            `thenUs` \ label ->
 121      let
 122         info = StInd AddrRep arg
 123         cond = StMachOp MO_Nat_Ne [info, bq_info ]
 124         jump = StCondJump label cond
 125         blocking_queue = StInd PtrRep
 126                           (StIndex PtrRep arg (StInt (toInteger fixedHdrSize)))
 127         call = StVoidable (StCall (Left FSLIT("awakenBlockedQueue"))
 128                                 CCallConv VoidRep [blocking_queue])
 129      in
 130      returnUs ( \xs -> jump : call : StLabel label : xs )
 131 \end{code}
 132
 133 -----------------------------------------------------------------------------
 134
 135 \begin{code}
 136 macroCode REGISTER_IMPORT [arg]
 137    = returnUs (
 138         \xs -> StAssignMem WordRep (StReg stgSp) arg
 139              : StAssignReg PtrRep  stgSp (StMachOp MO_Nat_Add [StReg stgSp, StInt 4])
 140              : xs
 141      )
 142
 143 macroCode REGISTER_FOREIGN_EXPORT [arg]
 144    = returnUs (
 145         \xs -> StVoidable (
 146                   StCall (Left FSLIT("getStablePtr")) CCallConv VoidRep
 147                          [arg]
 148                )
 149              : xs
 150      )
 151
 152 macroCode other args
 153    = panic "StixMacro.macroCode"
 154 \end{code}
 155
 156 Do the business for a @HEAP_CHK@, having converted the args to Trees
 157 of StixOp.
 158
 159 -----------------------------------------------------------------------------
 160 Let's make sure that these CAFs are lifted out, shall we?
 161
 162 \begin{code}
 163 -- Some common labels
 164
 165 bh_info, ind_static_info, ind_info :: StixExpr
 166
 167 bh_info         = StCLbl mkBlackHoleInfoTableLabel
 168 bq_info         = StCLbl mkBlackHoleBQInfoTableLabel
 169 ind_static_info = StCLbl mkIndStaticInfoLabel
 170 ind_info        = StCLbl mkIndInfoLabel
 171 upd_frame_info  = StCLbl mkUpdInfoLabel
 172
 173 -- Some common call trees
 174 \end{code}
 175
 176 -----------------------------------------------------------------------------
 177 Heap/Stack checks
 178
 179 \begin{code}
 180 checkCode :: CCheckMacro -> [CAddrMode] -> StixStmtList -> UniqSM StixStmtList
 181 checkCode macro args assts
 182   = getUniqLabelNCG             `thenUs` \ ulbl_fail ->
 183     getUniqLabelNCG             `thenUs` \ ulbl_pass ->
 184
 185     let args_stix        = map amodeToStix args
 186         newHp wds        = StIndex PtrRep (StReg stgHp) wds
 187         assign_hp wds    = StAssignReg PtrRep stgHp (newHp wds)
 188         hp_alloc wds     = StAssignReg IntRep stgHpAlloc wds
 189         test_hp          = StMachOp MO_NatU_Le [StReg stgHp, StReg stgHpLim]
 190         cjmp_hp          = StCondJump ulbl_pass test_hp
 191         newSp wds        = StIndex PtrRep (StReg stgSp) (StMachOp MO_NatS_Neg [wds])
 192         test_sp_pass wds = StMachOp MO_NatU_Ge [newSp wds, StReg stgSpLim]
 193         test_sp_fail wds = StMachOp MO_NatU_Lt [newSp wds, StReg stgSpLim]
 194         cjmp_sp_pass wds = StCondJump ulbl_pass (test_sp_pass wds)
 195         cjmp_sp_fail wds = StCondJump ulbl_fail (test_sp_fail wds)
 196         assign_ret r ret = mkStAssign CodePtrRep r ret
 197
 198         fail = StLabel ulbl_fail
 199         join = StLabel ulbl_pass
 200
 201         -- see includes/StgMacros.h for explaination of these magic consts
 202         aLL_NON_PTRS = 0xff
 203
 204         assign_liveness ptr_regs
 205            = StAssignReg WordRep stgR9
 206                          (StMachOp MO_Nat_Xor [StInt aLL_NON_PTRS, ptr_regs])
 207         assign_reentry reentry
 208            = StAssignReg WordRep stgR10 reentry
 209     in
 210
 211     returnUs (
 212     case macro of
 213         HP_CHK_NP      ->
 214                 let [words] = args_stix
 215                 in  (\xs -> assign_hp words : cjmp_hp :
 216                             assts (hp_alloc words : gc_enter : join : xs))
 217
 218         STK_CHK_NP     ->
 219                 let [words] = args_stix
 220                 in  (\xs -> cjmp_sp_pass words :
 221                             assts (gc_enter : join : xs))
 222
 223         HP_STK_CHK_NP  ->
 224                 let [sp_words,hp_words] = args_stix
 225                 in  (\xs -> cjmp_sp_fail sp_words :
 226                             assign_hp hp_words : cjmp_hp :
 227                             fail :
 228                             assts (hp_alloc hp_words : gc_enter
 229                                    : join : xs))
 230
 231         HP_CHK_FUN       ->
 232                 let [words] = args_stix
 233                 in  (\xs -> assign_hp words : cjmp_hp :
 234                             assts (hp_alloc words : gc_fun : join : xs))
 235
 236         STK_CHK_FUN       ->
 237                 let [words] = args_stix
 238                 in  (\xs -> cjmp_sp_pass words :
 239                             assts (gc_fun : join : xs))
 240
 241         HP_STK_CHK_FUN    ->
 242                 let [sp_words,hp_words] = args_stix
 243                 in  (\xs -> cjmp_sp_fail sp_words :
 244                             assign_hp hp_words : cjmp_hp :
 245                             fail :
 246                             assts (hp_alloc hp_words
 247                                   : gc_fun : join : xs))
 248
 249         HP_CHK_NOREGS  ->
 250                 let [words] = args_stix
 251                 in  (\xs -> assign_hp words : cjmp_hp :
 252                             assts (hp_alloc words : gc_noregs : join : xs))
 253
 254         HP_CHK_UNPT_R1 ->
 255                 let [words] = args_stix
 256                 in  (\xs -> assign_hp words : cjmp_hp :
 257                             assts (hp_alloc words : gc_unpt_r1 : join : xs))
 258
 259         HP_CHK_UNBX_R1 ->
 260                 let [words] = args_stix
 261                 in  (\xs -> assign_hp words : cjmp_hp :
 262                             assts (hp_alloc words : gc_unbx_r1 : join : xs))
 263
 264         HP_CHK_F1      ->
 265                 let [words] = args_stix
 266                 in  (\xs -> assign_hp words : cjmp_hp :
 267                             assts (hp_alloc words : gc_f1 : join : xs))
 268
 269         HP_CHK_D1      ->
 270                 let [words] = args_stix
 271                 in  (\xs -> assign_hp words : cjmp_hp :
 272                             assts (hp_alloc words : gc_d1 : join : xs))
 273
 274         HP_CHK_L1      ->
 275                 let [words] = args_stix
 276                 in  (\xs -> assign_hp words : cjmp_hp :
 277                             assts (hp_alloc words : gc_l1 : join : xs))
 278
 279         HP_CHK_UNBX_TUPLE  ->
 280                 let [words,liveness] = args_stix
 281                 in (\xs -> assign_hp words : cjmp_hp :
 282                            assts (hp_alloc words : assign_liveness liveness :
 283                                   gc_ut : join : xs))
 284     )
 285
 286 -- Various canned heap-check routines
 287
 288 mkStJump_to_GCentry_name :: String -> StixStmt
 289 mkStJump_to_GCentry_name gcname
 290 --   | opt_Static
 291    = StJump NoDestInfo (StCLbl (mkRtsGCEntryLabel gcname))
 292 --   | otherwise -- it's in a different DLL
 293 --   = StJump (StInd PtrRep (StLitLbl True sdoc))
 294
 295 mkStJump_to_RegTable_offw :: Int -> StixStmt
 296 mkStJump_to_RegTable_offw regtable_offw
 297 --   | opt_Static
 298    = StJump NoDestInfo (StInd PtrRep (get_Regtable_addr_from_offset regtable_offw))
 299 --   | otherwise
 300 --   do something plausible for cross-DLL jump
 301
 302 gc_enter = mkStJump_to_RegTable_offw OFFSET_stgGCEnter1
 303 gc_fun   = mkStJump_to_RegTable_offw OFFSET_stgGCFun
 304
 305 gc_noregs          = mkStJump_to_GCentry_name "stg_gc_noregs"
 306 gc_unpt_r1         = mkStJump_to_GCentry_name "stg_gc_unpt_r1"
 307 gc_unbx_r1         = mkStJump_to_GCentry_name "stg_gc_unbx_r1"
 308 gc_f1              = mkStJump_to_GCentry_name "stg_gc_f1"
 309 gc_d1              = mkStJump_to_GCentry_name "stg_gc_d1"
 310 gc_l1              = mkStJump_to_GCentry_name "stg_gc_l1"
 311 gc_ut              = mkStJump_to_GCentry_name "stg_gc_ut"
 312 \end{code}