Support large SLIDE instructions.

The bytecode generator used to keep track of the stack depth with a
16-bit counter, which could overflow for very large BCOs, resulting in
incorrect bytecode.

This commit switches to a word-sized counter, and eagerly panics
whenever an operand is too big, instead of truncating the result.

This allows us to work around the 16-bit limitation in the case of SLIDE
instructions, since we can simply factor it into multiple SLIDEs with
smaller arguments.

1 files changed, 66 insertions, 44 deletions

diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index 046d6ec132..c8b1b303b5 100644
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -131,11 +131,11 @@ coreExprToBCOs dflags this_mod expr
 
 type BCInstrList = OrdList BCInstr
 
-type Sequel = Word16 -- back off to this depth before ENTER
+type Sequel = Word -- back off to this depth before ENTER
 
 -- Maps Ids to the offset from the stack _base_ so we don't have
 -- to mess with it after each push/pop.
-type BCEnv = Map Id Word16 -- To find vars on the stack
+type BCEnv = Map Id Word -- To find vars on the stack
 
 {-
 ppBCEnv :: BCEnv -> SDoc
@@ -298,10 +298,10 @@ schemeR_wrk fvs nm original_body (args, body)
                  arity bitmap_size bitmap False{-not alts-})
 
 -- introduce break instructions for ticked expressions
-schemeER_wrk :: Word16 -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
+schemeER_wrk :: Word -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
 schemeER_wrk d p rhs
   | AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs
-  = do  code <- schemeE d 0 p newRhs
+  = do  code <- schemeE (fromIntegral d) 0 p newRhs
         arr <- getBreakArray
         this_mod <- getCurrentModule
         let idOffSets = getVarOffSets d p fvs
@@ -315,16 +315,23 @@ schemeER_wrk d p rhs
                          BA arr# ->
                              BRK_FUN arr# (fromIntegral tick_no) breakInfo
         return $ breakInstr `consOL` code
-   | otherwise = schemeE d 0 p rhs
+   | otherwise = schemeE (fromIntegral d) 0 p rhs
 
-getVarOffSets :: Word16 -> BCEnv -> [Id] -> [(Id, Word16)]
+getVarOffSets :: Word -> BCEnv -> [Id] -> [(Id, Word16)]
 getVarOffSets d p = catMaybes . map (getOffSet d p)
 
-getOffSet :: Word16 -> BCEnv -> Id -> Maybe (Id, Word16)
+getOffSet :: Word -> BCEnv -> Id -> Maybe (Id, Word16)
 getOffSet d env id
    = case lookupBCEnv_maybe id env of
         Nothing     -> Nothing
-        Just offset -> Just (id, d - offset)
+        Just offset -> Just (id, trunc16 $ d - offset)
+
+trunc16 :: Word -> Word16
+trunc16 w
+    | w > fromIntegral (maxBound :: Word16)
+    = panic "stack depth overflow"
+    | otherwise
+    = fromIntegral w
 
 fvsToEnv :: BCEnv -> VarSet -> [Id]
 -- Takes the free variables of a right-hand side, and
@@ -342,7 +349,7 @@ fvsToEnv p fvs = [v | v <- varSetElems fvs,
 -- -----------------------------------------------------------------------------
 -- schemeE
 
-returnUnboxedAtom :: Word16 -> Sequel -> BCEnv
+returnUnboxedAtom :: Word -> Sequel -> BCEnv
                  -> AnnExpr' Id VarSet -> CgRep
                  -> BcM BCInstrList
 -- Returning an unlifted value.
@@ -355,7 +362,7 @@ returnUnboxedAtom d s p e e_rep
 
 -- Compile code to apply the given expression to the remaining args
 -- on the stack, returning a HNF.
-schemeE :: Word16 -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
+schemeE :: Word -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
 
 schemeE d s p e
    | Just e' <- bcView e
@@ -404,7 +411,7 @@ schemeE d s p (AnnLet binds (_,body))
          -- after the closures have been allocated in the heap (but not
          -- filled in), and pointers to them parked on the stack.
          p'    = Map.insertList (zipE xs (mkStackOffsets d (genericReplicate n_binds 1))) p
-         d'    = d + n_binds
+         d'    = d + fromIntegral n_binds
          zipE  = zipEqual "schemeE"
 
          -- ToDo: don't build thunks for things with no free variables
@@ -415,7 +422,7 @@ schemeE d s p (AnnLet binds (_,body))
                      | otherwise  = MKPAP
          build_thunk dd (fv:fvs) size bco off arity = do
               (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv)
-              more_push_code <- build_thunk (dd+pushed_szw) fvs size bco off arity
+              more_push_code <- build_thunk (dd + fromIntegral pushed_szw) fvs size bco off arity
               return (push_code `appOL` more_push_code)
 
          alloc_code = toOL (zipWith mkAlloc sizes arities)
@@ -542,7 +549,7 @@ schemeE _ _ _ expr
 -- 4.  Otherwise, it must be a function call.  Push the args
 --     right to left, SLIDE and ENTER.
 
-schemeT :: Word16       -- Stack depth
+schemeT :: Word         -- Stack depth
         -> Sequel       -- Sequel depth
         -> BCEnv        -- stack env
         -> AnnExpr' Id VarSet
@@ -561,7 +568,7 @@ schemeT d s p app
    = do (push, arg_words) <- pushAtom d p arg
         tagToId_sequence <- implement_tagToId constr_names
         return (push `appOL`  tagToId_sequence
-                       `appOL`  mkSLIDE 1 (d+arg_words-s)
+                       `appOL`  mkSLIDE 1 (d - s + fromIntegral arg_words)
                        `snocOL` ENTER)
 
    -- Case 1
@@ -625,7 +632,7 @@ schemeT d s p app
 -- Generate code to build a constructor application,
 -- leaving it on top of the stack
 
-mkConAppCode :: Word16 -> Sequel -> BCEnv
+mkConAppCode :: Word -> Sequel -> BCEnv
              -> DataCon                 -- The data constructor
              -> [AnnExpr' Id VarSet]    -- Args, in *reverse* order
              -> BcM BCInstrList
@@ -646,12 +653,12 @@ mkConAppCode orig_d _ p con args_r_to_l
 
       do_pushery d (arg:args)
          = do (push, arg_words) <- pushAtom d p arg
-              more_push_code <- do_pushery (d+arg_words) args
+              more_push_code <- do_pushery (d + fromIntegral arg_words) args
               return (push `appOL` more_push_code)
       do_pushery d []
          = return (unitOL (PACK con n_arg_words))
          where
-           n_arg_words = d - orig_d
+           n_arg_words = trunc16 $ d - orig_d
 
 
 -- -----------------------------------------------------------------------------
@@ -662,19 +669,19 @@ mkConAppCode orig_d _ p con args_r_to_l
 -- returned, even if it is a pointed type.  We always just return.
 
 unboxedTupleReturn
-        :: Word16 -> Sequel -> BCEnv
+        :: Word -> Sequel -> BCEnv
         -> AnnExpr' Id VarSet -> BcM BCInstrList
 unboxedTupleReturn d s p arg = do
   (push, sz) <- pushAtom d p arg
   return (push                      `appOL`
-          mkSLIDE sz (d-s)          `snocOL`
+          mkSLIDE sz (d - s)        `snocOL`
           RETURN_UBX (atomRep arg))
 
 -- -----------------------------------------------------------------------------
 -- Generate code for a tail-call
 
 doTailCall
-        :: Word16 -> Sequel -> BCEnv
+        :: Word -> Sequel -> BCEnv
         -> Id -> [AnnExpr' Id VarSet]
         -> BcM BCInstrList
 doTailCall init_d s p fn args
@@ -685,7 +692,7 @@ doTailCall init_d s p fn args
         (push_fn, sz) <- pushAtom d p (AnnVar fn)
         ASSERT( sz == 1 ) return ()
         return (push_fn `appOL` (
-                  mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL`
+                  mkSLIDE (trunc16 $ d - init_d + 1) (init_d - s) `appOL`
                   unitOL ENTER))
   do_pushes d args reps = do
       let (push_apply, n, rest_of_reps) = findPushSeq reps
@@ -698,7 +705,7 @@ doTailCall init_d s p fn args
   push_seq d [] = return (d, nilOL)
   push_seq d (arg:args) = do
     (push_code, sz) <- pushAtom d p arg
-    (final_d, more_push_code) <- push_seq (d+sz) args
+    (final_d, more_push_code) <- push_seq (d + fromIntegral sz) args
     return (final_d, push_code `appOL` more_push_code)
 
 -- v. similar to CgStackery.findMatch, ToDo: merge
@@ -731,7 +738,7 @@ findPushSeq _
 -- -----------------------------------------------------------------------------
 -- Case expressions
 
-doCase  :: Word16 -> Sequel -> BCEnv
+doCase  :: Word -> Sequel -> BCEnv
         -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
         -> Bool  -- True <=> is an unboxed tuple case, don't enter the result
         -> BcM BCInstrList
@@ -741,10 +748,12 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
         -- underneath it is the pointer to the alt_code BCO.
         -- When an alt is entered, it assumes the returned value is
         -- on top of the itbl.
+        ret_frame_sizeW :: Word
         ret_frame_sizeW = 2
 
         -- An unlifted value gets an extra info table pushed on top
         -- when it is returned.
+        unlifted_itbl_sizeW :: Word
         unlifted_itbl_sizeW | isAlgCase = 0
                             | otherwise = 1
 
@@ -758,7 +767,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
 
         -- Env in which to compile the alts, not including
         -- any vars bound by the alts themselves
-        p_alts = Map.insert bndr (d_bndr - 1) p
+        p_alts = Map.insert bndr (fromIntegral d_bndr - 1) p
 
         bndr_ty = idType bndr
         isAlgCase = not (isUnLiftedType bndr_ty) && not is_unboxed_tuple
@@ -788,8 +797,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
                         p_alts
              in do
              MASSERT(isAlgCase)
-             rhs_code <- schemeE (d_alts+size) s p' rhs
-             return (my_discr alt, unitOL (UNPACK size) `appOL` rhs_code)
+             rhs_code <- schemeE (d_alts + size) s p' rhs
+             return (my_discr alt, unitOL (UNPACK (trunc16 size)) `appOL` rhs_code)
 	   where
 	     real_bndrs = filterOut isTyVar bndrs
 
@@ -828,7 +837,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
         -- really want a bitmap up to depth (d-s).  This affects compilation of
         -- case-of-case expressions, which is the only time we can be compiling a
         -- case expression with s /= 0.
-        bitmap_size = d-s
+        bitmap_size = trunc16 $ d-s
         bitmap_size' :: Int
         bitmap_size' = fromIntegral bitmap_size
         bitmap = intsToReverseBitmap bitmap_size'{-size-}
@@ -839,7 +848,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
           spread (id, offset)
                 | isFollowableArg (idCgRep id) = [ rel_offset ]
                 | otherwise = []
-                where rel_offset = d - offset - 1
+                where rel_offset = trunc16 $ d - fromIntegral offset - 1
 
      in do
      alt_stuff <- mapM codeAlt alts
@@ -852,7 +861,9 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
      -- in
 --     trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
 --            "\n      bitmap = " ++ show bitmap) $ do
-     scrut_code <- schemeE (d + ret_frame_sizeW) (d + ret_frame_sizeW) p scrut
+     scrut_code <- schemeE (d + ret_frame_sizeW)
+                           (d + ret_frame_sizeW)
+                           p scrut
      alt_bco' <- emitBc alt_bco
      let push_alts
             | isAlgCase = PUSH_ALTS alt_bco'
@@ -869,7 +880,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
 -- (machine) code for the ccall, and create bytecodes to call that and
 -- then return in the right way.
 
-generateCCall :: Word16 -> Sequel       -- stack and sequel depths
+generateCCall :: Word -> Sequel         -- stack and sequel depths
               -> BCEnv
               -> CCallSpec              -- where to call
               -> Id                     -- of target, for type info
@@ -896,25 +907,25 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
                     -- contains.
                     Just t
                      | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
-                       -> do rest <- pargs (d + addr_sizeW) az
+                       -> do rest <- pargs (d + fromIntegral addr_sizeW) az
                              code <- parg_ArrayishRep (fromIntegral arrPtrsHdrSize) d p a
                              return ((code,AddrRep):rest)
 
                      | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
-                       -> do rest <- pargs (d + addr_sizeW) az
+                       -> do rest <- pargs (d + fromIntegral addr_sizeW) az
                              code <- parg_ArrayishRep (fromIntegral arrWordsHdrSize) d p a
                              return ((code,AddrRep):rest)
 
                     -- Default case: push taggedly, but otherwise intact.
                     _
                        -> do (code_a, sz_a) <- pushAtom d p a
-                             rest <- pargs (d+sz_a) az
+                             rest <- pargs (d + fromIntegral sz_a) az
                              return ((code_a, atomPrimRep a) : rest)
 
          -- Do magic for Ptr/Byte arrays.  Push a ptr to the array on
          -- the stack but then advance it over the headers, so as to
          -- point to the payload.
-         parg_ArrayishRep :: Word16 -> Word16 -> BCEnv -> AnnExpr' Id VarSet
+         parg_ArrayishRep :: Word16 -> Word -> BCEnv -> AnnExpr' Id VarSet
                           -> BcM BCInstrList
          parg_ArrayishRep hdrSize d p a
             = do (push_fo, _) <- pushAtom d p a
@@ -1016,14 +1027,14 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
          (push_Addr, d_after_Addr)
             | is_static
             = (toOL [PUSH_UBX (Right static_target_addr) addr_sizeW],
-               d_after_args + addr_sizeW)
+               d_after_args + fromIntegral addr_sizeW)
             | otherwise -- is already on the stack
             = (nilOL, d_after_args)
 
          -- Push the return placeholder.  For a call returning nothing,
          -- this is a VoidArg (tag).
          r_sizeW   = fromIntegral (primRepSizeW r_rep)
-         d_after_r = d_after_Addr + r_sizeW
+         d_after_r = d_after_Addr + fromIntegral r_sizeW
          r_lit     = mkDummyLiteral r_rep
          push_r    = (if   returns_void
                       then nilOL
@@ -1035,7 +1046,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
          -- instruction needs to describe the chunk of stack containing
          -- the ccall args to the GC, so it needs to know how large it
          -- is.  See comment in Interpreter.c with the CCALL instruction.
-         stk_offset   = d_after_r - s
+         stk_offset   = trunc16 $ d_after_r - s
 
      -- in
      -- the only difference in libffi mode is that we prepare a cif
@@ -1050,7 +1061,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
          do_call      = unitOL (CCALL stk_offset (castFunPtrToPtr addr_of_marshaller)
                                  (fromIntegral (fromEnum (playInterruptible safety))))
          -- slide and return
-         wrapup       = mkSLIDE r_sizeW (d_after_r - r_sizeW - s)
+         wrapup       = mkSLIDE r_sizeW (d_after_r - fromIntegral r_sizeW - s)
                         `snocOL` RETURN_UBX (primRepToCgRep r_rep)
      --in
          --trace (show (arg1_offW, args_offW  ,  (map cgRepSizeW a_reps) )) $
@@ -1150,7 +1161,7 @@ implement_tagToId names
 -- to 5 and not to 4.  Stack locations are numbered from zero, so a
 -- depth 6 stack has valid words 0 .. 5.
 
-pushAtom :: Word16 -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Word16)
+pushAtom :: Word -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Word16)
 
 pushAtom d p e
    | Just e' <- bcView e
@@ -1170,7 +1181,7 @@ pushAtom d p (AnnVar v)
    = return (unitOL (PUSH_PRIMOP primop), 1)
 
    | Just d_v <- lookupBCEnv_maybe v p  -- v is a local variable
-   = let l = d - d_v + sz - 2
+   = let l = trunc16 $ d - d_v + fromIntegral sz - 2
      in return (toOL (genericReplicate sz (PUSH_L l)), sz)
          -- d - d_v                 the number of words between the TOS
          --                         and the 1st slot of the object
@@ -1401,7 +1412,7 @@ instance Outputable Discr where
    ppr NoDiscr    = text "DEF"
 
 
-lookupBCEnv_maybe :: Id -> BCEnv -> Maybe Word16
+lookupBCEnv_maybe :: Id -> BCEnv -> Maybe Word
 lookupBCEnv_maybe = Map.lookup
 
 idSizeW :: Id -> Int
@@ -1417,8 +1428,19 @@ unboxedTupleException
             "  Workaround: use -fobject-code, or compile this module to .o separately."))
 
 
-mkSLIDE :: Word16 -> Word16 -> OrdList BCInstr
-mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d)
+mkSLIDE :: Word16 -> Word -> OrdList BCInstr
+mkSLIDE n d
+    -- if the amount to slide doesn't fit in a word,
+    -- generate multiple slide instructions
+    | d > fromIntegral limit
+    = SLIDE n limit `consOL` mkSLIDE n (d - fromIntegral limit)
+    | d == 0
+    = nilOL
+    | otherwise
+    = if d == 0 then nilOL else unitOL (SLIDE n $ fromIntegral d)
+    where
+        limit :: Word16
+        limit = maxBound
 
 splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann])
         -- The arguments are returned in *right-to-left* order
@@ -1465,7 +1487,7 @@ isPtrAtom e = atomRep e == PtrArg
 -- Let szsw be the sizes in words of some items pushed onto the stack,
 -- which has initial depth d'.  Return the values which the stack environment
 -- should map these items to.
-mkStackOffsets :: Word16 -> [Word16] -> [Word16]
+mkStackOffsets :: Word -> [Word] -> [Word]
 mkStackOffsets original_depth szsw
    = map (subtract 1) (tail (scanl (+) original_depth szsw))