Simon Jakobi pushed to branch wip/sjakobi/mr16259 at Glasgow Haskell Compiler / GHC

Commits:

7 changed files:

Changes:

  • changelog.d/enter-taggable-invariant-23173
    ... ... @@ -12,4 +12,10 @@ description: {
    12 12 
       entry code of a taggable normal form is unreachable: entering such a
    13 13 
       closure prints a one-shot warning at runtime, or aborts the program when
    14 14 
       the new RTS flag ``--fatal-enter-taggable`` is given.
    15 
    +
    16 
    +  ``foreign import prim`` callees receive unlifted boxed arguments untagged,
    17 
    +  as before, but must now return unlifted boxed results with their proper
    18 
    +  pointer tag (1 for primitive objects). Likewise, C code that obtains an
    19 
    +  unlifted boxed value, e.g. an ``MVar#``, through a ``StablePtr`` must strip
    20 
    +  the tag before dereferencing the pointer.
    15 21 
     }

  • compiler/GHC/StgToCmm/Prim.hs
    ... ... @@ -92,8 +92,15 @@ cgOpApp (StgPrimOp primop) args res_ty = do
    92 92 
         cmm_args <- getNonVoidArgAmodes args
    93 93 
         -- See Note [Pointer tagging of unlifted boxed primitives]
    94 94 
         let decl_tys = map scaledThing (fst (splitFunTys (dropForAlls (primOpType primop))))
    95 
    -        nv_decl_tys = [ dty
    96 
    -                      | (dty, arg) <- zip decl_tys args
    95 
    +        -- Unarisation splits a declared unboxed-tuple argument (e.g.
    96 
    +        -- packFloatX4#'s) into several STG args, breaking positional
    97 
    +        -- alignment with the declared types. No such primop takes a boxed
    98 
    +        -- pointer through a tuple, so fall back to not untagging anything.
    99 
    +        mb_decl_tys
    100 
    +          | decl_tys `equalLength` args = map Just decl_tys
    101 
    +          | otherwise                   = map (const Nothing) args
    102 
    +        nv_decl_tys = [ mb_dty
    103 
    +                      | (mb_dty, arg) <- zip mb_decl_tys args
    97 104 
                           , not (null (stgArgRep arg)) ]
    98 105 
             cmm_args' = zipWith3 (untagPrimArg platform) nv_decl_tys (nonVoidStgArgs args) cmm_args
    99 106 
             -- The RTS dereferences the key field of a Weak directly (GC key
    ... ... @@ -145,9 +152,10 @@ cmmPrimOpApp cfg primop cmm_args mres_ty = do
    145 152 
     --    yet (e.g. ThreadId#s in the array filled in by C listThreads).
    146 153 
     --
    147 154 
     -- See Note [Pointer tagging of unlifted boxed primitives].
    148 
    -untagPrimArg :: Platform -> Type -> NonVoid StgArg -> CmmExpr -> CmmExpr
    149 
    -untagPrimArg platform decl_ty nv_arg e
    150 
    -  | Just tc <- tyConAppTyCon_maybe decl_ty
    155 
    +untagPrimArg :: Platform -> Maybe Type -> NonVoid StgArg -> CmmExpr -> CmmExpr
    156 
    +untagPrimArg platform mb_decl_ty nv_arg e
    157 
    +  | Just decl_ty <- mb_decl_ty
    158 
    +  , Just tc <- tyConAppTyCon_maybe decl_ty
    151 159 
       = if isKnownTag1PrimTyCon tc
    152 160 
           then cmmOffsetB platform e (-1)
    153 161 
           else if isUnliftedBoxedTy (stgArgType (fromNonVoid nv_arg))
    ... ... @@ -238,6 +246,11 @@ Foreign and foreign-prim arguments
    238 246 
       @Any \@UnliftedRep@ arguments, so the predicate here admits any unlifted boxed
    239 247 
       type rather than only the primitive ones.
    240 248
    249 
    +  In the other direction the callee is a producer: an unlifted boxed value
    250 
    +  /returned/ by a 'foreign import prim' must carry its proper tag (1 for a
    251 
    +  primitive object), just like the out-of-line primops in rts/PrimOps.cmm.
    252 
    +  Compiled code assumes the tag on the result (see e.g. T21305).
    253 
    +
    241 254 
     Stripping the tag from an already-untagged pointer is the identity, so the
    242 255 
     boundaries are correct whether or not a given producer has been taught to tag.
    243 256

  • rts/CloneStack.c
    ... ... @@ -78,7 +78,9 @@ void sendCloneStackMessage(StgTSO *tso, HsStablePtr mvar) {
    78 78 
       MessageCloneStack *msg;
    79 79 
       msg = (MessageCloneStack *)allocate(srcCapability, sizeofW(MessageCloneStack));
    80 80 
       msg->tso = tso;
    81 
    -  msg->result = (StgMVar*)deRefStablePtr(mvar);
    81 
    +  // MVar# pointers carry tag 1; see Note [Pointer tagging of unlifted boxed
    82 
    +  // primitives] in GHC.StgToCmm.Prim.
    83 
    +  msg->result = (StgMVar*)UNTAG_CLOSURE((StgClosure*)deRefStablePtr(mvar));
    82 84 
       SET_HDR_RELEASE(msg, &stg_MSG_CLONE_STACK_info, CCS_SYSTEM);
    83 85
    84 86 
       sendMessage(srcCapability, tso->cap, (Message *)msg);

  • rts/RtsAPI.c
    ... ... @@ -982,7 +982,9 @@ void hs_try_putmvar_with_value (/* in */ int capability,
    982 982
    983 983 
     #if !defined(THREADED_RTS)
    984 984
    985 
    -    performTryPutMVar(cap, (StgMVar*)deRefStablePtr(mvar), value);
    985 
    +    // MVar# pointers carry tag 1; see Note [Pointer tagging of unlifted boxed
    986 
    +    // primitives] in GHC.StgToCmm.Prim.
    987 
    +    performTryPutMVar(cap, (StgMVar*)UNTAG_CLOSURE((StgClosure*)deRefStablePtr(mvar)), value);
    986 988 
         freeStablePtr(mvar);
    987 989
    988 990 
     #else
    ... ... @@ -995,7 +997,8 @@ void hs_try_putmvar_with_value (/* in */ int capability,
    995 997 
             task->cap = cap;
    996 998 
             RELEASE_LOCK(&cap->lock);
    997 999
    998 
    -        performTryPutMVar(cap, (StgMVar*)deRefStablePtr(mvar), value);
    1000 
    +        performTryPutMVar(cap, (StgMVar*)UNTAG_CLOSURE((StgClosure*)deRefStablePtr(mvar)),
    1001 
    +                          value);
    999 1002
    1000 1003 
             freeStablePtr(mvar);
    1001 1004

  • rts/Schedule.c
    ... ... @@ -1053,7 +1053,8 @@ scheduleProcessInbox (Capability **pcap USED_IF_THREADS)
    1053 1053
    1054 1054 
             while (p != NULL) {
    1055 1055 
                 pnext = p->link;
    1056 
    -            performTryPutMVar(cap, (StgMVar*)deRefStablePtr(p->mvar),
    1056 
    +            performTryPutMVar(cap,
    1057 
    +                              (StgMVar*)UNTAG_CLOSURE((StgClosure*)deRefStablePtr(p->mvar)),
    1057 1058 
                                   Unit_closure);
    1058 1059 
                 freeStablePtr(p->mvar);
    1059 1060 
                 stgFree(p);

  • testsuite/tests/codeGen/should_compile/T21710a.stderr
    ... ... @@ -53,35 +53,34 @@
    53 53 
              }
    54 54 
          {offset
    55 55 
            cqw: // global
    56 
    -           if ((Sp + -8) < SpLim) (likely: False) goto cqx; else goto cqy;   // CmmCondBranch
    56 
    +           if ((Sp + -8) < SpLim) (likely: False) goto cqx; else goto cqy;
    57 57 
            cqx: // global
    58 
    -           R1 = M.foo_closure;   // CmmAssign
    59 
    -           call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8;   // CmmCall
    58 
    +           R1 = M.foo_closure;
    59 
    +           call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8;
    60 60 
            cqy: // global
    61 
    -           I64[Sp - 8] = cqo;   // CmmStore
    62 
    -           R1 = R2;   // CmmAssign
    63 
    -           Sp = Sp - 8;   // CmmAssign
    64 
    -           if (R1 & 7 != 0) goto cqo; else goto cqp;   // CmmCondBranch
    61 
    +           I64[Sp - 8] = cqo;
    62 
    +           R1 = R2;
    63 
    +           Sp = Sp - 8;
    64 
    +           if (R1 & 7 != 0) goto cqo; else goto cqp;
    65 65 
            cqp: // global
    66 
    -           call (I64![R1])(R1) returns to cqo, args: 8, res: 8, upd: 8;   // CmmCall
    66 
    +           call (I64![R1])(R1) returns to cqo, args: 8, res: 8, upd: 8;
    67 67 
            cqo: // global
    68 
    -           _cqv::P64 = R1 & 7;   // CmmAssign
    69 
    -           if (_cqv::P64 != 1) goto n0; else goto cqt;   // CmmCondBranch
    68 
    +           _cqv::P64 = R1 & 7;
    69 
    +           if (_cqv::P64 != 1) goto n0; else goto cqt;
    70 70 
            n0: // global
    71 
    -           if (_cqv::P64 != 2) goto cqs; else goto cqu;   // CmmCondBranch
    71 
    +           if (_cqv::P64 != 2) goto cqs; else goto cqu;
    72 72 
            cqs: // global
    73 
    -           // dataToTagSmall#
    74 
    -           R1 = R1 & 7 - 1;   // CmmAssign
    75 
    -           Sp = Sp + 8;   // CmmAssign
    76 
    -           call (P64[Sp])(R1) args: 8, res: 0, upd: 8;   // CmmCall
    73 
    +           R1 = R1 & 7 - 1;
    74 
    +           Sp = Sp + 8;
    75 
    +           call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
    77 76 
            cqu: // global
    78 
    -           R1 = 42;   // CmmAssign
    79 
    -           Sp = Sp + 8;   // CmmAssign
    80 
    -           call (P64[Sp])(R1) args: 8, res: 0, upd: 8;   // CmmCall
    77 
    +           R1 = 42;
    78 
    +           Sp = Sp + 8;
    79 
    +           call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
    81 80 
            cqt: // global
    82 
    -           R1 = 2;   // CmmAssign
    83 
    -           Sp = Sp + 8;   // CmmAssign
    84 
    -           call (P64[Sp])(R1) args: 8, res: 0, upd: 8;   // CmmCall
    81 
    +           R1 = 2;
    82 
    +           Sp = Sp + 8;
    83 
    +           call (P64[Sp])(R1) args: 8, res: 0, upd: 8;
    85 84 
          }
    86 85 
      },
    87 86 
      section ""data" . M.foo_closure" {
    ... ... @@ -92,27 +91,7 @@
    92 91
    93 92
    94 93 
     ==================== Output Cmm ====================
    95 
    -[section ""cstring" . cqJ_str" {
    96 
    -     cqJ_str:
    97 
    -         I8[] "A"
    98 
    - },
    99 
    - section ""cstring" . cqL_str" {
    100 
    -     cqL_str:
    101 
    -         I8[] "B"
    102 
    - },
    103 
    - section ""cstring" . cqN_str" {
    104 
    -     cqN_str:
    105 
    -         I8[] "C"
    106 
    - },
    107 
    - section ""cstring" . cqP_str" {
    108 
    -     cqP_str:
    109 
    -         I8[] "D"
    110 
    - },
    111 
    - section ""cstring" . cqR_str" {
    112 
    -     cqR_str:
    113 
    -         I8[] "E"
    114 
    - },
    115 
    - section ""relreadonly" . M.E_closure_tbl" {
    94 
    +[section ""relreadonly" . M.E_closure_tbl" {
    116 95 
          M.E_closure_tbl:
    117 96 
              const M.A_closure+1;
    118 97 
              const M.B_closure+2;
    ... ... @@ -121,73 +100,63 @@
    121 100 
              const M.E_closure+5;
    122 101 
      },
    123 102 
      M.A_con_entry() { //  []
    124 
    -         { info_tbls: [(cqK,
    103 
    +         { info_tbls: [(cqJ,
    125 104 
                             label: M.A_con_info
    126 105 
                             rep: HeapRep 1 nonptrs { Con {tag: 0 descr:"main:M.A"} }
    127 106 
                             srt: Nothing)]
    128 107 
                stack_info: arg_space: 8
    129 108 
              }
    130 109 
          {offset
    131 
    -       cqK: // global
    132 
    -           call "ccall" arg hints:  [PtrHint]  result hints:  [] checkEnteredTaggable(cqJ_str);   // CmmUnsafeForeignCall
    133 
    -           R1 = R1 + 1;   // CmmAssign
    134 
    -           call (P64[Sp])(R1) args: 8, res: 0, upd: 8;   // CmmCall
    110 
    +       cqJ: // global
    111 
    +           call stg_enteredTaggable(R1) args: 8, res: 0, upd: 8;
    135 112 
          }
    136 113 
      },
    137 114 
      M.B_con_entry() { //  []
    138 
    -         { info_tbls: [(cqM,
    115 
    +         { info_tbls: [(cqK,
    139 116 
                             label: M.B_con_info
    140 117 
                             rep: HeapRep 1 nonptrs { Con {tag: 1 descr:"main:M.B"} }
    141 118 
                             srt: Nothing)]
    142 119 
                stack_info: arg_space: 8
    143 120 
              }
    144 121 
          {offset
    145 
    -       cqM: // global
    146 
    -           call "ccall" arg hints:  [PtrHint]  result hints:  [] checkEnteredTaggable(cqL_str);   // CmmUnsafeForeignCall
    147 
    -           R1 = R1 + 2;   // CmmAssign
    148 
    -           call (P64[Sp])(R1) args: 8, res: 0, upd: 8;   // CmmCall
    122 
    +       cqK: // global
    123 
    +           call stg_enteredTaggable(R1) args: 8, res: 0, upd: 8;
    149 124 
          }
    150 125 
      },
    151 126 
      M.C_con_entry() { //  []
    152 
    -         { info_tbls: [(cqO,
    127 
    +         { info_tbls: [(cqL,
    153 128 
                             label: M.C_con_info
    154 129 
                             rep: HeapRep 1 nonptrs { Con {tag: 2 descr:"main:M.C"} }
    155 130 
                             srt: Nothing)]
    156 131 
                stack_info: arg_space: 8
    157 132 
              }
    158 133 
          {offset
    159 
    -       cqO: // global
    160 
    -           call "ccall" arg hints:  [PtrHint]  result hints:  [] checkEnteredTaggable(cqN_str);   // CmmUnsafeForeignCall
    161 
    -           R1 = R1 + 3;   // CmmAssign
    162 
    -           call (P64[Sp])(R1) args: 8, res: 0, upd: 8;   // CmmCall
    134 
    +       cqL: // global
    135 
    +           call stg_enteredTaggable(R1) args: 8, res: 0, upd: 8;
    163 136 
          }
    164 137 
      },
    165 138 
      M.D_con_entry() { //  []
    166 
    -         { info_tbls: [(cqQ,
    139 
    +         { info_tbls: [(cqM,
    167 140 
                             label: M.D_con_info
    168 141 
                             rep: HeapRep 1 nonptrs { Con {tag: 3 descr:"main:M.D"} }
    169 142 
                             srt: Nothing)]
    170 143 
                stack_info: arg_space: 8
    171 144 
              }
    172 145 
          {offset
    173 
    -       cqQ: // global
    174 
    -           call "ccall" arg hints:  [PtrHint]  result hints:  [] checkEnteredTaggable(cqP_str);   // CmmUnsafeForeignCall
    175 
    -           R1 = R1 + 4;   // CmmAssign
    176 
    -           call (P64[Sp])(R1) args: 8, res: 0, upd: 8;   // CmmCall
    146 
    +       cqM: // global
    147 
    +           call stg_enteredTaggable(R1) args: 8, res: 0, upd: 8;
    177 148 
          }
    178 149 
      },
    179 150 
      M.E_con_entry() { //  []
    180 
    -         { info_tbls: [(cqS,
    151 
    +         { info_tbls: [(cqN,
    181 152 
                             label: M.E_con_info
    182 153 
                             rep: HeapRep 1 nonptrs { Con {tag: 4 descr:"main:M.E"} }
    183 154 
                             srt: Nothing)]
    184 155 
                stack_info: arg_space: 8
    185 156 
              }
    186 157 
          {offset
    187 
    -       cqS: // global
    188 
    -           call "ccall" arg hints:  [PtrHint]  result hints:  [] checkEnteredTaggable(cqR_str);   // CmmUnsafeForeignCall
    189 
    -           R1 = R1 + 5;   // CmmAssign
    190 
    -           call (P64[Sp])(R1) args: 8, res: 0, upd: 8;   // CmmCall
    158 
    +       cqN: // global
    159 
    +           call stg_enteredTaggable(R1) args: 8, res: 0, upd: 8;
    191 160 
          }
    192 161 
      }]
    193 162

  • testsuite/tests/ffi/should_run/T21305_cmm.cmm
    ... ... @@ -2,5 +2,8 @@
    2 2
    3 3 
     f(P_ a, P_ b, P_ c) {
    4 4 
       I64[c + SIZEOF_StgArrBytes + 8] = 770000;
    5 
    -  return (b, a, c);
    5 
    +  // c arrives untagged and is a MutableByteArray#, so it must be returned
    6 
    +  // with tag 1; see Note [Pointer tagging of unlifted boxed primitives] in
    7 
    +  // GHC.StgToCmm.Prim.
    8 
    +  return (b, a, c + 1);
    6 9 
     }

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help